--- /dev/null
+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"
--- /dev/null
+module RunTests where
+
+import Test.QuickCheck.Batch hiding (runTests)
+import System.Exit
+import System.Environment
+
+import HeaderInfoTests as HI
+
+runUnitTests :: Bool -> IO ()
+runUnitTests debug = exitWith =<< performTests debug
+
+performTests :: Bool -> IO ExitCode
+performTests debug =
+ do e1 <- exeTests "HeaderInfo" opts
+ [ run HI.prop_optionsIdentity
+ , run HI.prop_languageParse
+ , run HI.prop_languageError ]
+ return (foldr1 cat [e1])
+ where opts = TestOptions 100 10 debug
+ cat (e@(ExitFailure _)) _ = e
+ cat _ e = e
+
+exeTests :: String -> TestOptions -> [TestOptions -> IO TestResult] -> IO ExitCode
+exeTests name scale actions =
+ do putStr (rjustify 25 name ++ " : ")
+ tr 1 actions [] 0 False
+ where
+ rjustify n s = replicate (max 0 (n - length s)) ' ' ++ s
+ tr n [] xs c e = do
+ putStr (rjustify (max 0 (35-n)) " (" ++ show c ++ ")\n")
+ mapM_ fa xs
+ if e
+ then return (ExitFailure 1)
+ else return ExitSuccess
+ tr n (action:actions) others c e =
+ do r <- action scale
+ case r of
+ (TestOk _ m _)
+ -> do { putStr "." ;
+ tr (n+1) actions others (c+m) e }
+ (TestExausted s m ss)
+ -> do { putStr "?" ;
+ tr (n+1) actions others (c+m) e }
+ (TestAborted e)
+ -> do { print e;
+ putStr "*" ;
+ tr (n+1) actions others c True }
+ (TestFailed f num)
+ -> do { putStr "#" ;
+ tr (n+1) actions ((f,n,num):others) (c+num) True }
+ fa :: ([String],Int,Int) -> IO ()
+ fa (f,n,no) =
+ do putStr "\n"
+ putStr (" ** test "
+ ++ show (n :: Int)
+ ++ " of "
+ ++ name
+ ++ " failed with the binding(s)\n")
+ sequence_ [putStr (" ** " ++ v ++ "\n")
+ | v <- f ]
+ putStr "\n"
+