Use work-stealing for load-balancing in the GC
[ghc.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"