X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=quickcheck%2FHeaderInfoTests.hs;fp=quickcheck%2FHeaderInfoTests.hs;h=6f8bef6239b190b35955b927ff981e90369ffba3;hp=0000000000000000000000000000000000000000;hb=422eaf986e456ed0e16647445f7bdcb3018eb6c2;hpb=693342ffbb61e1da4c009059755fa0b9b1396bb8

diff --git a/quickcheck/HeaderInfoTests.hs b/quickcheck/HeaderInfoTests.hs
new file mode 100644
index 0000000..6f8bef6
--- /dev/null
+++ b/quickcheck/HeaderInfoTests.hs
@@ -0,0 +1,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"