Improved VectInfo
[ghc-hetmet.git] / quickcheck / HeaderInfoTests.hs
1 module HeaderInfoTests
2     ( prop_optionsIdentity
3     , prop_languageParse
4     , prop_languageError
5     ) where
6
7 import Test.QuickCheck
8 import Test.QuickCheck.Batch
9 import Data.Char
10
11 import Control.Monad
12 import System.IO.Unsafe
13
14 import HeaderInfo
15 import StringBuffer
16 import SrcLoc
17
18 import Language.Haskell.Extension
19
20 newtype CmdOptions = CmdOptions {cmdOptions :: [String]}
21     deriving Show
22
23 instance Arbitrary CmdOptions where
24     arbitrary = resize 30 $ liftM CmdOptions arbitrary
25     coarbitrary = undefined
26
27 instance Arbitrary Char where
28     arbitrary = elements $ ['a'..'z']++['A'..'Z']
29     coarbitrary = undefined
30
31 data Options = Options
32              | Options_GHC
33                deriving Show
34
35 instance Arbitrary Options where
36     arbitrary = elements [Options,Options_GHC]
37     coarbitrary = undefined
38
39 -- Test that OPTIONS are correctly extracted from a buffer
40 -- with comments and garbage.
41 prop_optionsIdentity lowercase options cmds
42     = not (null cmds) ==>
43       all (all (not.null).cmdOptions) cmds ==>
44       concatMap cmdOptions cmds == map unLoc (getOptions buffer "somefile")
45     where buffer = unsafePerformIO $ stringToStringBuffer str
46           str = concatMap mkPragma cmds ++
47                 "\n @#@# garbage #@#@ \n"
48           mkPragma (CmdOptions cmd)
49               = unlines [ "-- Pragma: "
50                         , unwords $ ["{-#", pragma]++cmd++["#-}"]
51                         , "{- End of pragma -}" ]
52           pragma = (if lowercase then map toLower else map toUpper) $ 
53                    case options of
54                      Options -> "OPTIONS"
55                      Options_GHC -> "OPTIONS_GHC"
56
57 newtype Extensions = Extensions [Extension]
58     deriving Show
59
60 instance Arbitrary Extensions where
61     arbitrary = resize 30 $ liftM Extensions arbitrary
62     coarbitrary = undefined
63
64 extensions :: [Extension]
65 extensions = [ OverlappingInstances
66              , UndecidableInstances
67              , IncoherentInstances
68              , RecursiveDo
69              , ParallelListComp
70              , MultiParamTypeClasses
71              , NoMonomorphismRestriction
72              , FunctionalDependencies
73              , Rank2Types
74              , RankNTypes
75              , PolymorphicComponents
76              , ExistentialQuantification
77              , ScopedTypeVariables
78              , ImplicitParams
79              , FlexibleContexts
80              , FlexibleInstances
81              , EmptyDataDecls
82              , CPP
83              , TypeSynonymInstances
84              , TemplateHaskell
85              , ForeignFunctionInterface
86              , InlinePhase
87              , ContextStack
88              , Arrows
89              , Generics
90              , NoImplicitPrelude
91              , NamedFieldPuns
92              , PatternGuards
93              , GeneralizedNewtypeDeriving
94              , ExtensibleRecords
95              , RestrictedTypeSynonyms
96              , HereDocuments ]
97
98 -- derive Enum for Extension?
99 instance Arbitrary Extension where
100     arbitrary = elements extensions
101     coarbitrary = undefined
102
103 -- Test that we can parse all known extensions.
104 prop_languageParse lowercase (Extensions exts)
105     = not (null exts) ==>
106       not (isBottom (getOptions buffer "somefile"))
107     where buffer = unsafePerformIO $ stringToStringBuffer str
108           str = unlines [ "-- Pragma: "
109                         , unwords $ ["{-#", pragma, ppExts exts "" , "#-}"]
110                         , "{- End of pragma -}"
111                         , "garbage#@$#$" ]
112           ppExts [e] = shows e
113           ppExts (x:xs) = shows x . showChar ',' . ppExts xs
114           ppExts [] = id
115           pragma = (if lowercase then map toLower else map toUpper)
116                    "LANGUAGE"
117
118 -- Test that invalid extensions cause exceptions.
119 prop_languageError lowercase ext
120     = not (null ext) ==>
121       ext `notElem` map show extensions ==>
122       isBottom (foldr seq () (getOptions buffer "somefile"))
123     where buffer = unsafePerformIO $ stringToStringBuffer str
124           str = unlines [ "-- Pragma: "
125                         , unwords $ ["{-#", pragma, ext , "#-}"]
126                         , "{- End of pragma -}"
127                         , "garbage#@$#$" ]
128           pragma = (if lowercase then map toLower else map toUpper)
129                    "LANGUAGE"