module HeaderInfoTests
    ( prop_optionsIdentity
    , prop_languageParse
    , prop_languageError
    ) where

import Test.QuickCheck
import Test.QuickCheck.Batch
import Data.Char

import Control.Monad
import System.IO.Unsafe

import HeaderInfo
import StringBuffer
import SrcLoc

import Language.Haskell.Extension

newtype CmdOptions = CmdOptions {cmdOptions :: [String]}
    deriving Show

instance Arbitrary CmdOptions where
    arbitrary = resize 30 $ liftM CmdOptions arbitrary
    coarbitrary = undefined

instance Arbitrary Char where
    arbitrary = elements $ ['a'..'z']++['A'..'Z']
    coarbitrary = undefined

data Options = Options
             | Options_GHC
               deriving Show

instance Arbitrary Options where
    arbitrary = elements [Options,Options_GHC]
    coarbitrary = undefined

-- Test that OPTIONS are correctly extracted from a buffer
-- with comments and garbage.
prop_optionsIdentity lowercase options cmds
    = not (null cmds) ==>
      all (all (not.null).cmdOptions) cmds ==>
      concatMap cmdOptions cmds == map unLoc (getOptions buffer "somefile")
    where buffer = unsafePerformIO $ stringToStringBuffer str
          str = concatMap mkPragma cmds ++
                "\n @#@# garbage #@#@ \n"
          mkPragma (CmdOptions cmd)
              = unlines [ "-- Pragma: "
                        , unwords $ ["{-#", pragma]++cmd++["#-}"]
                        , "{- End of pragma -}" ]
          pragma = (if lowercase then map toLower else map toUpper) $ 
                   case options of
                     Options -> "OPTIONS"
                     Options_GHC -> "OPTIONS_GHC"

newtype Extensions = Extensions [Extension]
    deriving Show

instance Arbitrary Extensions where
    arbitrary = resize 30 $ liftM Extensions arbitrary
    coarbitrary = undefined

extensions :: [Extension]
extensions = [ OverlappingInstances
             , UndecidableInstances
             , IncoherentInstances
             , RecursiveDo
             , ParallelListComp
             , MultiParamTypeClasses
             , NoMonomorphismRestriction
             , FunctionalDependencies
             , Rank2Types
             , RankNTypes
             , PolymorphicComponents
             , ExistentialQuantification
             , ScopedTypeVariables
             , ImplicitParams
             , FlexibleContexts
             , FlexibleInstances
             , EmptyDataDecls
             , CPP
             , TypeSynonymInstances
             , TemplateHaskell
             , ForeignFunctionInterface
             , InlinePhase
             , ContextStack
             , Arrows
             , Generics
             , NoImplicitPrelude
             , NamedFieldPuns
             , PatternGuards
             , GeneralizedNewtypeDeriving
             , ExtensibleRecords
             , RestrictedTypeSynonyms
             , HereDocuments ]

-- derive Enum for Extension?
instance Arbitrary Extension where
    arbitrary = elements extensions
    coarbitrary = undefined

-- Test that we can parse all known extensions.
prop_languageParse lowercase (Extensions exts)
    = not (null exts) ==>
      not (isBottom (getOptions buffer "somefile"))
    where buffer = unsafePerformIO $ stringToStringBuffer str
          str = unlines [ "-- Pragma: "
                        , unwords $ ["{-#", pragma, ppExts exts "" , "#-}"]
                        , "{- End of pragma -}"
                        , "garbage#@$#$" ]
          ppExts [e] = shows e
          ppExts (x:xs) = shows x . showChar ',' . ppExts xs
          ppExts [] = id
          pragma = (if lowercase then map toLower else map toUpper)
                   "LANGUAGE"

-- Test that invalid extensions cause exceptions.
prop_languageError lowercase ext
    = not (null ext) ==>
      ext `notElem` map show extensions ==>
      isBottom (foldr seq () (getOptions buffer "somefile"))
    where buffer = unsafePerformIO $ stringToStringBuffer str
          str = unlines [ "-- Pragma: "
                        , unwords $ ["{-#", pragma, ext , "#-}"]
                        , "{- End of pragma -}"
                        , "garbage#@$#$" ]
          pragma = (if lowercase then map toLower else map toUpper)
                   "LANGUAGE"