From 0490ee1f0996fcd1f360e2c5fdae488cd36e2a17 Mon Sep 17 00:00:00 2001 From: Lemmih Date: Fri, 10 Mar 2006 02:05:14 +0000 Subject: [PATCH] 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'. --- ghc/quickcheck/HeaderInfoTests.hs | 129 +++++++++++++++++++++++++++++++++++++ ghc/quickcheck/README | 9 +++ ghc/quickcheck/RunTests.hs | 62 ++++++++++++++++++ ghc/quickcheck/run.sh | 23 +++++++ 4 files changed, 223 insertions(+) create mode 100644 ghc/quickcheck/HeaderInfoTests.hs create mode 100644 ghc/quickcheck/README create mode 100644 ghc/quickcheck/RunTests.hs create mode 100644 ghc/quickcheck/run.sh diff --git a/ghc/quickcheck/HeaderInfoTests.hs b/ghc/quickcheck/HeaderInfoTests.hs new file mode 100644 index 0000000..6f8bef6 --- /dev/null +++ b/ghc/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" diff --git a/ghc/quickcheck/README b/ghc/quickcheck/README new file mode 100644 index 0000000..251bc80 --- /dev/null +++ b/ghc/quickcheck/README @@ -0,0 +1,9 @@ +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. diff --git a/ghc/quickcheck/RunTests.hs b/ghc/quickcheck/RunTests.hs new file mode 100644 index 0000000..4aabb48 --- /dev/null +++ b/ghc/quickcheck/RunTests.hs @@ -0,0 +1,62 @@ +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" + diff --git a/ghc/quickcheck/run.sh b/ghc/quickcheck/run.sh new file mode 100644 index 0000000..cff728a --- /dev/null +++ b/ghc/quickcheck/run.sh @@ -0,0 +1,23 @@ +#!/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 -- 1.7.10.4