HTF 0.1 → 0.3
raw patch · 20 files changed
+1293/−555 lines, 20 filesdep +cpphsdep +haskell-src-extsdep +mtldep −template-haskelldep ~HUnitdep ~QuickCheckdep ~basesetup-changednew-component:exe:htfppnew-uploader
Dependencies added: cpphs, haskell-src-exts, mtl, pretty
Dependencies removed: template-haskell
Dependency ranges changed: HUnit, QuickCheck, base
Files
- HTF.cabal +54/−29
- HTFPP.hs +89/−0
- README +35/−0
- Setup.hs +1/−1
- TODO +4/−0
- Test/Framework.hs +13/−58
- Test/Framework/BlackBoxTest.hs +235/−0
- Test/Framework/Configuration.hs +0/−4
- Test/Framework/FileBasedTest.hs +0/−190
- Test/Framework/HUnitWrapper.hs +79/−97
- Test/Framework/HaskellParser.hs +82/−0
- Test/Framework/Location.hs +23/−3
- Test/Framework/Preprocessor.hs +150/−0
- Test/Framework/Pretty.hs +42/−0
- Test/Framework/Process.hs +3/−2
- Test/Framework/QuickCheckWrapper.hs +74/−97
- Test/Framework/TestManager.hs +225/−0
- Test/Framework/Tutorial.hs +162/−0
- Test/Framework/Utils.hs +22/−8
- scripts/HTFpp.hs +0/−66
HTF.cabal view
@@ -1,39 +1,64 @@ Name: HTF-Version: 0.1+Version: 0.3 License: LGPL-License-file: LICENSE-Author: Stefan Wehr <wehr@informatik.uni-freiburg.de>+License-File: LICENSE+Copyright: (c) 2005-2010 Stefan Wehr+Author: Stefan Wehr <mail@stefanwehr.de>+Maintainer: Stefan Wehr <mail@stefanwehr.de>+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 (<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. -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
+ HTFPP.hs view
@@ -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>", 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
+ README view
@@ -0,0 +1,35 @@+ HTF - The Haskell Test Framework+ ====================================++Author: Stefan Wehr <mail AT stefanwehr DOT de>+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)
Setup.hs view
@@ -2,4 +2,4 @@ import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks+main = defaultMain
+ TODO view
@@ -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
Test/Framework.hs view
@@ -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))) |]+
+ Test/Framework/BlackBoxTest.hs view
@@ -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)+
− Test/Framework/Configuration.hs
@@ -1,4 +0,0 @@--- GENERATED AUTOMATICALLY, DO NOT EDIT!!-module Test.Framework.Configuration where-import Data.Version-ghcVersion = Version {versionBranch = [6,4,1], versionTags = []}
− Test/Framework/FileBasedTest.hs
@@ -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)-
Test/Framework/HUnitWrapper.hs view
@@ -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")
+ Test/Framework/HaskellParser.hs view
@@ -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
Test/Framework/Location.hs view
@@ -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
+ Test/Framework/Preprocessor.hs view
@@ -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) ++ ")"
+ Test/Framework/Pretty.hs view
@@ -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+
Test/Framework/Process.hs view
@@ -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
Test/Framework/QuickCheckWrapper.hs view
@@ -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
+ Test/Framework/TestManager.hs view
@@ -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)
+ Test/Framework/Tutorial.hs view
@@ -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
Test/Framework/Utils.hs view
@@ -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]+
− scripts/HTFpp.hs
@@ -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)