1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
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"
|
