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"