diff --git a/HTF.cabal b/HTF.cabal --- a/HTF.cabal +++ b/HTF.cabal @@ -1,39 +1,64 @@ Name: HTF -Version: 0.1 +Version: 0.3 License: LGPL -License-file: LICENSE -Author: Stefan Wehr +License-File: LICENSE +Copyright: (c) 2005-2010 Stefan Wehr +Author: Stefan Wehr +Maintainer: Stefan Wehr +Bug-Reports: mailto:mail@stefanwehr.de Stability: Beta Category: Testing Synopsis: The Haskell Test Framework -Description: The HTF lets you write HUnit tests (http://hunit.sourceforge.net) - and QuickCheck (http://www.cs.chalmers.se/~rjmh/QuickCheck/) properties - in an easy and convenient way. Additionally, the HTF provides a facility - for testing programs by running them and comparing the actual output with - the expected output (so called "file-based tests"). +Description: - The HTF uses Template Haskell to collect all tests and properties, - so you do not need to write boilerplate code for that purpose. - Preprocessor macros provide you with file name and line number information - for tests and properties that failed. -homepage: http://www.informatik.uni-freiburg.de/~wehr/software/haskell/ + The Haskell Test Framework (/HTF/ for short) lets you define unit + tests (), QuickCheck properties + (), and black box + tests in an easy and convenient way. The HTF uses a custom + preprocessor that collects test definitions automatically. + Furthermore, the preprocessor allows the HTF to report failing + test cases with exact file name and line number information. -tested-with: GHC==6.8.2 -Build-Depends: HUnit, QuickCheck<2, template-haskell, base>3, random, containers, process, directory + . + + The documentation of the "Test.Framework.Tutorial" module + provides a tutorial for the HTF. + +Tested-With: GHC==6.10.4 Build-Type: Simple +Cabal-Version: >= 1.6 +Extra-Source-Files: + README + TODO -Exposed-Modules: Test.Framework -Other-Modules: - Test.Framework.Location - Test.Framework.HUnitWrapper - Test.Framework.QuickCheckWrapper - Test.Framework.Configuration - Test.Framework.Process - Test.Framework.FileBasedTest - Test.Framework.Utils +Executable htfpp + Main-Is: HTFPP.hs + Build-Depends: cpphs >= 1.11, + haskell-src-exts >= 1.8.2, + base >= 4 && < 5 + Other-Modules: + Test.Framework.Preprocessor + Test.Framework.HaskellParser -Executable: htf-pp -Main-Is: HTFpp.hs -Hs-Source-Dirs: scripts, . -Other-Modules: Test.Framework.Process -ghc-options: -threaded -Wall +Library + Build-Depends: HUnit >= 1.2, + QuickCheck >= 2, + base >= 4 && < 5, + random, + containers, + process, + directory, + mtl, + pretty + Exposed-Modules: + Test.Framework + Test.Framework.HUnitWrapper + Test.Framework.TestManager + Test.Framework.QuickCheckWrapper + Test.Framework.BlackBoxTest + Test.Framework.Location + Test.Framework.Tutorial + Test.Framework.Pretty + Other-Modules: + Test.Framework.Utils + Test.Framework.Process diff --git a/HTFPP.hs b/HTFPP.hs new file mode 100644 --- /dev/null +++ b/HTFPP.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- +-- Copyright (c) 2009 Stefan Wehr - http://www.stefanwehr.de +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA +-- + +import Prelude hiding ( catch ) +import System.IO +import System.Environment +import System.Exit +import Control.Monad +import Control.Exception + +import Test.Framework.Preprocessor + +usage :: IO () +usage = + hPutStrLn stderr + ("Preprocessor for the Haskell Test Framework\n\n" ++ + "Usage: " ++ progName ++ " [FILE1 [FILE2 [FILE3]]]\n\n" ++ + "* If no argument is given, input is read from stdin and\n" ++ + " output is written to stdout.\n" ++ + "* If only FILE1 is given, input is read from this file\n" ++ + " and output is written to stdout.\n" ++ + "* If FILE1 and FILE2 are given, input is read from FILE1\n" ++ + " and output is written to FILE2.\n" ++ + "* If FILE1, FILE2, and FILE3 are given, input is read\n" ++ + " from FILE2, output is written to FILE3, and\n" ++ + " FILE1 serves as the original input filename.") + +saveOpenFile :: FilePath -> IOMode -> IO Handle +saveOpenFile path mode = + openFile path mode `catch` exHandler + where + exHandler :: SomeException -> IO Handle + exHandler e = + do hPutStrLn stderr ("Error opening file " ++ path ++ ": " ++ + show e) + exitWith (ExitFailure 1) + +main = + do args <- getArgs + when ("-h" `elem` args || + "-help" `elem` args || + "--help" `elem` args) $ + do usage + exitWith (ExitFailure 1) + (origInputFilename, hIn, hOut) <- + case args of + [] -> + return ("", stdin, stdout) + file1:[] -> + do h <- saveOpenFile file1 ReadMode + return (file1, h, stdout) + file1:file2:[] -> + do h1 <- saveOpenFile file1 ReadMode + h2 <- saveOpenFile file2 WriteMode + return (file1, h1, h2) + file1:file2:file3:[] -> + do h1 <- saveOpenFile file2 ReadMode + h2 <- saveOpenFile file3 WriteMode + return (file1, h1, h2) + _ -> + do usage + exitWith (ExitFailure 1) + input <- hGetContents hIn + output <- transform origInputFilename input `catch` + (\ (e::SomeException) -> + do hPutStrLn stderr (progName ++ + ": unexpected exception: " ++ + show e) + return ("#line 1 " ++ show origInputFilename ++ + "\n" ++ input)) + hPutStr hOut output + hFlush hOut diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,35 @@ + HTF - The Haskell Test Framework + ==================================== + +Author: Stefan Wehr +License: LGPL + +The Haskell Test Framework (HTF for short) lets you define unit tests +(http://hunit.sourceforge.net), QuickCheck properties +(http://www.cs.chalmers.se/~rjmh/QuickCheck/), and black box tests in an +easy and convenient way. The HTF uses a custom preprocessor that collects +test definitions automatically. Furthermore, the preprocessor allows the +HTF to report failing test cases with exact file name and line number +information. + +The documentation of the Test.Framework.Tutorial module provides a +tutorial for the HTF. + +NOTE: If you use black box tests, you have to compile your program +with the `-threaded' option. Otherwise, your program just blocks +indefinitely! + + +Requirements: +------------- + +- GHC (tested with 6.10.4) +- Some haskell libraries, see HTF.cabal + + +Installation instructions: +-------------------------- + +runhaskell setup.hs configure +runhaskell setup.hs build +runhaskell setup.hs install (probably as root) diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -2,4 +2,4 @@ import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks +main = defaultMain diff --git a/TODO b/TODO new file mode 100644 --- /dev/null +++ b/TODO @@ -0,0 +1,4 @@ +* Replace haskell-src-exts by the GHC parser +* Write proper documentation +* diff if assertEqualsP fails +* LATER: Support for Smallcheck and/or Lazy Smallcheck diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -1,7 +1,7 @@ -{-# OPTIONS -fth #-} +{-# LANGUAGE TemplateHaskell #-} -- --- Copyright (c) 2005 Stefan Wehr - http://www.stefanwehr.de +-- Copyright (c) 2005,2009 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public @@ -20,64 +20,19 @@ module Test.Framework ( - module HU, module QC, module FBT, + module Test.Framework.HUnitWrapper, + module Test.Framework.QuickCheckWrapper, + module Test.Framework.BlackBoxTest, + module Test.Framework.TestManager, - tests + Loc.makeLoc ) where -import Data.Maybe -import Language.Haskell.TH - -import Test.Framework.HUnitWrapper as HU -import Test.Framework.QuickCheckWrapper as QC -import Test.Framework.FileBasedTest as FBT +import Test.Framework.HUnitWrapper +import Test.Framework.QuickCheckWrapper +import Test.Framework.BlackBoxTest +import Test.Framework.TestManager +import qualified Test.Framework.Location as Loc -tests :: String -> Q [Dec] -> Q [Dec] -tests name decs = - do decs' <- decs - -- runIO $ putStrLn (show decs') - moduleName <- currentModule - let ts = collectTests decs' - props = collectProps decs' - testName = moduleName ++ "." ++ name - e <- [| HU.TestLabel testName - (HU.TestList $(listE (map mkExp ts ++ - map (mkPropExp testName) props))) |] - let lete = LetE decs' e - suiteDec = ValD (VarP (mkName name)) (NormalB lete) [] - resDecs = [suiteDec] - -- runIO $ putStrLn (show props) --(pprint resDecs) - return resDecs - where - collectTests :: [Dec] -> [Name] - collectTests = mapMaybe f - where f (ValD (VarP name) _ _) | isTestName (nameBase name) = Just name - f _ = Nothing - collectProps :: [Dec] -> [(Name, String, Bool)] - collectProps = mapMaybe f - where f (ValD (VarP name) _ _) = analyzePropName name - f (FunD name _) = analyzePropName name - f _ = Nothing - isTestName :: String -> Bool - isTestName ('t':'e':'s':'t':'_':s) | not (null s) = True - isTestName _ = False - analyzePropName :: Name -> Maybe (Name, String, Bool) - analyzePropName name = - case nameBase name of - ('p':'r':'o':'p':'_':'c':'f':'g':'_':s) - | not (null s) -> Just (name, s, True) - ('p':'r':'o':'p':'_':s) - | not (null s) -> Just (name, s, False) - _ -> Nothing - mkExp :: Name -> Q Exp - mkExp name = - let s = nameBase name - in [| HU.TestLabel s (HU.TestCase $(varE name)) |] - mkPropExp :: String -> (Name, String, Bool) -> Q Exp - mkPropExp testName (name, s, customCfg) = - let fullName = testName `joinPathElems` s - exp = if customCfg then [| $(varE name) |] - else [| (id, $(varE name)) |] - in [| HU.TestLabel s - (HU.TestCase (testableAsAssertion fullName $(exp))) |] + diff --git a/Test/Framework/BlackBoxTest.hs b/Test/Framework/BlackBoxTest.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/BlackBoxTest.hs @@ -0,0 +1,235 @@ +-- +-- Copyright (c) 2005,2009 Stefan Wehr - http://www.stefanwehr.de +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA +-- + +{- | + +A /black box test/ in the terminology of the HTF consists of a +driver program that is run in various input files. For each input +file, the HTF checks that the driver program exits with the +correct exit code and that it produces the expected output. + +-} +module Test.Framework.BlackBoxTest ( + + BBTArgs(..), defaultBBTArgs, + + blackBoxTests, + + Diff, defaultDiff + +) where + +import Prelude hiding ( catch ) + +import System.IO +import System.Exit +import Control.Exception +import System.Directory +import Data.List ( mapAccumL ) +import qualified Data.Map as Map +import Control.Monad + +import Test.Framework.Process +import Test.Framework.TestManager +import Test.Framework.Utils + +{- | +The type of a function comparing the content of a file +against a string, similar to the unix tool @diff@. +The first parameter is the name of the file containing the +expected output. If this parameter is 'Nothing', then no output +is expected. The second parameter is the actual output produced. +If the result is 'Nothing' then no difference was found. +Otherwise, a 'Just' value contains a string explaining the +different. +-} +type Diff = Maybe FilePath -> String -> IO (Maybe String) + +data BlackBoxTestCfg = BlackBoxTestCfg + { bbtCfg_shouldFail :: Bool + , bbtCfg_cmd :: String + , bbtCfg_stdinFile :: Maybe FilePath + , bbtCfg_stdoutFile :: Maybe FilePath + , bbtCfg_stderrFile :: Maybe FilePath + , bbtCfg_verbose :: Bool + -- functions for comparing output on stdout and stderr. + , bbtCfg_stdoutCmp :: Diff + , bbtCfg_stderrCmp :: Diff + } + +runBlackBoxTest :: BlackBoxTestCfg -> Assertion +runBlackBoxTest bbt = + do inp <- case bbtCfg_stdinFile bbt of + Nothing -> return Nothing + Just f -> do s <- readFile f + return $ Just s + (out,err,exit) <- popenShell (bbtCfg_cmd bbt) inp + case exit of + ExitSuccess | bbtCfg_shouldFail bbt + -> blackBoxTestFail ("test is supposed to fail but succeeded") + ExitFailure i | not $ bbtCfg_shouldFail bbt + -> do when (bbtCfg_verbose bbt) $ + do hPutStrLn stderr ("stderr for " ++ show (bbtCfg_cmd bbt) + ++ ":") + hPutStrLn stderr (err ++ (endOfOutput "output")) + putStrLn $ "stdout for " ++ show (bbtCfg_cmd bbt) ++ ":" + putStrLn (out ++ (endOfOutput "output")) + blackBoxTestFail ("test is supposed to succeed but failed " + ++ "with exit code " ++ show i) + _ -> do cmpOut <- cmp (bbtCfg_stdoutFile bbt) (bbtCfg_stdoutCmp bbt) + out "Mismatch on stdout:\n" + cmpErr <- cmp (bbtCfg_stderrFile bbt) (bbtCfg_stderrCmp bbt) + err "Mismatch on stderr:\n" + case (cmpOut, cmpErr) of + (Nothing, Nothing) -> return () + (x1, x2) -> + do when (bbtCfg_verbose bbt) $ + putStrLn (x1 `concatMaybes` x2) + let mismatchOn = + case (cmpOut, cmpErr) of + (Just _, Just _) -> "stdout and stderr" + (Just _, Nothing) -> "stdout" + _ -> "stderr" + blackBoxTestFail ("Mismatch on " ++ mismatchOn) + where cmp expectFile cmpAction real label = + do res <- cmpAction expectFile real + case res of + Nothing -> return Nothing + Just s -> return $ Just (label ++ s) + concatMaybes Nothing Nothing = "" + concatMaybes (Just s) Nothing = s + concatMaybes (Nothing) (Just s) = s + concatMaybes (Just s1) (Just s2) = s1 ++ "\n" ++ s2 + +endOfOutput :: String -> String +endOfOutput s = "[end of " ++ s ++ "]" + +data BBTArgs = BBTArgs { bbtArgs_stdinSuffix :: String + , bbtArgs_stdoutSuffix :: String + , bbtArgs_stderrSuffix :: String + , bbtArgs_dynArgsName :: String + , bbtArgs_verbose :: Bool + , bbtArgs_stdoutDiff :: Diff + , bbtArgs_stderrDiff :: Diff } + +defaultBBTArgs :: BBTArgs +defaultBBTArgs = BBTArgs { bbtArgs_stdinSuffix = ".in" + , bbtArgs_stdoutSuffix = ".out" + , bbtArgs_stderrSuffix = ".err" + , bbtArgs_dynArgsName = "BBTArgs" + , bbtArgs_stdoutDiff = defaultDiff + , bbtArgs_stderrDiff = defaultDiff + , bbtArgs_verbose = False } + +defaultDiff :: Diff +defaultDiff expectFile real = + do mexe <- findExecutable "diff" + let exe = case mexe of + Just p -> p + Nothing -> error ("diff command not in path") + case expectFile of + Nothing | null real -> return Nothing + | otherwise -> return $ Just ("no output expected, but " ++ + "given:\n" ++ real ++ + (endOfOutput "given output")) + Just expect -> + do (out, err, exitCode) <- popen exe ["-u", expect, "-"] + (Just real) + case exitCode of + ExitSuccess -> return Nothing -- no difference + ExitFailure 1 -> -- files differ + return $ Just (out ++ (endOfOutput "diff output")) + ExitFailure i -> error ("diff command failed with exit " ++ + "code " ++ show i ++ ": " ++ err) + +blackBoxTests :: FilePath -- root directory of the test hierarchy + -> String -- name of executable + -> String -- filename suffix for input file + -> BBTArgs -- configuration + -> IO [Test] +blackBoxTests root exe suf cfg = + do let prune root _ = do dynCfg <- readDynCfg Map.empty + (root + bbtArgs_dynArgsName cfg) + return $ dyn_skip dynCfg + inputFiles <- collectFiles root suf prune + (_, tests) <- mapAccumLM genTest Map.empty inputFiles + return tests + where genTest :: DynamicConfigMap -> FilePath -> IO (DynamicConfigMap, + Test) + genTest map fname = + do stdinf <- maybeFile $ replaceSuffix fname + (bbtArgs_stdinSuffix cfg) + stdoutf <- maybeFile $ replaceSuffix fname + (bbtArgs_stdoutSuffix cfg) + stderrf <- maybeFile $ replaceSuffix fname + (bbtArgs_stderrSuffix cfg) + let configFile = dirname fname bbtArgs_dynArgsName cfg + dynCfg <- readDynCfg map configFile + let cmd = exe ++ " " ++ dropSpace (dyn_flags dynCfg) ++ " " ++ + fname + shouldFail = dyn_shouldFail dynCfg + verbose = bbtArgs_verbose cfg || dyn_verbose dynCfg + let bbt = BlackBoxTestCfg + { bbtCfg_shouldFail = shouldFail + , bbtCfg_cmd = cmd + , bbtCfg_stdinFile = stdinf + , bbtCfg_stdoutFile = stdoutf + , bbtCfg_stderrFile = stderrf + , bbtCfg_verbose = verbose + , bbtCfg_stdoutCmp = bbtArgs_stdoutDiff cfg + , bbtCfg_stderrCmp = bbtArgs_stderrDiff cfg + } + return (Map.insert configFile dynCfg map, + makeBlackBoxTest fname (runBlackBoxTest bbt)) + +data DynamicConfig = DynamicConfig { dyn_skip :: Bool + , dyn_flags :: String + , dyn_shouldFail :: Bool + , dyn_verbose :: Bool } + +type DynamicConfigMap = Map.Map FilePath DynamicConfig + +defaultDynCfg = DynamicConfig { dyn_skip = False + , dyn_flags = "" + , dyn_shouldFail = False + , dyn_verbose = False } + +readDynCfg :: DynamicConfigMap -> FilePath -> IO DynamicConfig +readDynCfg m f = + do case Map.lookup f m of + Just dynCfg -> return dynCfg + Nothing -> + do b <- doesFileExist f + if not b then return $ defaultDynCfg + else do s <- readFile f + return $ foldl (parse f) defaultDynCfg $ + filter (not . isUseless) (map dropSpace + (lines s)) + where isUseless :: String -> Bool + isUseless [] = True + isUseless ('#':_) = True + isUseless _ = False + parse :: FilePath -> DynamicConfig -> String -> DynamicConfig + parse _ cfg "Skip" = cfg { dyn_skip = True } + parse _ cfg "Fail" = cfg { dyn_shouldFail = True } + parse _ cfg "Verbose" = cfg { dyn_verbose = True } + parse _ cfg ('F':'l':'a':'g':'s':':':flags) = cfg { dyn_flags = flags } + parse f _ l = error ("invalid line in dynamic configuration file `" ++ + f ++ "': " ++ show l) + diff --git a/Test/Framework/Configuration.hs b/Test/Framework/Configuration.hs deleted file mode 100644 --- a/Test/Framework/Configuration.hs +++ /dev/null @@ -1,4 +0,0 @@ --- GENERATED AUTOMATICALLY, DO NOT EDIT!! -module Test.Framework.Configuration where -import Data.Version -ghcVersion = Version {versionBranch = [6,4,1], versionTags = []} diff --git a/Test/Framework/FileBasedTest.hs b/Test/Framework/FileBasedTest.hs deleted file mode 100644 --- a/Test/Framework/FileBasedTest.hs +++ /dev/null @@ -1,190 +0,0 @@ --- --- Copyright (c) 2005 Stefan Wehr - http://www.stefanwehr.de --- --- This library is free software; you can redistribute it and/or --- modify it under the terms of the GNU Lesser General Public --- License as published by the Free Software Foundation; either --- version 2.1 of the License, or (at your option) any later version. --- --- This library is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- Lesser General Public License for more details. --- --- You should have received a copy of the GNU Lesser General Public --- License along with this library; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA --- - -module Test.Framework.FileBasedTest ( - - Diff, FBTConfig(..), - - defaultFBTConfig, defaultDiff, - - fileBasedTests - -) where - -import Prelude hiding ( catch ) - -import System.IO -import System.Exit -import Control.Exception -import System.Directory -import Data.List ( mapAccumL ) -import qualified Data.Map as Map -import Control.Monad - -import Test.Framework.Process -import Test.Framework.HUnitWrapper as HU -import Test.Framework.Utils - -type Diff = Maybe FilePath -- Name of the file that contains the expected output. - -- If the parameter is Nothing, then no output - -- is expected. - -> String -- Actual output - -> IO (Maybe String) -- A Nothing value means ok, otherwise the - -- Just value wraps the error message - -data FileBasedTest = FileBasedTest - { fbt_shouldFail :: Bool - , fbt_cmd :: String - , fbt_stdinFile :: Maybe FilePath - , fbt_stdoutFile :: Maybe FilePath - , fbt_stderrFile :: Maybe FilePath - -- functions for comparing output on stdout and stderr. - , fbt_stdoutCmp :: Diff - , fbt_stderrCmp :: Diff - } - -runFileBasedTest :: FileBasedTest -> HU.Assertion -runFileBasedTest fbt = - do inp <- case fbt_stdinFile fbt of - Nothing -> return Nothing - Just f -> do s <- readFile f - return $ Just s - (out,err,exit) <- popenShell (fbt_cmd fbt) inp - case exit of - ExitSuccess | fbt_shouldFail fbt - -> HU.assertFailure ("test is supposed to fail but succeeded") - ExitFailure i | not $ fbt_shouldFail fbt - -> do hPutStrLn stderr $ "stderr for " ++ show (fbt_cmd fbt) ++ ":" - hPutStr stderr err - putStrLn $ "stdout for " ++ show (fbt_cmd fbt) ++ ":" - putStr out - HU.assertFailure ("test is supposed to succeed but failed with " ++ - "exit code " ++ show i) - _ -> do cmpOut <- cmp (fbt_stdoutFile fbt) (fbt_stdoutCmp fbt) - out "Mismatch on stdout:\n" - cmpErr <- cmp (fbt_stderrFile fbt) (fbt_stderrCmp fbt) - err "Mismatch on stderr:\n" - case (cmpOut, cmpErr) of - (Nothing, Nothing) -> return () - (x1, x2) -> HU.assertFailure (x1 `concatMaybes` x2) - where cmp expectFile cmpAction real label = - do res <- cmpAction expectFile real - case res of - Nothing -> return Nothing - Just s -> return $ Just (label ++ s) - concatMaybes Nothing Nothing = "" - concatMaybes (Just s) Nothing = s - concatMaybes (Nothing) (Just s) = s - concatMaybes (Just s1) (Just s2) = s1 ++ "\n" ++ s2 - - -data FBTConfig = FBTConfig { fbt_stdinSuffix :: String - , fbt_stdoutSuffix :: String - , fbt_stderrSuffix :: String - , fbt_dynConfigName :: String - , fbt_stdoutDiff :: Diff - , fbt_stderrDiff :: Diff } - -defaultDiff :: Diff -defaultDiff expectFile real = - do mexe <- findExecutable "diff" - let exe = case mexe of - Just p -> p - Nothing -> error ("diff command not in path") - case expectFile of - Nothing | null real -> return Nothing - | otherwise -> return $ Just ("no output expected, but given:\n" - ++ real) - Just expect -> - do (out, err, exitCode) <- popen exe ["-u", expect, "-"] (Just real) - case exitCode of - ExitSuccess -> return Nothing -- no difference - ExitFailure 1 -> return $ Just out -- files differ - ExitFailure i -> error ("diff command failed with exit code " ++ - show i ++ ": " ++ err) - -defaultFBTConfig = FBTConfig { fbt_stdinSuffix = ".in" - , fbt_stdoutSuffix = ".out" - , fbt_stderrSuffix = ".err" - , fbt_dynConfigName = "FBTConfig" - , fbt_stdoutDiff = defaultDiff - , fbt_stderrDiff = defaultDiff } - -fileBasedTests :: String -- id for the tests - -> FilePath -- root directory of the test hierarchy - -> String -- name of executable - -> String -- filename suffix for input file - -> FBTConfig -- configuration - -> IO HU.Test -fileBasedTests id root exe suf cfg = - do let prune root _ = do dynCfg <- readDynCfg Map.empty - (root fbt_dynConfigName cfg) - return $ dyn_skip dynCfg - inputFiles <- collectFiles root suf prune - (_, tests) <- mapAccumLM genTest Map.empty inputFiles - return $ HU.TestLabel id $ HU.TestList tests - where genTest :: DynamicConfigMap -> FilePath -> IO (DynamicConfigMap, HU.Test) - genTest map fname = - do stdinf <- maybeFile $ replaceSuffix fname (fbt_stdinSuffix cfg) - stdoutf <- maybeFile $ replaceSuffix fname (fbt_stdoutSuffix cfg) - stderrf <- maybeFile $ replaceSuffix fname (fbt_stderrSuffix cfg) - let configFile = dirname fname fbt_dynConfigName cfg - dynCfg <- readDynCfg map configFile - let cmd = exe ++ " " ++ dropSpace (dyn_flags dynCfg) ++ " " ++ fname - shouldFail = dyn_shouldFail dynCfg - let fbt = FileBasedTest - { fbt_shouldFail = shouldFail - , fbt_cmd = cmd - , fbt_stdinFile = stdinf - , fbt_stdoutFile = stdoutf - , fbt_stderrFile = stderrf - , fbt_stdoutCmp = fbt_stdoutDiff cfg - , fbt_stderrCmp = fbt_stderrDiff cfg - } - return (Map.insert configFile dynCfg map, - HU.TestLabel fname $ HU.TestCase $ runFileBasedTest fbt) - -data DynamicConfig = DynamicConfig { dyn_skip :: Bool - , dyn_flags :: String - , dyn_shouldFail :: Bool } - -type DynamicConfigMap = Map.Map FilePath DynamicConfig - -defaultDynCfg = DynamicConfig False "" False - -readDynCfg :: DynamicConfigMap -> FilePath -> IO DynamicConfig -readDynCfg m f = - do case Map.lookup f m of - Just dynCfg -> return dynCfg - Nothing -> - do b <- doesFileExist f - if not b then return $ defaultDynCfg - else do s <- readFile f - return $ foldl (parse f) defaultDynCfg $ - filter (not . isUseless) (map dropSpace (lines s)) - where isUseless :: String -> Bool - isUseless [] = True - isUseless ('#':_) = True - isUseless _ = False - parse :: FilePath -> DynamicConfig -> String -> DynamicConfig - parse _ cfg "Skip" = cfg { dyn_skip = True } - parse _ cfg "Fail" = cfg { dyn_shouldFail = True } - parse _ cfg ('F':'l':'a':'g':'s':':':flags) = cfg { dyn_flags = flags } - parse f _ l = error ("invalid line in dynamic configuration file `" ++ - f ++ "': " ++ show l) - diff --git a/Test/Framework/HUnitWrapper.hs b/Test/Framework/HUnitWrapper.hs --- a/Test/Framework/HUnitWrapper.hs +++ b/Test/Framework/HUnitWrapper.hs @@ -1,5 +1,6 @@ +{-# LANGUAGE ScopedTypeVariables #-} -- --- Copyright (c) 2005 Stefan Wehr - http://www.stefanwehr.de +-- Copyright (c) 2005, 2009 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public @@ -16,29 +17,44 @@ -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA -- +{-| +You should not use the functions provided by this module directly. +Instead, for each function @assertXXX_@ defined in this module, +there exist a preprocessor macro @assertXXX@, which provides +the "Location" parameter automatically. +|-} + module Test.Framework.HUnitWrapper ( - HU.Assertion, + assertBool_, - assertBool_, assertEqual_, assertEqualNoShow_, assertNotNull_, assertNull_, - assertSetEqual_, assertThrows_, + assertEqual_, assertEqualP_, assertEqualNoShow_, - assertFailure, + assertNotEmpty_, assertEmpty_, - HU.Test(..), runTestTT, + assertSetEqual_, - joinPathElems, showPathLabel + assertThrows_, assertThrowsSome_, + assertLeft_, assertLeftNoShow_, assertRight_, assertRightNoShow_, + + assertJust_, + + assertFailure + ) where import System.IO ( stderr ) import Data.List ( (\\) ) import Control.Exception -import Data.Version -import qualified Test.HUnit as HU +import Control.Monad +import qualified Test.HUnit as HU hiding ( assertFailure ) +-- import Data.Algorithm.Diff +import Test.Framework.TestManager import Test.Framework.Location -import Test.Framework.Configuration +import Test.Framework.Utils +import Test.Framework.Pretty -- -- Assertions @@ -46,16 +62,8 @@ -- WARNING: do not forget to add a preprocessor macro for new assertions!! -assertFailure :: String -> IO () -assertFailure s = - if ghcVersion <= buggyVersion - then -- because of a bug in HUnit shipped with GHC 6.4.1, we must - -- throw an exception e such that (show e) does not have a prefix - -- like `user error'. - error (hunitPrefix ++ s) - else HU.assertFailure s - where hunitPrefix = "HUnit:" - buggyVersion = Version [6,4,1] [] +assertFailure :: String -> IO a +assertFailure s = unitTestFail s assertBool_ :: Location -> Bool -> HU.Assertion assertBool_ loc False = assertFailure ("assert failed at " ++ showLoc loc) @@ -67,8 +75,18 @@ then assertFailure msg else return () where msg = "assertEqual failed at " ++ showLoc loc ++ - "\n expected: " ++ show expected ++ "\n but got: " ++ show actual + "\n expected: " ++ show expected ++ + "\n but got: " ++ show actual +assertEqualP_ :: (Eq a, Pretty a) => Location -> a -> a -> HU.Assertion +assertEqualP_ loc expected actual = + if expected /= actual + then assertFailure msg + else return () + where msg = "assertEqual failed at " ++ showLoc loc ++ + "\n expected:\n" ++ showPretty expected ++ + "\n but got:\n" ++ showPretty actual + assertEqualNoShow_ :: Eq a => Location -> a -> a -> HU.Assertion assertEqualNoShow_ loc expected actual = if expected /= actual @@ -93,17 +111,18 @@ null (l1 \\ l2) && null (l2 \\ l1) -assertNotNull_ :: Location -> [a] -> HU.Assertion -assertNotNull_ loc [] = assertFailure ("assertNotNull failed at " ++ showLoc loc) -assertNotNull_ _ (_:_) = return () +assertNotEmpty_ :: Location -> [a] -> HU.Assertion +assertNotEmpty_ loc [] = + assertFailure ("assertNotEmpty failed at " ++ showLoc loc) +assertNotEmpty_ _ (_:_) = return () -assertNull_ :: Location -> [a] -> HU.Assertion -assertNull_ loc (_:_) = assertFailure ("assertNull failed at " ++ showLoc loc) -assertNull_ loc [] = return () +assertEmpty_ :: Location -> [a] -> HU.Assertion +assertEmpty_ loc (_:_) = assertFailure ("assertNull failed at " ++ showLoc loc) +assertEmpty_ loc [] = return () -assertThrows_ :: Location -> IO a -> (Exception -> Bool) -> HU.Assertion -assertThrows_ loc io f = - do res <- try io +assertThrows_ :: Exception e => Location -> a -> (e -> Bool) -> HU.Assertion +assertThrows_ loc x f = + do res <- try (evaluate x) case res of Right _ -> assertFailure ("assertThrows failed at " ++ showLoc loc ++ ": no exception was thrown") @@ -113,75 +132,38 @@ ": wrong exception was thrown: " ++ show e) --- --- Test runner --- - -{- -We use our own test runner because HUnit print test paths a bit unreadable: -If a test list contains a named tests, then HUnit prints `i:n' where i -is the index of the named tests and n is the name. --} - -{- -`runTestText` executes a test, processing each report line according -to the given reporting scheme. The reporting scheme's state is -threaded through calls to the reporting scheme's function and finally -returned, along with final count values. --} - -runTestText :: HU.PutText st -> HU.Test -> IO (HU.Counts, st) -runTestText (HU.PutText put us) t = do - put allTestsStr True us - (counts, us') <- HU.performTest reportStart reportError reportFailure us t - us'' <- put (HU.showCounts counts) True us' - return (counts, us'') - where - allTestsStr = unlines ("All tests:" : - map (\p -> " " ++ showPath p) (HU.testCasePaths t)) - reportStart ss us = put (HU.showCounts (HU.counts ss)) False us - reportError = reportProblem "Error:" "Error in: " - reportFailure = reportProblem "Failure:" "Failure in: " - reportProblem p0 p1 msg ss us = put line True us - where line = "### " ++ kind ++ path' ++ '\n' : msg ++ "\n" - kind = if null path' then p0 else p1 - path' = showPath (HU.path ss) - - - -{- -`showPath` converts a test case path to a string, separating adjacent -elements by ':'. An element of the path is quoted (as with `show`) -when there is potential ambiguity. --} +assertThrowsSome_ :: Location -> a -> HU.Assertion +assertThrowsSome_ loc x = + assertThrows_ loc x (\ (e::SomeException) -> True) -showPath :: HU.Path -> String -showPath [] = "" -showPath nodes = foldr1 joinPathElems - (map showNode (filterNodes (reverse nodes))) - where showNode (HU.ListItem n) = show n - showNode (HU.Label label) = showPathLabel label - filterNodes (HU.ListItem _ : l@(HU.Label _) : rest) = - l : filterNodes rest - filterNodes [] = [] - filterNodes (x:rest) = x : filterNodes rest +assertLeft_ :: forall a b . Show b => Location -> Either a b -> IO a +assertLeft_ _ (Left x) = return x +assertLeft_ loc (Right x) = + assertFailure ("assertLeft failed at " ++ showLoc loc ++ + ": expected a Left value, given " ++ + show (Right x :: Either b b)) -joinPathElems :: String -> String -> String -joinPathElems s1 s2 = s1 ++ ":" ++ s2 +assertLeftNoShow_ :: Location -> Either a b -> IO a +assertLeftNoShow_ _ (Left x) = return x +assertLeftNoShow_ loc (Right x) = + assertFailure ("assertLeft failed at " ++ showLoc loc ++ + ": expected a Left value, given a Right value") -showPathLabel :: String -> String -showPathLabel s = - let ss = show s - in if ':' `elem` s || "\"" ++ s ++ "\"" /= ss then ss else s +assertRight_ :: forall a b . Show a => Location -> Either a b -> IO b +assertRight_ _ (Right x) = return x +assertRight_ loc (Left x) = + assertFailure ("assertRight failed at " ++ showLoc loc ++ + ": expected a Right value, given " ++ + show (Left x :: Either a a)) -{- -`runTestTT` provides the "standard" text-based test controller. -Reporting is made to standard error, and progress reports are -included. For possible programmatic use, the final counts are -returned. The "TT" in the name suggests "Text-based reporting to the -Terminal". --} +assertRightNoShow_ :: Location -> Either a b -> IO b +assertRightNoShow_ _ (Right x) = return x +assertRightNoShow_ loc (Left x) = + assertFailure ("assertRight failed at " ++ showLoc loc ++ + ": expected a Right value, given a Left value") -runTestTT :: HU.Test -> IO HU.Counts -runTestTT t = do (counts, _) <- runTestText (HU.putTextToHandle stderr False) t - return counts +assertJust_ :: Location -> Maybe a -> IO a +assertJust_ _ (Just x) = return x +assertJust_ loc Nothing = + assertFailure ("assertJust failed at " ++ showLoc loc ++ + ": expected a Just value, given Nothing") diff --git a/Test/Framework/HaskellParser.hs b/Test/Framework/HaskellParser.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/HaskellParser.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA +-- + +module Test.Framework.HaskellParser where + +import Data.Maybe +import Control.Exception ( evaluate, catch, SomeException ) +import Prelude hiding ( catch ) + +import qualified Language.Haskell.Exts.Parser as Parser +import qualified Language.Haskell.Exts.Syntax as Syn +import qualified Language.Haskell.Exts.Extension as Ext + +import Test.Framework.Location + +type Name = String + +data Decl = Decl { decl_loc :: Location + , decl_name :: Name } + +data ParseResult a = ParseOK a | ParseError Location String + +data Module = Module { mod_name :: Name + , mod_imports :: [ImportDecl] + , mod_decls :: [Decl] } + +data ImportDecl = ImportDecl { imp_moduleName :: Name + , imp_qualified :: Bool + , imp_alias :: Maybe Name } + +parse :: FilePath -> String -> IO (ParseResult Module) +parse originalFileName input = + do r <- (evaluate $ Parser.parseModuleWithMode parseMode fixedInput) + `catch` (\(e::SomeException) -> + return $ Parser.ParseFailed unknownLoc (show e)) + case r of + Parser.ParseFailed loc err -> return (ParseError (transformLoc loc) err) + Parser.ParseOk m -> return $ ParseOK (transformModule m) + where + fixedInput :: String + fixedInput = (input ++ "\n") {- the parser fails if the last line is a + line comment not ending with \n -} + parseMode :: Parser.ParseMode + parseMode = Parser.defaultParseMode { Parser.parseFilename = originalFileName + , Parser.extensions = + Ext.glasgowExts ++ + [Ext.ExplicitForall] + } + unknownLoc :: Syn.SrcLoc + unknownLoc = Syn.SrcLoc originalFileName 0 0 + transformModule (Syn.Module _ (Syn.ModuleName moduleName) _ _ _ + imports decls) = + Module moduleName (map transformImport imports) + (mapMaybe transformDecl decls) + transformImport (Syn.ImportDecl loc (Syn.ModuleName s) qualified _ _ alias _) = + let alias' = case alias of + Nothing -> Nothing + Just (Syn.ModuleName s) -> Just s + in ImportDecl s qualified alias' + transformDecl (Syn.PatBind loc (Syn.PVar name) _ _ _) = + Just $ Decl (transformLoc loc) (transformName name) + transformDecl (Syn.FunBind (Syn.Match loc name _ _ _ _ : _)) = + Just $ Decl (transformLoc loc) (transformName name) + transformDecl _ = Nothing + transformLoc (Syn.SrcLoc f n _) = makeLoc f n + transformName :: Syn.Name -> String + transformName (Syn.Ident s) = s + transformName (Syn.Symbol s) = s diff --git a/Test/Framework/Location.hs b/Test/Framework/Location.hs --- a/Test/Framework/Location.hs +++ b/Test/Framework/Location.hs @@ -16,11 +16,31 @@ -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA -- -module Test.Framework.Location where +module Test.Framework.Location ( + Location, -type Location = (String, Int) + fileName, lineNumber, + showLoc, makeLoc + +) where + + +-- | An abstract type representing locations in a file. +data Location = Location String Int + showLoc :: Location -> String -showLoc (f,n) = f ++ ":" ++ show n +showLoc (Location f n) = f ++ ":" ++ show n +fileName :: Location -> String +fileName (Location f _ ) = f + +lineNumber :: Location -> Int +lineNumber (Location _ i) = i + +-- | Create a new location. +makeLoc :: String -- ^ The file name + -> Int -- ^ The line number + -> Location +makeLoc = Location diff --git a/Test/Framework/Preprocessor.hs b/Test/Framework/Preprocessor.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/Preprocessor.hs @@ -0,0 +1,150 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- +-- Copyright (c) 2009 Stefan Wehr - http://www.stefanwehr.de +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA +-- + +module Test.Framework.Preprocessor ( transform, progName ) where + +import Data.Maybe ( mapMaybe ) +import Data.List ( intercalate ) +import System.IO ( hPutStrLn, stderr ) +import Language.Preprocessor.Cpphs ( runCpphs, + CpphsOptions(..), + defaultCpphsOptions) + +import Test.Framework.HaskellParser +import Test.Framework.Location + +progName :: String +progName = "htfpp" + +htfModule :: String +htfModule = "Test.Framework" + +testDeclName :: String +testDeclName = "allHTFTests" + +assertDefines :: String -> [(String, String)] +assertDefines prefix = + map (\s -> (s, "(" ++ prefix ++ s ++ "_ (" ++ + prefix ++ "makeLoc __FILE__ __LINE__))")) + ["assertBool" + ,"assertEqual" + ,"assertEqualP" + ,"assertEqualNoShow" + ,"assertSetEqual" + ,"assertEmpty" + ,"assertNotEmpty" + ,"assertThrows" + ,"assertThrowsSome" + ,"assertLeft" + ,"assertLeftNoShow" + ,"assertRight" + ,"assertRightNoShow" + ,"assertJust" + ] + +warn :: String -> IO () +warn s = + hPutStrLn stderr $ progName ++ " warning: " ++ s + +data ModuleInfo = ModuleInfo { mi_prefix :: String + , mi_defs :: [Definition] + , mi_moduleName :: String } + +data Definition = TestDef String Location String + | PropDef String Location String + +analyse :: FilePath -> String + -> IO (ParseResult ModuleInfo) +analyse originalFileName s = + do parseResult <- parse originalFileName s + case parseResult of + ParseOK (Module moduleName imports decls) -> + do -- putStrLn $ show decls + let defs = mapMaybe defFromDecl decls + htfPrefix <- + case mapMaybe prefixFromImport imports of + (s:_) -> return s + [] -> do warn ("No import found for " ++ htfModule ++ + " in " ++ originalFileName) + return (htfModule ++ ".") + return $ ParseOK (ModuleInfo htfPrefix defs moduleName) + ParseError loc err -> return (ParseError loc err) + where + prefixFromImport :: ImportDecl -> Maybe String + prefixFromImport (ImportDecl s qualified alias) + | s == htfModule = + if qualified + then case alias of + Just s' -> Just $ s' ++ "." + Nothing -> Just $ s ++ "." + else Just "" + prefixFromImport _ = Nothing + defFromDecl :: Decl -> Maybe Definition + defFromDecl (Decl loc name) = defFromNameAndLoc name loc + defFromNameAndLoc :: Name -> Location -> Maybe Definition + defFromNameAndLoc name loc = + case name of + ('t':'e':'s':'t':'_':rest) | not (null rest) -> + Just (TestDef rest loc name) + ('p':'r':'o':'p':'_':rest) | not (null rest) -> + Just (PropDef rest loc name) + _ -> Nothing + +transform :: FilePath -> String -> IO String +transform originalFileName input = + do analyseResult <- analyse originalFileName input + case analyseResult of + ParseError loc err -> + do warn ("Parsing of " ++ originalFileName ++ " failed at line " + ++ show (lineNumber loc) ++ ": " ++ err) + preprocess (ModuleInfo "" [] "UNKNOWN_MODULE") + ParseOK info -> + preprocess info + where + preprocess :: ModuleInfo -> IO String + preprocess info = + do preProcessedInput <- runCpphs (cpphsOptions info) originalFileName + input + return $ preProcessedInput ++ "\n\n" ++ additionalCode info ++ "\n" + cpphsOptions :: ModuleInfo -> CpphsOptions + cpphsOptions info = + defaultCpphsOptions { defines = + defines defaultCpphsOptions ++ + assertDefines (mi_prefix info) + } + additionalCode :: ModuleInfo -> String + additionalCode info = + testDeclName ++ " :: " ++ mi_prefix info ++ "TestSuite\n" ++ + testDeclName ++ " = " ++ mi_prefix info ++ "makeTestSuite" ++ + " " ++ show (mi_moduleName info) ++ + " [\n " ++ intercalate ",\n " + (map (codeForDef (mi_prefix info)) (mi_defs info)) + ++ "\n ]" + codeForDef :: String -> Definition -> String + codeForDef pref (TestDef s loc name) = + pref ++ "makeUnitTest " ++ (show s) ++ " " ++ codeForLoc pref loc ++ + " " ++ name + codeForDef pref (PropDef s loc name) = + pref ++ "makeQuickCheckTest " ++ (show s) ++ " " ++ + codeForLoc pref loc ++ " (" ++ pref ++ "testableAsAssertion (" ++ + pref ++ "asTestableWithQCArgs " ++ name ++ "))" + codeForLoc :: String -> Location -> String + codeForLoc pref loc = "(" ++ pref ++ "makeLoc " ++ show (fileName loc) ++ + " " ++ show (lineNumber loc) ++ ")" diff --git a/Test/Framework/Pretty.hs b/Test/Framework/Pretty.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/Pretty.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} + +module Test.Framework.Pretty ( + + Pretty(..), (<=>), + + module Text.PrettyPrint +) + +where + +import Text.PrettyPrint + +class Pretty a where + pretty :: a -> Doc + prettyList :: [a] -> Doc + prettyList l = + char '[' <> vcat (punctuate comma (map pretty l)) <> char ']' + showPretty :: a -> String + showPretty = render . pretty + +{- +instance Pretty String where + pretty = text +-} + +instance Pretty Char where + pretty = char + prettyList s = text s + +instance Pretty a => Pretty [a] where + pretty = prettyList + +instance Pretty Int where + pretty = int + +instance Pretty Bool where + pretty = text . show + +(<=>) :: Doc -> Doc -> Doc +d1 <=> d2 = d1 <+> equals <+> d2 + diff --git a/Test/Framework/Process.hs b/Test/Framework/Process.hs --- a/Test/Framework/Process.hs +++ b/Test/Framework/Process.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -cpp #-} +{-# LANGUAGE CPP,ScopedTypeVariables #-} -- -- Copyright (c) 2005 Don Stewart - http://www.cse.unsw.edu.au/~dons -- @@ -42,7 +42,8 @@ -> Maybe String -> IO (String,String,ExitCode) popen' run minput = - Control.Exception.handle (\e -> return ([],show e,error (show e))) $ do + Control.Exception.handle (\ (e :: Control.Exception.SomeException) -> + return ([],show e,error (show e))) $ do (inp,out,err,pid) <- run diff --git a/Test/Framework/QuickCheckWrapper.hs b/Test/Framework/QuickCheckWrapper.hs --- a/Test/Framework/QuickCheckWrapper.hs +++ b/Test/Framework/QuickCheckWrapper.hs @@ -1,5 +1,7 @@ +{-# LANGUAGE FlexibleInstances,OverlappingInstances,ExistentialQuantification #-} + -- --- Copyright (c) 2005 Stefan Wehr - http://www.stefanwehr.de +-- Copyright (c) 2005,2009 Stefan Wehr - http://www.stefanwehr.de -- -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public @@ -18,124 +20,99 @@ module Test.Framework.QuickCheckWrapper ( - Id, Config(..), makeVerbose, setMaxTest, - testableAsAssertion, - - module Test.QuickCheck + + module Test.QuickCheck, + + TestableWithQCArgs, WithQCArgs, withQCArgs, asTestableWithQCArgs + ) where import qualified Data.Map as Map import Control.Concurrent.MVar -import Control.Exception ( throw ) +import Prelude hiding ( catch ) +import Control.Exception ( throw, catch, SomeException, evaluate ) import System.IO import System.IO.Unsafe import System.Random import Data.List( group, sort, intersperse ) import Data.Char -import Test.QuickCheck hiding ( Config(..), defaultConfig, - test, quickCheck, verboseCheck, check ) -import Test.QuickCheck.Batch -import Test.Framework.HUnitWrapper -type Id = String +import Test.QuickCheck +import Test.QuickCheck.Property -data Config = Config - { configMaxTest :: Int - , configMaxFail :: Int - , configSize :: Int -> Int - , configEvery :: String -> IO () - } +import Test.Framework.TestManager -data QCState = QCState { qc_config :: Config } +data QCState = QCState { qc_args :: Args } -defaultConfig = Config - { configMaxTest = 100 - , configMaxFail = 1000 - , configSize = (+ 3) . (`div` 2) - , configEvery = \_ -> return () - } - -verboseConfigEvery = hPutStr stderr +qcState :: MVar QCState +qcState = unsafePerformIO (newMVar (QCState defaultArgs)) +{-# NOINLINE qcState #-} -makeVerbose :: Config -> Config -makeVerbose cfg = cfg { configEvery = verboseConfigEvery } +defaultArgs :: Args +defaultArgs = stdArgs -setMaxTest :: Int -> Config -> Config -setMaxTest i cfg = cfg { configMaxTest = i } +setDefaultArgs :: Args -> IO () +setDefaultArgs args = + do withMVar qcState $ \state -> return (state { qc_args = args }) + return () -qcState :: MVar QCState -qcState = unsafePerformIO (newMVar (QCState defaultConfig)) +getCurrentArgs :: IO Args +getCurrentArgs = + withMVar qcState $ \state -> return (qc_args state) -testableAsAssertion :: Testable a => Id -> (Config -> Config, a) -> Assertion -testableAsAssertion id (f, t) = +testableAsAssertion :: (Testable t, WithQCArgs t) => t -> Assertion +testableAsAssertion t = withMVar qcState $ \state -> - do let cfg = f (qc_config state) - configEvery cfg (prop id ++ "\n") - res <- check cfg t - case res of - PropOk s -> do hPutStrLn stderr $ " * " ++ prop id ++ (strip s) - hPutStrLn stderr "" - PropFailure s -> assertFailure $ prop id ++ (strip s) - PropExhausted s -> assertFailure $ prop id ++ (strip s) - return () - where prop s = "Property `" ++ s ++ "' " - strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace + do eitherArgs <- + (let a = (argsModifier t) (qc_args state) + in do evaluate (length (show a)) + return (Right a)) + `catch` + (\e -> return $ Left (show (e :: SomeException))) + case eitherArgs of + Left err -> quickCheckTestError + (Just ("Cannot evaluate custom arguments: " + ++ err)) + Right args -> + do res <- do x <- quickCheckWithResult args t + return (Right x) + `catch` + (\e -> return $ Left (show (e::SomeException))) + case res of + Left err -> quickCheckTestError (Just err) + Right (Success _) -> return () + Right (Failure gen size _ _) -> + do putStrLn ("Replay argument: " ++ + (show (show (Just (gen, size))))) + quickCheckTestFail Nothing + _ -> quickCheckTestFail Nothing + return () -data PropResult = PropOk String - | PropFailure String - | PropExhausted String - -check :: Testable a => Config -> a -> IO PropResult -check config a = - do rnd <- newStdGen - tests config (evaluate a) rnd 0 0 [] +data TestableWithQCArgs = forall a . Testable a => + TestableWithQCArgs (Args -> Args) a -tests :: Config -> Gen Result -> StdGen - -> Int -> Int -> [[String]] -> IO PropResult -tests config gen rnd0 ntest nfail stamps - | ntest == configMaxTest config = - return $ done PropOk "OK, passed" ntest stamps - | nfail == configMaxFail config = - return $ done PropExhausted "Arguments exhausted after" ntest stamps - | otherwise = - do configEvery config $ show ntest ++ ":\n" ++ unlines (arguments result) - case ok result of - Nothing -> - tests config gen rnd1 ntest (nfail+1) stamps - Just True -> - tests config gen rnd1 (ntest+1) nfail (stamp result:stamps) - Just False -> - return $ PropFailure ("Falsifiable, after " - ++ show ntest - ++ " tests:\n" - ++ unlines (arguments result) - ) - where - result = generate (configSize config ntest) rnd2 gen - (rnd1,rnd2) = split rnd0 +instance Testable TestableWithQCArgs where + property (TestableWithQCArgs _ t) = property t -done :: (String -> PropResult) -> String -> Int -> [[String]] -> PropResult -done f mesg ntest stamps = - f ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) - where - table = display - . map entry - . reverse - . sort - . map pairLength - . group - . sort - . filter (not . null) - $ stamps +class WithQCArgs a where + argsModifier :: a -> (Args -> Args) + original :: a -> Maybe TestableWithQCArgs - display [] = ".\n" - display [x] = " (" ++ x ++ ").\n" - display xs = ".\n" ++ unlines (map (++ ".") xs) +instance WithQCArgs a where + argsModifier _ = id + original _ = Nothing - pairLength xss@(xs:_) = (length xss, xs) - entry (n, xs) = percentage n ntest - ++ " " - ++ concat (intersperse ", " xs) +instance WithQCArgs TestableWithQCArgs where + argsModifier (TestableWithQCArgs f _) = f + original a = Just a - percentage n m = show ((100 * n) `div` m) ++ "%" +withQCArgs :: (WithQCArgs a, Testable a) => (Args -> Args) -> a + -> TestableWithQCArgs +withQCArgs = TestableWithQCArgs + +asTestableWithQCArgs :: (WithQCArgs a, Testable a) => a -> TestableWithQCArgs +asTestableWithQCArgs a = + case original a of + Just a' -> a' + Nothing -> TestableWithQCArgs id a diff --git a/Test/Framework/TestManager.hs b/Test/Framework/TestManager.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/TestManager.hs @@ -0,0 +1,225 @@ +-- +-- Copyright (c) 2009 Stefan Wehr - http://www.stefanwehr.de +-- +-- This library is free software; you can redistribute it and/or +-- modify it under the terms of the GNU Lesser General Public +-- License as published by the Free Software Foundation; either +-- version 2.1 of the License, or (at your option) any later version. +-- +-- This library is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +-- Lesser General Public License for more details. +-- +-- You should have received a copy of the GNU Lesser General Public +-- License along with this library; if not, write to the Free Software +-- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA +-- + +module Test.Framework.TestManager ( + + TestID, Assertion, Test, TestSuite, Filter, FlatTest(..), TestSort(..), + TestableHTF, + + quickCheckTestFail, quickCheckTestError, + unitTestFail, blackBoxTestFail, + + makeQuickCheckTest, makeUnitTest, makeBlackBoxTest, makeTestSuite, + makeAnonTestSuite, + addToTestSuite, testSuiteAsTest, + + runTest, runTestWithArgs, runTestWithFilter + +) where + +import Control.Monad +import Control.Monad.State +import Data.List ( isInfixOf ) +import Text.PrettyPrint + +import qualified Test.HUnit.Lang as HU + +import Test.Framework.Location ( Location, showLoc ) +import Test.Framework.Utils ( readM ) + +type Assertion = IO () + +type TestID = String + +assertFailureHTF :: String -> Assertion +-- Important: force the string argument, otherwise an error embedded +-- lazily inside the string might escape. +assertFailureHTF s = length s `seq` HU.assertFailure s + +-- This is a HACK: we encode a custom error message for QuickCheck +-- failures and errors in a string, which is later parsed using read! + +quickCheckTestError :: Maybe String -> Assertion +quickCheckTestError m = assertFailureHTF (show (False, m)) + +quickCheckTestFail :: Maybe String -> Assertion +quickCheckTestFail m = assertFailureHTF (show (True, m)) + +unitTestFail :: String -> IO a +unitTestFail s = + do assertFailureHTF s + error "unitTestFail: UNREACHABLE" + +blackBoxTestFail :: String -> Assertion +blackBoxTestFail = assertFailureHTF + +makeQuickCheckTest :: TestID -> Location -> Assertion -> Test +makeQuickCheckTest id loc ass = BaseTest QuickCheckTest id (Just loc) ass + +makeUnitTest :: TestID -> Location -> IO a -> Test +makeUnitTest id loc ass = BaseTest UnitTest id (Just loc) (ass >> return ()) + +makeBlackBoxTest :: TestID -> Assertion -> Test +makeBlackBoxTest id ass = BaseTest BlackBoxTest id Nothing ass + +makeTestSuite :: TestID -> [Test] -> TestSuite +makeTestSuite = TestSuite + +makeAnonTestSuite :: [Test] -> TestSuite +makeAnonTestSuite = AnonTestSuite + +testSuiteAsTest :: TestSuite -> Test +testSuiteAsTest = CompoundTest + +addToTestSuite :: TestSuite -> [Test] -> TestSuite +addToTestSuite (TestSuite id ts) ts' = TestSuite id (ts ++ ts') +addToTestSuite (AnonTestSuite ts) ts' = AnonTestSuite (ts ++ ts') + +data TestSort = UnitTest | QuickCheckTest | BlackBoxTest + deriving (Eq,Show,Read) + +data Test = BaseTest TestSort TestID (Maybe Location) Assertion + | CompoundTest TestSuite + +data TestSuite = TestSuite TestID [Test] + | AnonTestSuite [Test] + +data FlatTest = FlatTest TestSort TestID (Maybe Location) Assertion + +class TestableHTF t where + flatten :: t -> [FlatTest] + +instance TestableHTF Test where + flatten = flattenTest Nothing + +instance TestableHTF TestSuite where + flatten = flattenTestSuite Nothing + +type Path = Maybe String + +flattenTest :: Path -> Test -> [FlatTest] +flattenTest path (BaseTest sort id mloc ass) = + [FlatTest sort (path `concatPath` id) mloc ass] +flattenTest path (CompoundTest ts) = + flattenTestSuite path ts + +flattenTestSuite :: Path -> TestSuite -> [FlatTest] +flattenTestSuite path (TestSuite id ts) = + concatMap (flattenTest (Just (path `concatPath` id))) ts +flattenTestSuite path (AnonTestSuite ts) = + concatMap (flattenTest path) ts + +concatPath :: Path -> String -> String +concatPath Nothing s = s +concatPath (Just s1) s2 = s1 ++ pathSep ++ s2 + where pathSep = ":" + +data TestState = TestState { ts_passed :: [String] + , ts_failed :: [String] + , ts_error :: [String] } + +initTestState :: TestState +initTestState = TestState [] [] [] + +type TR = StateT TestState IO + +runFlatTest :: FlatTest -> TR () +runFlatTest (FlatTest sort id mloc ass) = + do let name = id ++ case mloc of + Nothing -> "" + Just loc -> " (" ++ showLoc loc ++ ")" + liftIO $ report name + res <- liftIO $ HU.performTestCase ass + case res of + Nothing -> reportSuccess name + Just (isFailure', msg') -> + let (isFailure, msg, doReport) = + if sort /= QuickCheckTest + then (isFailure', msg', True) + else case readM msg' :: Maybe (Bool, Maybe String) of + Nothing -> + error ("ERROR: " ++ + "Cannot deserialize QuickCheck " ++ + "error message " ++ show msg') + Just (b, ms) -> + case ms of + Nothing -> (b, "", False) + Just s -> (b, s, True) + in if isFailure + then do modify (\s -> s { ts_failed = + name : (ts_failed s) }) + when doReport $ reportFailure msg + else do modify (\s -> s { ts_error = + name : (ts_error s) }) + when doReport $ reportError msg + liftIO $ report "" + where + reportSuccess name = + do modify (\s -> s { ts_passed = name : (ts_passed s) }) + when (sort /= QuickCheckTest) $ + liftIO $ report "+++ OK" + reportFailure msg = + reportMessage msg failurePrefix + reportError msg = + reportMessage msg errorPrefix + reportMessage msg prefix = liftIO $ report (prefix ++ msg) + failurePrefix = "*** Failed! " + errorPrefix = "@@@ Error! " + +runFlatTests :: [FlatTest] -> TR () +runFlatTests = mapM_ runFlatTest + +runTest :: TestableHTF t => t -> IO () +runTest = runTestWithFilter (\_ -> True) + +runTestWithArgs :: TestableHTF t => [String] -> t -> IO () +runTestWithArgs [] = runTest +runTestWithArgs l = runTestWithFilter pred + where pred (FlatTest _ id _ _) = any (\s -> s `isInfixOf` id) l + +type Filter = FlatTest -> Bool + +runTestWithFilter :: TestableHTF t => Filter -> t -> IO () +runTestWithFilter pred t = + do s <- execStateT (runFlatTests (filter pred (flatten t))) + initTestState + let passed = length (ts_passed s) + failed = length (ts_failed s) + error = length (ts_error s) + total = passed + failed + error + report ("* Tests: " ++ show total ++ "\n" ++ + "* Passed: " ++ show passed ++ "\n" ++ + "* Failures: " ++ show failed ++ "\n" ++ + "* Errors: " ++ show error ) + when (failed > 0) $ + reportDoc (text "\nFailures:" $$ renderTestNames + (reverse (ts_failed s))) + when (error > 0) $ + reportDoc (text "\nFailures:" $$ renderTestNames + (reverse (ts_error s))) + return () + where + renderTestNames l = + nest 2 (vcat (map (\name -> text "*" <+> text name) l)) + + +report :: String -> IO () +report = putStrLn + +reportDoc :: Doc -> IO () +reportDoc doc = report (render doc) diff --git a/Test/Framework/Tutorial.hs b/Test/Framework/Tutorial.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/Tutorial.hs @@ -0,0 +1,162 @@ +{-| + +This module provides a short tutorial on how to use the HTF. It +assumes that you are using GHC for compiling your Haskell code. (It is +possible to use the HTF with other Haskell environments, only the steps +taken to invoke the custom preprocessor of the HTF may differ in +this case.) + +Suppose you are writing a function for reversing lists: + +@ +myReverse :: [a] -> [a] +myReverse [] = [] +myReverse [x] = [x] +myReverse (x:xs) = myReverse xs +@ + +To test this function using the HTF, you first create a new source +file with a @OPTIONS_GHC@ pragma in the first line. + +@ +{-# OPTIONS_GHC -F -pgmF htfpp #-} +@ + +This pragma instructs GHC to run the source file through @htfpp@, the +custom preprocessor of the HTF. + +The following @import@ statements are also needed: + +@ +import System.Environment ( getArgs ) +import Test.Framework +@ + +The actual unit tests and QuickCheck properties are defined like this: + +@ +test_nonEmpty = do assertEqual [1] (myReverse [1]) + assertEqual [3,2,1] (myReverse [1,2,3]) + +test_empty = assertEqual ([] :: [Int]) (myReverse []) + +prop_reverse :: [Int] -> Bool +prop_reverse xs = xs == (myReverse (myReverse xs)) +@ + +When @htfpp@ consumes the source file, it replaces the @assertEqual@ +tokens (and other @assert@-like tokens, see +"Test.Framework.HUnitWrapper") with calls to +'assertEqual_', passing +the current location in the file as the first argument. Moreover, the +preprocessor collects all top-level definitions starting with @test_@ +or @prop_@ in a test suite with name allHTFTests of type 'TestSuite'. + +Definitions starting with @test_@ +denote unit tests and must be of type 'Assertion'. +Definitions starting with @prop_@ +denote QuickCheck properties and must be of type /T/ such that +/T/ is an instance of the type class 'Testable'. + +To run the tests, use the 'runTestWithArgs' function, which +takes a list of strings and the test. + +@ +main = + do args <- getArgs + runTestWithArgs args reverseTests +@ + +Here is the skeleton of a @.cabal@ file which you may want to use to +compile the tests. + +@ +Name: HTF-tutorial +Version: 0.1 +Cabal-Version: >= 1.6 +Build-type: Simple + +Executable tutorial + Main-is: Tutorial.hs + Build-depends: base, HTF +@ + +Compiling the program just shown (you must include the code for +@myReverse@ as well), and then running the resulting program with no +further commandline arguments yields the following output: + +> Main:nonEmpty (Tutorial.hs:17) +> *** Failed! assertEqual failed at Tutorial.hs:18 +> expected: [3,2,1] +> but got: [3] +> +> Main:empty (Tutorial.hs:19) +> +++ OK +> +> Main:reverse (Tutorial.hs:22) +> *** Failed! Falsifiable (after 3 tests and 1 shrink): +> [0,0] +> Replay argument: "Just (847701486 2147483396,2)" +> +> * Tests: 3 +> * Passed: 1 +> * Failures: 2 +> * Errors: 0 + +(To check only specific tests, you can pass commandline +arguments to the program: the HTF then runs only those tests whose name +contain at least one of the commandline arguments as a substring.) + +You see that the message for the first failure contains exact location +information, which is quite convenient. Moreover, for the QuickCheck +property @Main.reverse@, the HTF also outputs a string +represenation of the random generator used to check the property. This +string representation can be used to replay the property. (The replay +feature may not be useful for this simple example but it helps in more +complex scenarios). + +To replay a property you simply use the string +representation of the generator to define a new QuickCheck property +with custom arguments: + +@ +prop_reverseReplay = + 'withQCArgs' (\a -> a { 'replay' = 'read' \"Just (1060394807 2147483396,2)\" }) + prop_reverse +@ + +To finish this tutorial, we now give a correct definition for @myReverse@: + +@ +myReverse :: [a] -> [a] +myReverse [] = [] +myReverse (x:xs) = myReverse xs ++ [x] +@ + +Running our tests again on the fixed definition then yields the +desired result: + +> Main:nonEmpty (Tutorial.hs:17) +> +++ OK +> +> Main:empty (Tutorial.hs:19) +> +++ OK +> +> Main:reverse (Tutorial.hs:22) +> +++ OK, passed 100 tests. +> +> Main:reverseReplay (Tutorial.hs:24) +> +++ OK, passed 100 tests. +> +> * Tests: 4 +> * Passed: 4 +> * Failures: 0 +> * Errors: 0 + +The HTF also allows the definition of black box tests. See the documentation +of the "Test.Framework.BlackBoxTest" module for further information. + +-} +module Test.Framework.Tutorial where + +import Test.Framework diff --git a/Test/Framework/Utils.hs b/Test/Framework/Utils.hs --- a/Test/Framework/Utils.hs +++ b/Test/Framework/Utils.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE PatternGuards #-} -- -- Copyright (c) 2005 Stefan Wehr - http://www.stefanwehr.de -- @@ -46,6 +47,12 @@ let n = length s - length suf in drop n s == suf +dropPrefix :: String -> String -> String +dropPrefix s pref = + if startswith s pref + then drop (length pref) s + else s + dropSuffix :: FilePath -> FilePath dropSuffix f = reverse . tail . dropWhile (/= '.') $ reverse f @@ -67,13 +74,14 @@ collectFiles :: FilePath -- the directory to start from -> String -- suffix of the file names to collect - -> (FilePath -> [FilePath] -> IO Bool) -- predicate that determines - -- whether files below a certain - -- directory should be pruned. - -- The first argument is the - -- name of the directory, the - -- second the entries of the - -- directory + -> (FilePath -> [FilePath] -> IO Bool) + -- predicate that determines + -- whether files below a certain + -- directory should be pruned. + -- The first argument is the + -- name of the directory, the + -- second the entries of the + -- directory -> IO [FilePath] collectFiles root suf prune = do entries <- getDirectoryContents root @@ -106,4 +114,10 @@ mapAccumLM f s (x:xs) = do (s', y ) <- f s x (s'',ys) <- mapAccumLM f s' xs return (s'',y:ys) - + +readM :: (Monad m, Read a) => String -> m a +readM s | [x] <- parse = return x + | otherwise = fail $ "Failed parse: " ++ show s + where + parse = [x | (x,t) <- reads s] + diff --git a/scripts/HTFpp.hs b/scripts/HTFpp.hs deleted file mode 100644 --- a/scripts/HTFpp.hs +++ /dev/null @@ -1,66 +0,0 @@ --- --- Copyright (c) 2005 Stefan Wehr - http://www.stefanwehr.de --- --- This program is free software; you can redistribute it and/or --- modify it under the terms of the GNU General Public License as --- published by the Free Software Foundation; either version 2 of --- the License, or (at your option) any later version. --- --- This program is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU --- General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with this program; if not, write to the Free Software --- Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA --- 02111-1307, USA. --- - -module Main where - -import System.IO -import System.Environment -import System.Exit - -import Test.Framework.Process - -assertions :: [String] -assertions = [ "assertBool" - , "assertEqual" - , "assertEqualNoShow" - , "assertSetEqual" - , "assertNull" - , "assertNotNull" - , "assertThrows" - ] - -macros :: String -macros = unlines $ - "#define SRC_LOC_ (__FILE__, __LINE__)" : - map define assertions - where define s = "#define " ++ s ++ " (" ++ s ++ "_ SRC_LOC_)" - -main :: IO () -main = - do prog <- getProgName - args <- getArgs - if length args /= 4 - then hPutStrLn stderr - ("Usage: " ++ prog ++ - " original-filename input-filename output-filename " - ++ "cpp-command") - else let orig = args!!0 - infile = args!!1 - outfile = args!!2 - cpp = args!!3 - fstLine = "#line 1 \"" ++ orig ++ "\"\n" - in do inString <- readFile infile - (out,err,_) <- popen cpp ["-w"] - (Just $ macros ++ fstLine ++ - inString) - if null err - then do writeFile outfile out - exitWith ExitSuccess - else do hPutStrLn stderr err - exitWith (ExitFailure 1)