Commit 0490ee1f authored by David Himmelstrup's avatar David Himmelstrup
Browse files

Initial foundation for quickcheck tests.

I have no idea how to use the testsuite so I'll start
making QuickCheck tests instead.
I've included tests for 'HeaderInfo.getOptions'.
parent d700953c
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"
QuickCheck for the GHC library.
Requirements:
stage2 of ghc.
Usage:
./run.sh
./run.sh debug # runs quickCheck in debug mode.
./run.sh ghci [file] # loads [file] with the stage2 compiler.
module RunTests where
import Test.QuickCheck.Batch hiding (runTests)
import System.Exit
import System.Environment
import HeaderInfoTests as HI
runUnitTests :: Bool -> IO ()
runUnitTests debug = exitWith =<< performTests debug
performTests :: Bool -> IO ExitCode
performTests debug =
do e1 <- exeTests "HeaderInfo" opts
[ run HI.prop_optionsIdentity
, run HI.prop_languageParse
, run HI.prop_languageError ]
return (foldr1 cat [e1])
where opts = TestOptions 100 10 debug
cat (e@(ExitFailure _)) _ = e
cat _ e = e
exeTests :: String -> TestOptions -> [TestOptions -> IO TestResult] -> IO ExitCode
exeTests name scale actions =
do putStr (rjustify 25 name ++ " : ")
tr 1 actions [] 0 False
where
rjustify n s = replicate (max 0 (n - length s)) ' ' ++ s
tr n [] xs c e = do
putStr (rjustify (max 0 (35-n)) " (" ++ show c ++ ")\n")
mapM_ fa xs
if e
then return (ExitFailure 1)
else return ExitSuccess
tr n (action:actions) others c e =
do r <- action scale
case r of
(TestOk _ m _)
-> do { putStr "." ;
tr (n+1) actions others (c+m) e }
(TestExausted s m ss)
-> do { putStr "?" ;
tr (n+1) actions others (c+m) e }
(TestAborted e)
-> do { print e;
putStr "*" ;
tr (n+1) actions others c True }
(TestFailed f num)
-> do { putStr "#" ;
tr (n+1) actions ((f,n,num):others) (c+num) True }
fa :: ([String],Int,Int) -> IO ()
fa (f,n,no) =
do putStr "\n"
putStr (" ** test "
++ show (n :: Int)
++ " of "
++ name
++ " failed with the binding(s)\n")
sequence_ [putStr (" ** " ++ v ++ "\n")
| v <- f ]
putStr "\n"
#!/bin/sh
# I suck at bash scripting. Please feel free to make this code better.
Root=../compiler
ExtraOptions="-cpp -fglasgow-exts -package ghc"
HC=$Root/stage2/ghc-inplace
Debug="False"
if [ "$1" == "debug" ]
then
Debug="True"
fi
if [ "$1" == "ghci" ]
then
$HC --interactive $ExtraOptions $2
else
$HC --interactive -e "runUnitTests $Debug" $ExtraOptions RunTests.hs
fi
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment