HTF 0.8.2.2 → 0.9.0.0

raw patch · 23 files changed

+770/−363 lines, 23 filesdep −criterionPVP ok

version bump matches the API change (PVP)

Dependencies removed: criterion

API changes (from Hackage documentation)

Files

• ChangeLog +9/−0
• HTF.cabal +50/−14
• HTFPP.hs +3/−1
• README +0/−33
• README.md +38/−0
• TODO +0/−4
• TODO.org +3/−0
• Test/Framework.hs +2/−4
• Test/Framework/BlackBoxTest.hs +75/−12
• Test/Framework/Colors.hs +1/−1
• Test/Framework/CriterionWrapper.hs +0/−151
• Test/Framework/Diff.hs +4/−1
• Test/Framework/HUnitWrapper.hs +96/−13
• Test/Framework/HaskellParser.hs +33/−8
• Test/Framework/Location.hs +12/−1
• Test/Framework/Preprocessor.hs +80/−25
• Test/Framework/Pretty.hs +17/−2
• Test/Framework/QuickCheckWrapper.hs +37/−7
• Test/Framework/TestConfig.hs +3/−5
• Test/Framework/TestManager.hs +118/−41
• Test/Framework/TestManagerInternal.hs +2/−1
• Test/Framework/Tutorial.hs +183/−38
• Test/Framework/Utils.hs +4/−1

@@ -1,3 +1,12 @@+* 0.9.0.0 (2012-09-26)+  NOTE: this version is NOT backwards compatible with 0.8.*. The documentation on+  hackage describes what you need to do in order to upgrade.++  - Totally reworked how tests are collected+  - Greatly improved documentation (fixes issue #2)+  - Added assertThrowsIO and similar functions (fixes issue #6)+  - Added htfMain function+ * 0.8.2.0 (2012-01-30)   - Assertions can be run via runTest   - Support for assertNotEqual

@@ -1,8 +1,8 @@ Name:             HTF-Version:          0.8.2.2+Version:          0.9.0.0 License:          LGPL License-File:     LICENSE-Copyright:        (c) 2005-2011 Stefan Wehr+Copyright:        (c) 2005-2012 Stefan Wehr Author:           Stefan Wehr <mail@stefanwehr.de> Maintainer:       Stefan Wehr <mail@stefanwehr.de> Bug-Reports:      mailto:mail@stefanwehr.de@@ -14,27 +14,65 @@     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+    tests in an easy and convenient way. HTF uses a custom     preprocessor that collects test definitions automatically.-    Furthermore, the preprocessor allows the HTF to report failing+    Furthermore, the preprocessor allows HTF to report failing     test cases with exact file name and line number information.+    Additionally, HTF tries to produce highly readable output+    for failing tests: for example, it colors and pretty prints expected and+    actual results and provides a diff between the two values.      .      The documentation of the "Test.Framework.Tutorial" module-    provides a tutorial for the HTF.+    provides a tutorial for HTF. There is also a slightly out-dated+    blog article (<http://factisresearch.blogspot.de/2011/10/new-version-of-htf-with-diffs-colors.html>)+    demonstrating HTF's coloring, pretty-printing and diff functionality. -Tested-With:      GHC==6.10.4, GHC==6.12, GHC==7.0+    .++    /HEADS UP, backwards incomatibility with prior versions:/++    .+    Starting with version 0.9.0.0, HTF uses a new strategy+    for collecting the testcases defined in your project+    (see "Test.Framework.Tutorial" for a description of this strategy).+    If you used version 0.8.* or earlier of HTF, this /will break your build!/+    However, it's rather easy to bring you project in line with the new HTF+    version. Here are the steps that will most likely resolve+    your backwards incompatibility problems:++    .++    * If a module exports the @allHTFTests@ symbol, this export must+      be changed to @htf_thisModulesTests@.++    .++    * If an import declaration of some module hides the @allHTFTests@+      symbol, you can simply remove the hiding clause for @allHTFTests@.++    .++    * If a module collects and executes tests from several other modules,+      the collecting module has to be changed as follows: add+      @&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;@ to the top+      of the collecting module, import+      the other modules with the @&#x7b;-&#x40; HTF_TESTS &#x40;-&#x7d;@+      annotation, use the symbol @htf_importedTests@ for referencing+      the imported tests. See "Test.Framework.Tutorial" for details.++Tested-With:      GHC==7.0.4, GHC==7.2.1, GHC==7.4.1, GHC==7.4.2, GHC==7.6.1 Build-Type:       Simple Cabal-Version:    >= 1.6 Extra-Source-Files:-  README-  TODO+  README.md+  TODO.org   ChangeLog  Source-Repository head-  Type:           darcs-  Location:       http://www.stefanwehr.de/darcs/HTF+  Type:           git+  Location:       git://github.com/skogsbaer/HTF.git  Executable htfpp   Main-Is:          HTFPP.hs@@ -59,14 +97,11 @@                     unix >= 2.4 && < 2.7,                     bytestring >= 0.9 && < 0.11,                     regex-compat >= 0.92 && < 0.96,-                    haskell-src-exts >= 1.11 && < 1.14,-                    criterion >= 0.5 && < 0.7+                    haskell-src-exts >= 1.11 && < 1.14   Exposed-Modules:     Test.Framework     Test.Framework.HUnitWrapper-    Test.Framework.CriterionWrapper     Test.Framework.TestManager-    Test.Framework.TestConfig     Test.Framework.QuickCheckWrapper     Test.Framework.BlackBoxTest     Test.Framework.Location@@ -78,3 +113,4 @@     Test.Framework.Colors     Test.Framework.Diff     Test.Framework.Process+    Test.Framework.TestConfig

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables,CPP #-}  -- -- Copyright (c) 2009   Stefan Wehr - http://www.stefanwehr.de@@ -18,7 +18,9 @@ -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA -- +#if !MIN_VERSION_base(4,6,0) import Prelude hiding ( catch )+#endif import System.IO import System.Environment import System.Exit

@@ -1,33 +0,0 @@-                    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 and 6.12.3)-- Some haskell libraries, see HTF.cabal---Installation instructions:-----------------------------Execute the command `cabal install' inside the HTF root directory.

@@ -0,0 +1,38 @@+# HTF - The Haskell Test Framework++* Documentation:     http://hackage.haskell.org/package/HTF+* Source Repository: https://github.com/skogsbaer/HTF/+* Issue tracker:     https://github.com/skogsbaer/HTF/issues?state=open+* Author:            Stefan Wehr (http://www.stefanwehr.de)+* License: LGPL++## Summary++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. HTF uses a custom preprocessor that collects+test definitions automatically. Furthermore, the preprocessor allows+HTF to report failing test cases with exact file name and line number+information. Additionally, HTF tries to produce highly readable output+for failing tests: for example, it colors and pretty prints expected and+actual results and provides a diff between the two values.++Look [here](http://hackage.haskell.org/packages/archive/HTF/latest/doc/html/Test-Framework-Tutorial.html)+for a short tutorial on HTF. The following slightly out-dated+[blog article](http://factisresearch.blogspot.de/2011/10/new-version-of-htf-with-diffs-colors.html)+demonstrates HTF's coloring, pretty-printing and diff functionality.++## Installation instructions++* Install from http://hackage.haskell.org/ using `cabal install HTF`+* Install from source:++        $ git clone git@github.com:skogsbaer/HTF.git+        $ cd HTF+        $ cabal install++## Getting started++* Read the [tutorial](http://hackage.haskell.org/packages/archive/HTF/latest/doc/html/Test-Framework-Tutorial.html).+* Experiment with the sample project located in the `sample` directory of HTF's source tree.

@@ -1,4 +0,0 @@-* Replace haskell-src-exts by the GHC parser-* Write proper documentation-* diff if assertEqualsP fails-* LATER: Support for Smallcheck and/or Lazy Smallcheck

@@ -0,0 +1,3 @@+* Replace haskell-src-exts by the GHC parser+* diff if assertEqualsP fails+* LATER: Support for Smallcheck and/or Lazy Smallcheck

@@ -1,13 +1,13 @@ {-# LANGUAGE TemplateHaskell #-} ---+--  -- 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@@ -22,7 +22,6 @@    module Test.Framework.HUnitWrapper,   module Test.Framework.QuickCheckWrapper,-  module Test.Framework.CriterionWrapper,   module Test.Framework.BlackBoxTest,   module Test.Framework.TestManager, @@ -32,7 +31,6 @@  import Test.Framework.HUnitWrapper import Test.Framework.QuickCheckWrapper-import Test.Framework.CriterionWrapper import Test.Framework.BlackBoxTest import Test.Framework.TestManager import qualified Test.Framework.Location as Loc

@@ -1,5 +1,6 @@+{-# LANGUAGE CPP #-} ----- Copyright (c) 2005,2009   Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2005,2009,2012   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@@ -22,7 +23,13 @@ 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.+The samples directory of the HTF source tree shows an example+for a black box test, see <https://github.com/skogsbaer/HTF/tree/master/sample>. +/NOTE:/ If you use black box tests, you have to compile your program+with the @-threaded@ option. Otherwise, your program just blocks+indefinitely!+ -} module Test.Framework.BlackBoxTest ( @@ -34,7 +41,9 @@  ) where +#if !MIN_VERSION_base(4,6,0) import Prelude hiding ( catch )+#endif  import System.IO import System.Exit@@ -116,14 +125,32 @@ 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 }+{- |+Use a value of this datatype to customize various aspects+of your black box tests.+-}+data BBTArgs = BBTArgs { bbtArgs_stdinSuffix    :: String -- ^ File extension for the file used as stdin.+                       , bbtArgs_stdoutSuffix   :: String -- ^ File extension for the file specifying expected output on stdout.+                       , bbtArgs_stderrSuffix   :: String -- ^ File extension for the file specifying expected output on stderr.+                       , bbtArgs_dynArgsName    :: String -- ^ Name of a file defining various arguments for executing the tests contained in a subdirectory of the test hierarchy. If a directory contains a such-named file, the arguments apply to all testfiles directly contained in this directory. See the documentation of 'blackBoxTests' for a specification of the argument file format.+                       , bbtArgs_verbose        :: Bool   -- ^ Ge verbose or not.+                       , bbtArgs_stdoutDiff     :: Diff   -- ^ Diff program for comparing output on stdout with the expected value.+                       , bbtArgs_stderrDiff     :: Diff   -- ^ Diff program for comparing output on stderr with the expected value.+                       } +{- |+Sensible default values for 'BBTArgs':++@+defaultBBTArgs = BBTArgs { bbtArgs_stdinSuffix    = \".in\"+                         , bbtArgs_stdoutSuffix   = \".out\"+                         , bbtArgs_stderrSuffix   = \".err\"+                         , bbtArgs_dynArgsName    = "BBTArgs"+                         , bbtArgs_stdoutDiff     = defaultDiff+                         , bbtArgs_stderrDiff     = defaultDiff+                         , bbtArgs_verbose        = False }+@+-} defaultBBTArgs :: BBTArgs defaultBBTArgs = BBTArgs { bbtArgs_stdinSuffix    = ".in"                          , bbtArgs_stdoutSuffix   = ".out"@@ -133,6 +160,10 @@                          , bbtArgs_stderrDiff     = defaultDiff                          , bbtArgs_verbose        = False } +{- |+A default value for the 'Diff' datatype that simple resorts to the+@diff@ commandline utility.+-} defaultDiff :: Diff defaultDiff expectFile real =     do mexe <- findExecutable "diff"@@ -154,10 +185,42 @@                   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+{- |+Collects all black box tests with the given file extension stored in a specific directory.+For example, the invocation++> blackBoxTests "bbt-dir" "dist/build/sample/sample" ".num" defaultBBTArgs++returns a list of 'Test' values, one 'Test' for each @.num@ file found in+@bbt-dir@ and its subdirectories. (The samples directory of the HTF source tree+contains the example shown here,+see <https://github.com/skogsbaer/HTF/tree/master/sample>.)++Suppose that one of the @.num@ files+is @bbt-dir\/should-pass\/x.num@. Running the corresponding 'Test' invokes+@dist\/build\/sample\/sample@ (the program under test) with @bbt-dir\/should-pass\/x.num@+as input file. If @bbt-dir\/should-pass\/x.num@ existed, its content+would be used as stdin. The tests succeeds+if the exit code of the program is zero and+the output on stdout and stderr matches the contents of+@bbt-dir\/should-pass\/x.out@ and @bbt-dir\/should-pass\/x.err@, respectively.++The directory @bbt-dir\/should-fail@ contains the file @BBTArgs@. If this file+exists, then its content specifies various+arguments for the test run. The file defines the arguments separated by newlines.+Supported arguments:++ [@Skip@] Skips all tests in the same directory as the argument file.++ [@Fail@] Specify that the test should succeed if it exits with a non-zero exit code.++ [@Flags: flags@] Passes the given @flags@ to the program under test.++-}+blackBoxTests :: FilePath  -- ^ root directory of the test hierarchy+              -> String    -- ^ name of program under test+              -> String    -- ^ filename suffix for input file+              -> BBTArgs   -- ^ configuration               -> IO [Test] blackBoxTests root exe suf cfg =     do let prune root _ = do dynCfg <- readDynCfg Map.empty

@@ -1,5 +1,5 @@ ----- Copyright (c) 2011   Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2011, 2012   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

@@ -1,151 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverlappingInstances #-}-{-# LANGUAGE UndecidableInstances #-}------- Copyright (c) 2011   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.CriterionWrapper (--    HtfBenchmark, ComparisonBenchmark-  , mkComparison, mkComparisonWithMargin-  , simpleBenchmark, withBenchmarkConfig-  , withBenchmarkComparison, withBenchmarkComparisonAndConfig-  , IsHtfBenchmark, asHtfBenchmark, prepareHtfBenchmark-  , defaultBenchmarkConfig--) where----import qualified Data.Vector.Unboxed as V---import Control.Monad.Trans--import Data.Maybe (isJust)--import Criterion-import Criterion.Monad-import Criterion.Environment-import Criterion.Config--import Test.Framework.TestConfig--data AnyBenchmarkable = forall b . Benchmarkable b => AnyBenchmarkable b--instance Benchmarkable AnyBenchmarkable where-    run (AnyBenchmarkable b) n = run b n--data HtfBenchmark-    = HtfBenchmark-      { htfb_benchmarkable :: AnyBenchmarkable-      , htfb_config :: Config-      , htfb_comparison :: Maybe ComparisonBenchmark-      , htfb_pending :: Bool-      }--instance Benchmarkable HtfBenchmark where-    run b n = run (htfb_benchmarkable b) n--data ComparisonBenchmark-    = ComparisonBenchmark-      { cb_benchmarkable :: AnyBenchmarkable-      , cb_factor :: Double-      , cb_margin :: Double-      }--defaultBenchmarkConfig :: Config-defaultBenchmarkConfig = defaultConfig--mkComparison :: Benchmarkable b => b -> Double -> ComparisonBenchmark-mkComparison b f = mkComparisonWithMargin b f 0.1--mkComparisonWithMargin :: Benchmarkable b => b -> Double -> Double -> ComparisonBenchmark-mkComparisonWithMargin b f m = ComparisonBenchmark (AnyBenchmarkable b) f m--simpleBenchmark :: Benchmarkable b => b -> HtfBenchmark-simpleBenchmark b =-    HtfBenchmark-    {-      htfb_benchmarkable = AnyBenchmarkable b-    , htfb_config = defaultConfig-    , htfb_comparison = Nothing-    , htfb_pending = False-    }--withBenchmarkConfig :: Benchmarkable b => Config -> b -> HtfBenchmark-withBenchmarkConfig cfg b =-    HtfBenchmark-    {-      htfb_benchmarkable = AnyBenchmarkable b-    , htfb_config = cfg-    , htfb_comparison = Nothing-    , htfb_pending = False-    }--withBenchmarkComparison :: Benchmarkable b => ComparisonBenchmark -> b -> HtfBenchmark-withBenchmarkComparison cmp b =-    HtfBenchmark-    {-      htfb_benchmarkable = AnyBenchmarkable b-    , htfb_config = defaultConfig-    , htfb_comparison = Just cmp-    , htfb_pending = False-    }--withBenchmarkComparisonAndConfig ::-    Benchmarkable b => ComparisonBenchmark -> Config -> b -> HtfBenchmark-withBenchmarkComparisonAndConfig cmp cfg b =-    HtfBenchmark-    {-      htfb_benchmarkable = AnyBenchmarkable b-    , htfb_config = cfg-    , htfb_comparison = Just cmp-    , htfb_pending = False-    }--{--getSamples :: Benchmarkable b => b -> IO [Double]-getSamples b =-    do samples <- withConfig defaultConfig $ do env <- measureEnvironment-                                                liftIO $ putStrLn "running benchmark"-                                                runBenchmark env b-       return $ V.toList samples--}--class IsHtfBenchmark a where-    isHtfBenchmark :: a -> Maybe HtfBenchmark--instance IsHtfBenchmark HtfBenchmark where-    isHtfBenchmark = Just--instance Benchmarkable b => IsHtfBenchmark b where-    isHtfBenchmark = Just . simpleBenchmark--asHtfBenchmark :: (Benchmarkable b, IsHtfBenchmark b) => b -> HtfBenchmark-asHtfBenchmark b =-    case isHtfBenchmark b of-      Nothing -> simpleBenchmark b-      Just h -> h--prepareHtfBenchmark :: HtfBenchmark -> (TestConfig -> Bool, IO ())-prepareHtfBenchmark bench =-    (\tc -> tc_benchmarks tc || isJust (htfb_comparison bench),-     putStrLn "running benchmarks not yet implemented")--benchmarkPending :: (Benchmarkable b, IsHtfBenchmark b) => b -> HtfBenchmark-benchmarkPending x =-    (asHtfBenchmark x) { htfb_pending = True }

@@ -1,5 +1,6 @@+{-# LANGUAGE CPP #-} ----- Copyright (c) 2011   Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2011, 2012   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@@ -24,7 +25,9 @@  ) where +#if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch)+#endif  import Control.Exception (catch, finally, IOException) import qualified Data.List as List

@@ -1,7 +1,7 @@ {-# OPTIONS_GHC -cpp -pgmPcpphs -optP --layout -optP --hashes -optP --cpp #-} {-# LANGUAGE ScopedTypeVariables #-} ----- Copyright (c) 2005, 2009   Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2005, 2009, 2012  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@@ -19,17 +19,23 @@ --  {-|-You should not use the functions provided by this module directly.-Instead, for each function @assertXXX_@ defined in this module,++This module provides assert-like functions for writing unit tests.++/Hint:/ Do not use the @assertXXX_@ functions+directly. Instead, for each function @assertXXX_@, there exist a preprocessor macro @assertXXX@, which provides-the "Location" parameter automatically.-|-}+the "Location" parameter automatically. Use these macros, which+are available automatically if you add -module Test.Framework.HUnitWrapper (+@&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;@ -  -- * General failure-  assertFailure, unitTestPending, unitTestPending',+at the top of your source file (see the 'Test.Framework.Tutorial'). +-}++module Test.Framework.HUnitWrapper (+   -- * Assertions on Bool values   assertBool_, assertBoolVerbose_, @@ -49,6 +55,8 @@   -- * Assertions for exceptions   assertThrows_, assertThrowsVerbose_,   assertThrowsSome_, assertThrowsSomeVerbose_,+  assertThrowsIO_, assertThrowsIOVerbose_,+  assertThrowsSomeIO_, assertThrowsSomeIOVerbose_,    -- * Assertions on Either values   assertLeft_, assertLeftVerbose_,@@ -59,8 +67,11 @@   -- * Assertions on Just values   assertJust_, assertJustVerbose_,   assertNothing_, assertNothingVerbose_,-  assertNothingNoShow_, assertNothingNoShowVerbose_+  assertNothingNoShow_, assertNothingNoShowVerbose_, +  -- * General failure+  assertFailure, unitTestPending, unitTestPending'+ ) where  import System.IO ( stderr )@@ -81,9 +92,16 @@  -- WARNING: do not forget to add a preprocessor macro for new assertions!! +{- |+Fail with the given reason.+-} assertFailure :: String -> IO a assertFailure s = unitTestFail s +{- |+Use @unitTestPending' msg test@ to mark the given test as pending+without removing it from the test suite and without deleting or commenting out the test code.+-} unitTestPending' :: String -> IO a -> IO a unitTestPending' msg _ = unitTestPending msg @@ -114,13 +132,23 @@ #define CreateAssertionsRet(__name__, __type__, __ret__) \ CreateAssertionsGeneric(__name__, , __type__, __ret__) +#define DocAssertion(__name__, __text__) \+  {- | __text__ The 'String' parameter in the @Verbose@ \+      variant can be used to provide extra information about the error. Do not use \+      @__name__##_@ and @__name__##Verbose_@ directly, use the macros @__name__@ \+      and @__name__##Verbose@ instead. These macros, provided by the @htfpp@ preprocessor, \+      insert the 'Location' parameter automatically. -}+ -- -- Boolean Assertions --+ _assertBool_ :: String -> Location -> String -> Bool -> HU.Assertion _assertBool_ name loc s False =     assertFailure (mkMsg name s ("failed at " ++ showLoc loc)) _assertBool_ _ _ _   True = return ()++DocAssertion(assertBool, Fail if the 'Bool' value is 'False'.) CreateAssertions(assertBool, Bool)  --@@ -176,6 +204,10 @@        then do x <- equalityFailedMessage (show expected) (show actual)                assertFailure (mkMsg name s $ "failed at " ++ showLoc loc ++ x)        else return ()++DocAssertion(assertEqual, Fail if the two values of type @a@ are not equal.+             The first parameter denotes the expected value. Use these two functions+             of @a@ is an instance of 'Show' but not of 'Pretty'.) CreateAssertionsCtx(assertEqual, (Eq a, Show a), a -> a)  _assertNotEqual_ :: (Eq a, Show a)@@ -185,6 +217,10 @@        then do x <- notEqualityFailedMessage (show expected)                assertFailure (mkMsg name s $ "failed at " ++ showLoc loc ++ x)        else return ()++DocAssertion(assertNotEqual, Fail if the two values of type @a@ are equal.+             The first parameter denotes the expected value. Use these two functions+             of @a@ is an instance of 'Show' but not of 'Pretty'.) CreateAssertionsCtx(assertNotEqual, (Eq a, Show a), a -> a)  _assertEqualPretty_ :: (Eq a, Pretty a)@@ -194,6 +230,10 @@        then do x <- equalityFailedMessage (showPretty expected) (showPretty actual)                assertFailure (mkMsg name s $ "failed at " ++ showLoc loc ++ x)        else return ()++DocAssertion(assertEqualPretty, Fail if the two values of type @a@ are not equal.+             The first parameter denotes the expected value. Use these two functions+             of @a@ is an instance of 'Pretty'.) CreateAssertionsCtx(assertEqualPretty, (Eq a, Pretty a), a -> a)  _assertNotEqualPretty_ :: (Eq a, Pretty a)@@ -203,6 +243,9 @@        then do x <- notEqualityFailedMessage (showPretty expected)                assertFailure (mkMsg name s $ "failed at " ++ showLoc loc ++ x)        else return ()+DocAssertion(assertNotEqualPretty, Fail if the two values of type @a@ are equal.+             The first parameter denotes the expected value. Use these two functions+             of @a@ is an instance of 'Pretty'.) CreateAssertionsCtx(assertNotEqualPretty, (Eq a, Pretty a), a -> a)  _assertEqualNoShow_ :: Eq a@@ -211,6 +254,10 @@     if expected /= actual        then assertFailure (mkMsg name s ("failed at " ++ showLoc loc))        else return ()+DocAssertion(assertEqualNoShow, Fail if the two values of type @a@ are not equal.+             The first parameter denotes the expected value. Use these two functions+             of @a@ is neither an instance of 'Show' nor 'Pretty'. Be aware that in this+             case the generated error message might not be very helpful.) CreateAssertionsCtx(assertEqualNoShow, Eq a, a -> a)  _assertNotEqualNoShow_ :: Eq a@@ -219,6 +266,10 @@     if expected == actual        then assertFailure (mkMsg name s ("failed at " ++ showLoc loc))        else return ()+DocAssertion(assertNotEqualNoShow, Fail if the two values of type @a@ are equal.+             The first parameter denotes the expected value. Use these two functions+             of @a@ is neither an instance of 'Show' nor 'Pretty'. Be aware that in this+             case the generated error message might not be very helpful.) CreateAssertionsCtx(assertNotEqualNoShow, Eq a, a -> a)  --@@ -243,28 +294,33 @@              | otherwise -> return ()     where unorderedEq l1 l2 =               null (l1 \\ l2) && null (l2 \\ l1)+DocAssertion(assertListsEqualAsSets, Fail if the two given lists are not equal+                                     when considered as sets. The first list parameter+                                     denotes the expected value.) CreateAssertionsCtx(assertListsEqualAsSets, (Eq a, Show a), [a] -> [a])  _assertNotEmpty_ :: String -> Location -> String -> [a] -> HU.Assertion _assertNotEmpty_ name loc s [] =     assertFailure (mkMsg name s ("failed at " ++ showLoc loc)) _assertNotEmpty_ _ _ _ (_:_) = return ()+DocAssertion(assertNotEmpty, Fail if the given list is empty.) CreateAssertions(assertNotEmpty, [a])  _assertEmpty_ :: String -> Location -> String -> [a] -> HU.Assertion _assertEmpty_ name loc s (_:_) =     assertFailure (mkMsg name s ("failed at " ++ showLoc loc)) _assertEmpty_ _ _ _ [] = return ()+DocAssertion(assertEmpty, Fail if the given list is a non-empty list.) CreateAssertions(assertEmpty, [a])  -- -- Assertions for Exceptions -- -_assertThrows_ :: Exception e-               => String -> Location -> String -> a -> (e -> Bool) -> HU.Assertion-_assertThrows_ name loc s x f =-    do res <- try (evaluate x)+_assertThrowsIO_ :: Exception e+                 => String -> Location -> String -> IO a -> (e -> Bool) -> HU.Assertion+_assertThrowsIO_ name loc s x f =+    do res <- try x        case res of          Right _ -> assertFailure (mkMsg name s                                    ("failed at " ++ showLoc loc ++@@ -275,11 +331,28 @@                                         showLoc loc ++                                         ": wrong exception was thrown: " ++                                         show e))+DocAssertion(assertThrowsIO, Fail if executing the 'IO' action does not+             throw an exception satisfying the given predicate @(e -> Bool)@.)+CreateAssertionsCtx(assertThrowsIO, Exception e, IO a -> (e -> Bool))++_assertThrowsSomeIO_ :: String -> Location -> String -> IO a -> HU.Assertion+_assertThrowsSomeIO_ name loc s x = _assertThrowsIO_ name loc s x (\ (e::SomeException) -> True)+DocAssertion(assertThrowsSomeIO, Fail if executing the 'IO' action does not+             throw an exception.)+CreateAssertions(assertThrowsSomeIO, IO a)++_assertThrows_ :: Exception e+               => String -> Location -> String -> a -> (e -> Bool) -> HU.Assertion+_assertThrows_ name loc s x f = _assertThrowsIO_ name loc s (evaluate x) f+DocAssertion(assertThrows, Fail if evaluating the expression of type @a@ does not+             throw an exception satisfying the given predicate @(e -> Bool)@.) CreateAssertionsCtx(assertThrows, Exception e, a -> (e -> Bool))  _assertThrowsSome_ :: String -> Location -> String -> a -> HU.Assertion _assertThrowsSome_ name loc s x =     _assertThrows_ name loc s x (\ (e::SomeException) -> True)+DocAssertion(assertThrowsSome, Fail if evaluating the expression of type @a@ does not+             throw an exception.) CreateAssertions(assertThrowsSome, a)  --@@ -294,6 +367,8 @@                    ("failed at " ++ showLoc loc ++                     ": expected a Left value, given " ++                     show (Right x :: Either b b)))+DocAssertion(assertLeft, Fail if the given @Either a b@ value is a 'Right'.+             Use this function if @b@ is an instance of 'Show') CreateAssertionsCtxRet(assertLeft, Show b, Either a b, IO a)  _assertLeftNoShow_ :: String -> Location -> String -> Either a b -> IO a@@ -301,6 +376,7 @@ _assertLeftNoShow_ name loc s (Right _) =     assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++                                  ": expected a Left value, given a Right value"))+DocAssertion(assertLeftNoShow, Fail if the given @Either a b@ value is a 'Right'.) CreateAssertionsRet(assertLeftNoShow, Either a b, IO a)  _assertRight_ :: forall a b . Show a@@ -310,6 +386,8 @@     assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++                                  ": expected a Right value, given " ++                                  show (Left x :: Either a a)))+DocAssertion(assertRight, Fail if the given @Either a b@ value is a 'Left'.+             Use this function if @a@ is an instance of 'Show') CreateAssertionsCtxRet(assertRight, Show a, Either a b, IO b)  _assertRightNoShow_ :: String -> Location -> String -> Either a b -> IO b@@ -317,6 +395,7 @@ _assertRightNoShow_ name loc s (Left _) =     assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++                                  ": expected a Right value, given a Left value"))+DocAssertion(assertRightNoShow, Fail if the given @Either a b@ value is a 'Left'.) CreateAssertionsRet(assertRightNoShow, Either a b, IO b)  --@@ -328,6 +407,7 @@ _assertJust_ name loc s Nothing =     assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++                                  ": expected a Just value, given Nothing"))+DocAssertion(assertJust, Fail is the given @Maybe a@ value is a 'Nothing'.) CreateAssertionsRet(assertJust, Maybe a, IO a)  _assertNothing_ :: Show a@@ -336,6 +416,8 @@ _assertNothing_ name loc s jx =     assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++                                  ": expected Nothing, given " ++ show jx))+DocAssertion(assertNothing, Fail is the given @Maybe a@ value is a 'Just'.+             Use this function if @a@ is an instance of 'Show'.) CreateAssertionsCtx(assertNothing, Show a, Maybe a)  _assertNothingNoShow_ :: String -> Location -> String -> Maybe a -> HU.Assertion@@ -343,4 +425,5 @@ _assertNothingNoShow_ name loc s _ =     assertFailure (mkMsg name s ("failed at " ++ showLoc loc ++                                  ": expected Nothing, given a Just value"))+DocAssertion(assertNothingNoShow, Fail is the given @Maybe a@ value is a 'Just'.) CreateAssertions(assertNothingNoShow, Maybe a)

@@ -1,4 +1,4 @@-{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ScopedTypeVariables,CPP #-}  -- This library is free software; you can redistribute it and/or -- modify it under the terms of the GNU Lesser General Public@@ -19,40 +19,51 @@  import Data.Maybe import Data.Char ( isSpace )+import qualified Data.List as List import Control.Exception ( evaluate, catch, SomeException )+#if !MIN_VERSION_base(4,6,0) import Prelude hiding ( catch )+#endif  import qualified Language.Haskell.Exts as Exts 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 qualified Language.Haskell.Exts.Fixity as Fix+import qualified Language.Haskell.Exts.SrcLoc as Src  import Test.Framework.Location+import Test.Framework.Utils  type Name = String  data Decl = Decl { decl_loc :: Location                  , decl_name :: Name } +data Pragma = Pragma { pr_name :: String+                     , pr_args :: String+                     , pr_loc :: Location }+ data ParseResult a = ParseOK a | ParseError Location String  data Module = Module { mod_name :: Name                      , mod_imports :: [ImportDecl]-                     , mod_decls :: [Decl] }+                     , mod_decls :: [Decl]+                     , mod_htfPragmas :: [Pragma] }  data ImportDecl = ImportDecl { imp_moduleName :: Name                              , imp_qualified :: Bool-                             , imp_alias :: Maybe Name }+                             , imp_alias :: Maybe Name+                             , imp_loc :: Location }  parse :: FilePath -> String -> IO (ParseResult Module) parse originalFileName input =-    do r <- (evaluate $ Exts.parseFileContentsWithMode parseMode fixedInput)+    do r <- (evaluate $ Exts.parseFileContentsWithComments 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)+         Parser.ParseOk (m, comments) -> return $ ParseOK (transformModule m comments)     where       -- fixedInput serves two purposes:       -- 1. add a trailing \n@@ -80,22 +91,36 @@                                    }       unknownLoc :: Syn.SrcLoc       unknownLoc = Syn.SrcLoc originalFileName 0 0-      transformModule (Syn.Module _ (Syn.ModuleName moduleName) _ _ _-                          imports decls) =+      transformModule (Syn.Module _ (Syn.ModuleName moduleName) _ _ _ imports decls)+                      comments =           Module moduleName (map transformImport imports)                             (mapMaybe transformDecl decls)+                            (mapMaybe transformComment comments)       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'+          in ImportDecl s qualified alias' (transformLoc loc)       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+      transformSpan span = makeLoc (Src.srcSpanFilename span) (Src.srcSpanStartLine span)       transformLoc (Syn.SrcLoc f n _) = makeLoc f n       transformName :: Syn.Name -> String       transformName (Syn.Ident s) = s       transformName (Syn.Symbol s) = s+      transformComment (Exts.Comment True span ('@':s)) =+          case reverse s of+            '@':r ->+                let stripped = strip (reverse r)+                in if "HTF_" `List.isPrefixOf` stripped+                      then let (name, args) = List.span (not . isSpace) stripped+                               argsStripped = dropWhile isSpace args+                               loc = transformSpan span+                           in Just $ Pragma name argsStripped loc+                      else Nothing+            _ -> Nothing+      transformComment _ = Nothing

@@ -1,5 +1,5 @@ ----- Copyright (c) 2005   Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2005, 2012   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,6 +16,12 @@ -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA -- +{- |++This module defines types and functions dealing with source code locations.++-}+ module Test.Framework.Location (    Location, unknownLocation,@@ -29,13 +35,17 @@  -- | An abstract type representing locations in a file. data Location = Location String Int+                deriving (Eq, Ord) +-- | Render a 'Location' as a 'String'. showLoc :: Location -> String showLoc (Location f n) = f ++ ":" ++ show n +-- | Extract the file name of a 'Location'. fileName :: Location -> String fileName (Location f _ ) = f +-- | Extract the line number of a 'Location'. lineNumber :: Location -> Int lineNumber (Location _ i) = i @@ -45,5 +55,6 @@         -> Location makeLoc = Location +-- | The unknown location (file @?@ and line @0@). unknownLocation :: Location unknownLocation = Location "?" 0

@@ -1,7 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-}  ----- Copyright (c) 2009   Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2009-2012 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,8 +20,9 @@  module Test.Framework.Preprocessor ( transform, progName ) where +import Data.Char ( toLower ) import Data.Maybe ( mapMaybe )-import Data.List ( intercalate )+import qualified Data.List as List import System.IO ( hPutStrLn, stderr ) import Language.Preprocessor.Cpphs ( runCpphs,                                      CpphsOptions(..),@@ -36,9 +37,31 @@ htfModule :: String htfModule = "Test.Framework" -testDeclName :: String-testDeclName = "allHTFTests"+mkName varName fullModuleName =+    "htf_" +++    map (\c -> if c == '.' then '_' else c)+        (fullModuleName ++ "." +++         (case varName of+            'h':'t':'f':'_':s -> s+            s -> s)) +thisModulesTestsFullName :: String -> String+thisModulesTestsFullName = mkName thisModulesTestsName++importedTestListFullName :: String -> String+importedTestListFullName = mkName importedTestListName++thisModulesTestsName :: String+thisModulesTestsName = "htf_thisModulesTests"++importedTestListName :: String+importedTestListName = "htf_importedTests"++nameDefines :: ModuleInfo -> [(String, String)]+nameDefines info =+    [(thisModulesTestsName, thisModulesTestsFullName (mi_moduleName info)),+     (importedTestListName, importedTestListFullName (mi_moduleName info))]+ allAsserts :: [String] allAsserts = ["assertBool"              ,"assertEqual"@@ -52,6 +75,8 @@              ,"assertNotEmpty"              ,"assertThrows"              ,"assertThrowsSome"+             ,"assertThrowsIO"+             ,"assertThrowsSomeIO"              ,"assertLeft"              ,"assertLeftNoShow"              ,"assertRight"@@ -76,33 +101,36 @@ warn s =     hPutStrLn stderr $ progName ++ " warning: " ++ s -data ModuleInfo = ModuleInfo { mi_prefix     :: String+data ModuleInfo = ModuleInfo { mi_htfPrefix  :: String+                             , mi_htfImports :: [ImportDecl]                              , mi_defs       :: [Definition]                              , mi_moduleName :: String }  data Definition = TestDef String Location String                 | PropDef String Location String-                | BenchDef String Location String +data ImportOrPragma = IsImport ImportDecl | IsPragma Pragma+ analyse :: FilePath -> String         -> IO (ParseResult ModuleInfo)-analyse originalFileName s =-    do parseResult <- parse originalFileName s+analyse originalFileName inputString =+    do parseResult <- parse originalFileName inputString        case parseResult of-         ParseOK (Module moduleName imports decls) ->+         ParseOK (Module moduleName imports decls pragmas) ->              do -- putStrLn $ show decls                 let defs = mapMaybe defFromDecl decls+                    htfImports = findHtfImports imports pragmas                 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)+                return $ ParseOK (ModuleInfo htfPrefix htfImports defs moduleName)          ParseError loc err -> return (ParseError loc err)     where       prefixFromImport :: ImportDecl -> Maybe String-      prefixFromImport (ImportDecl s qualified alias)+      prefixFromImport (ImportDecl s qualified alias _)           | s == htfModule =               if qualified                   then case alias of@@ -119,9 +147,21 @@                 Just (TestDef rest loc name)             ('p':'r':'o':'p':'_':rest) | not (null rest) ->                 Just (PropDef rest loc name)-            ('b':'e':'n':'c':'h':'_':rest) | not (null rest) ->-                Just (BenchDef rest loc name)             _ -> Nothing+      findHtfImports allImports allPragmas =+          let importPragmas = filter (\p -> pr_name p == "HTF_TESTS") allPragmas+              importsAndPragmas = List.sortBy cmpByLine (map IsImport allImports +++                                                         map IsPragma importPragmas)+              loop (IsImport imp : IsPragma prag : rest) =+                  if lineNumber (imp_loc imp) == lineNumber (pr_loc prag)+                     then imp : loop rest+                     else loop rest+              loop (_ : rest) = loop rest+              loop [] = []+          in loop importsAndPragmas+      cmpByLine x y = getLine x `compare` getLine y+      getLine (IsImport imp) = (lineNumber (imp_loc imp))+      getLine (IsPragma prag) = (lineNumber (pr_loc prag))  transform :: Bool -> FilePath -> String -> IO String transform hunitBackwardsCompat originalFileName input =@@ -130,7 +170,7 @@          ParseError loc err ->              do warn ("Parsing of " ++ originalFileName ++ " failed at line "                       ++ show (lineNumber loc) ++ ": " ++ err)-                preprocess (ModuleInfo "" [] "UNKNOWN_MODULE")+                preprocess (ModuleInfo "" [] [] "UNKNOWN_MODULE")          ParseOK info ->              preprocess info     where@@ -143,17 +183,19 @@       cpphsOptions info =           defaultCpphsOptions { defines =                                     defines defaultCpphsOptions ++-                                            assertDefines hunitBackwardsCompat-                                                          (mi_prefix info)+                                    assertDefines hunitBackwardsCompat (mi_htfPrefix info) +++                                    nameDefines info                               }       additionalCode :: ModuleInfo -> String       additionalCode info =-          testDeclName ++ " :: " ++ mi_prefix info ++ "TestSuite\n" ++-          testDeclName ++ " = " ++ mi_prefix info ++ "makeTestSuite" +++          thisModulesTestsFullName (mi_moduleName info) ++ " :: " +++            mi_htfPrefix info ++ "TestSuite\n" +++          thisModulesTestsFullName (mi_moduleName info) ++ " = " +++            mi_htfPrefix info ++ "makeTestSuite" ++           " " ++ show (mi_moduleName info) ++-          " [\n    " ++ intercalate ",\n    "-                          (map (codeForDef (mi_prefix info)) (mi_defs info))-          ++ "\n  ]"+          " [\n    " ++ List.intercalate ",\n    "+                          (map (codeForDef (mi_htfPrefix info)) (mi_defs info))+          ++ "\n  ]\n" ++ importedTestListCode info       codeForDef :: String -> Definition -> String       codeForDef pref (TestDef s loc name) =           pref ++ "makeUnitTest " ++ (show s) ++ " " ++ codeForLoc pref loc ++@@ -162,10 +204,23 @@           pref ++ "makeQuickCheckTest " ++ (show s) ++ " " ++           codeForLoc pref loc ++ " (" ++ pref ++ "testableAsAssertion (" ++           pref ++ "asTestableWithQCArgs " ++ name ++ "))"-      codeForDef pref (BenchDef s loc name) =-          pref ++ "makeBenchmarkTest " ++ show s ++ " " ++-          codeForLoc pref loc ++ "(" ++ pref ++ "prepareHtfBenchmark (" ++-          pref ++ "asHtfBenchmark " ++ name ++ "))"       codeForLoc :: String -> Location -> String       codeForLoc pref loc = "(" ++ pref ++ "makeLoc " ++ show (fileName loc) ++                             " " ++ show (lineNumber loc) ++ ")"+      importedTestListCode :: ModuleInfo -> String+      importedTestListCode info =+          let l = mi_htfImports info+          in importedTestListFullName (mi_moduleName info)+               ++ " :: [" ++ mi_htfPrefix info ++ "TestSuite]\n" +++             importedTestListFullName (mi_moduleName info)+               ++ " = [\n    " +++             List.intercalate ",\n     " (map htfTestsInModule l) +++             "\n  ]\n"+      htfTestsInModule :: ImportDecl -> String+      htfTestsInModule imp = qualify imp (thisModulesTestsFullName (imp_moduleName imp))+      qualify :: ImportDecl -> String -> String+      qualify imp name =+          case (imp_qualified imp, imp_alias imp) of+            (False, _) -> name+            (True, Just alias) -> alias ++ "." ++ name+            (True, _) -> imp_moduleName imp ++ "." ++ name

@@ -1,5 +1,15 @@ {-# LANGUAGE FlexibleInstances, TypeSynonymInstances #-} +{- |++This module defines the 'Pretty' type class. The assert functions+from 'Test.Framework.HUnitWrapper' use the pretty-printing functionality+provided by this type class so as to provide nicely formatted+error messages.++Additionally, this module re-exports the standard Haskell pretty-printing module+'Text.PrettyPrint'+-} module Test.Framework.Pretty (    Pretty(..), (<=>),@@ -11,11 +21,16 @@  import Text.PrettyPrint +-- | A type class for pretty-printable things.+-- Minimal complete definition: @pretty@. class Pretty a where+    -- | Pretty-print a single value.     pretty :: a -> Doc+    -- | Pretty-print a list of things.     prettyList :: [a] -> Doc     prettyList l =         char '[' <> vcat (punctuate comma (map pretty l)) <> char ']'+    -- | Pretty-print a single value as a 'String'.     showPretty :: a -> String     showPretty = render . pretty @@ -29,7 +44,7 @@     prettyList s = text s  instance Pretty a => Pretty [a] where-    pretty = prettyList +    pretty = prettyList  instance Pretty Int where     pretty = int@@ -37,6 +52,6 @@ instance Pretty Bool where     pretty = text . show +-- | Utility function for inserting a @=@ between two 'Doc' values. (<=>) :: Doc -> Doc -> Doc d1 <=> d2 = d1 <+> equals <+> d2-

@@ -1,8 +1,8 @@ {-# LANGUAGE FlexibleInstances,OverlappingInstances,ExistentialQuantification,-             DeriveDataTypeable,ScopedTypeVariables #-}+             DeriveDataTypeable,ScopedTypeVariables,CPP #-}  ----- Copyright (c) 2005,2009-2011 Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2005,2009-2012 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@@ -19,20 +19,35 @@ -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA -- -module Test.Framework.QuickCheckWrapper (+{- | -  testableAsAssertion,+This module integrates the 'Test.QuickCheck' library into HTF. It re-exports+all functionality of 'Test.QuickCheck' and defines some additional functions. +-}++module Test.Framework.QuickCheckWrapper (+   module Test.QuickCheck, -  TestableWithQCArgs, WithQCArgs, withQCArgs, asTestableWithQCArgs,-  qcPending+  -- * Arguments for evaluating properties+  defaultArgs, getCurrentArgs, setDefaultArgs,+  withQCArgs, +  -- * Pending properties+  qcPending,++  -- * Internal functions+  testableAsAssertion, asTestableWithQCArgs,+  TestableWithQCArgs, WithQCArgs+ ) where  import qualified Data.Map as Map import Control.Concurrent.MVar+#if !MIN_VERSION_base(4,6,0) import Prelude hiding ( catch )+#endif import Control.Exception ( SomeException, Exception, Handler(..),                            throw, catch, catches, evaluate ) import System.IO@@ -54,14 +69,17 @@ qcState = unsafePerformIO (newMVar (QCState defaultArgs)) {-# NOINLINE qcState #-} +-- | The 'Args' used if not explicitly changed. defaultArgs :: Args defaultArgs = stdArgs { chatty = False } +-- | Change the default 'Args' used to evaluate quick check properties. setDefaultArgs :: Args -> IO () setDefaultArgs args =     do withMVar qcState $ \state -> return (state { qc_args = args })        return () +-- | Retrieve the 'Args' currently used per default when evaluating quick check properties. getCurrentArgs :: IO Args getCurrentArgs =     withMVar qcState $ \state -> return (qc_args state)@@ -71,6 +89,8 @@  instance Exception QCPendingException +-- | Turns a 'Test.QuickCheck' property into an 'Assertion'. This function+-- is used internally in the code generated by @htfpp@, do not use it directly. testableAsAssertion :: (Testable t, WithQCArgs t) => t -> Assertion testableAsAssertion t =     withMVar qcState $ \state ->@@ -121,12 +141,16 @@             _ -> s       trimTrailing = reverse . dropWhile isSpace . reverse +-- | Abstract type for representing quick check properties with custom 'Args'.+--   Used only internally. data TestableWithQCArgs = forall a . Testable a =>                           TestableWithQCArgs (Args -> Args) a  instance Testable TestableWithQCArgs where     property (TestableWithQCArgs _ t) = property t +-- | Type class providing access to the custom 'Args' of a quick check property.+--   Used only internally. class WithQCArgs a where     argsModifier :: a -> (Args -> Args)     original :: a -> Maybe TestableWithQCArgs@@ -139,15 +163,21 @@     argsModifier (TestableWithQCArgs f _) = f     original a = Just a -withQCArgs :: (WithQCArgs a, Testable a) => (Args -> Args) -> a+-- | Run a 'Test.QuickCheck' property with modified quick check arguments 'Args'.+withQCArgs :: (WithQCArgs a, Testable a) => (Args -> Args) -- ^ Modification function for the default 'Args'+           -> a                                            -- ^ Property            -> TestableWithQCArgs withQCArgs = TestableWithQCArgs +-- | Turns a 'Test.QuickCheck' property with custom 'Args' into an 'Assertion'. This function+-- is used internally in the code generated by @htfpp@, do not use it directly. asTestableWithQCArgs :: (WithQCArgs a, Testable a) => a -> TestableWithQCArgs asTestableWithQCArgs a =     case original a of       Just a' -> a'       Nothing -> TestableWithQCArgs id a +-- | Use @qcPending msg prop@ to mark the given quick check property as pending+-- without removing it from the test suite and without deleting or commenting out the property code. qcPending :: Testable t => String -> t -> t qcPending msg _ = throw (QCPendingException msg)

@@ -1,5 +1,5 @@ ----- Copyright (c) 2009-2011   Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2009-2012   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@@ -32,13 +32,11 @@ import System.Posix.Types (Fd) import System.Posix.Env (getEnv) -data TestConfig = TestConfig { tc_quiet :: Bool-                             , tc_benchmarks :: Bool }+data TestConfig = TestConfig { tc_quiet :: Bool }                 deriving (Read,Show,Eq)  defaultTestConfig :: TestConfig-defaultTestConfig = TestConfig { tc_quiet = False-                               , tc_benchmarks = False }+defaultTestConfig = TestConfig { tc_quiet = False }  data ReportLevel = Debug | Info                  deriving (Eq,Ord)

@@ -1,5 +1,5 @@ ----- Copyright (c) 2009-2011   Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2009-2012   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,22 +16,37 @@ -- Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA -- +{- |++This module defines function for running a set of tests. Furthermore,+it provides functionality for organzing tests into a hierarchical+structure. This functionality is mainly used internally in the code+generated by the @hftpp@ pre-processor.+-}+ module Test.Framework.TestManager ( +  -- * Running tests+  htfMain, runTest, runTestWithArgs, runTestWithOptions,++  -- * Options for running tests+  TestOptions(..), defaultTestOptions, parseTestArgs,++  -- * Organzing tests   TestID, Assertion, Test, TestSuite, Filter, FlatTest(..), TestSort(..),   TestableHTF, -  makeQuickCheckTest, makeBenchmarkTest, makeUnitTest, makeBlackBoxTest, makeTestSuite,+  makeQuickCheckTest, makeUnitTest, makeBlackBoxTest, makeTestSuite,   makeAnonTestSuite,   addToTestSuite, testSuiteAsTest, -  parseTestArgs, runTest, runTestWithArgs, runTestWithOptions  ) where  import Control.Monad import Control.Monad.RWS-import System.Exit (ExitCode(..))+import System.Exit (ExitCode(..), exitWith)+import System.Environment (getArgs) import Data.List ( isInfixOf, isPrefixOf, partition ) import Text.PrettyPrint import qualified Data.List as List@@ -52,50 +67,64 @@ import Test.Framework.TestConfig import Test.Framework.Colors +-- | An assertion is just an 'IO' action. type Assertion = IO () +-- | Type for naming tests. type TestID = String +-- | Construct a test where the given 'Assertion' checks a quick check property.+-- See 'Test.Framework.QuickCheckWrapper'.+-- Mainly used internally. makeQuickCheckTest :: TestID -> Location -> Assertion -> Test-makeQuickCheckTest id loc ass = BaseTest QuickCheckTest id (Just loc) (const True) ass+makeQuickCheckTest id loc ass = BaseTest QuickCheckTest id (Just loc) ass +-- | Construct a unit test from the given 'IO' action.+-- See 'Test.Framework.HUnitWrapper'.+-- Mainly used internally. makeUnitTest :: TestID -> Location -> IO a -> Test-makeUnitTest id loc ass = BaseTest UnitTest id (Just loc) (const True) (ass >> return ())--makeBenchmarkTest :: TestID -> Location -> (TestConfig -> Bool, Assertion) -> Test-makeBenchmarkTest id loc x = BaseTest BenchmarkTest id (Just loc) (fst x) (snd x)+makeUnitTest id loc ass = BaseTest UnitTest id (Just loc) (ass >> return ()) +-- | Construct a black box test from the given 'Assertion'.+-- See 'Test.Framework.BlackBoxTest'.+-- Mainly used internally. makeBlackBoxTest :: TestID -> Assertion -> Test-makeBlackBoxTest id ass = BaseTest BlackBoxTest id Nothing (const True) ass+makeBlackBoxTest id ass = BaseTest BlackBoxTest id Nothing ass +-- | Create a named 'TestSuite' from a list of 'Test' values. makeTestSuite :: TestID -> [Test] -> TestSuite makeTestSuite = TestSuite +-- | Create an unnamed 'TestSuite' from a list of 'Test' values. makeAnonTestSuite :: [Test] -> TestSuite makeAnonTestSuite = AnonTestSuite +-- | Turn a 'TestSuite' into a proper 'Test'. testSuiteAsTest :: TestSuite -> Test testSuiteAsTest = CompoundTest +-- | Extend a 'TestSuite' with a list of 'Test' values 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 | BenchmarkTest+-- | Type for distinguishing different sorts of tests.+data TestSort = UnitTest | QuickCheckTest | BlackBoxTest               deriving (Eq,Show,Read) -data Test = BaseTest TestSort TestID (Maybe Location) (TestConfig -> Bool) Assertion+-- | Abstract type for tests.+data Test = BaseTest TestSort TestID (Maybe Location) Assertion           | CompoundTest TestSuite +-- | Abstract type for test suites. data TestSuite = TestSuite TestID [Test]                | AnonTestSuite [Test] -data FlatTest = FlatTest { ft_sort :: TestSort-                         , ft_id :: TestID-                         , ft_loc :: Maybe Location-                         , ft_runnable :: TestConfig -> Bool-                         , ft_action :: Assertion }+-- | Type for flattened tests.+data FlatTest = FlatTest TestSort TestID (Maybe Location) Assertion +-- | A type class for things that can be run as tests.+-- Mainly used internally. class TestableHTF t where     flatten :: t -> [FlatTest] @@ -114,8 +143,8 @@ type Path = Maybe String  flattenTest :: Path -> Test -> [FlatTest]-flattenTest path (BaseTest sort id mloc pred ass) =-    [FlatTest sort (path `concatPath` id) mloc pred ass]+flattenTest path (BaseTest sort id mloc ass) =+    [FlatTest sort (path `concatPath` id) mloc ass] flattenTest path (CompoundTest ts) =     flattenTestSuite path ts @@ -169,7 +198,7 @@        removeFile (hr_newFilePath hr)  runFlatTest :: FlatTest -> TR ()-runFlatTest (FlatTest sort id mloc _ ass) =+runFlatTest (FlatTest sort id mloc ass) =     do let name = id ++ case mloc of                           Nothing -> ""                           Just loc -> " (" ++ showLoc loc ++ ")"@@ -265,20 +294,24 @@ runFlatTests :: [FlatTest] -> TR () runFlatTests = mapM_ runFlatTest -runTest :: TestableHTF t => t -> IO ExitCode+-- | Run something testable using the 'defaultTestOptions'.+runTest :: TestableHTF t => t              -- ^ Testable thing+                         -> IO ExitCode    -- See 'runTestWithOptions' for a specification of the 'ExitCode' result runTest = runTestWithOptions defaultTestOptions  optionDescriptions :: [OptDescr (TestOptions -> TestOptions)] optionDescriptions =-    [ Option ['v'] ["verbose"] (NoArg (\o -> o { opts_quiet = False })) "chatty output"-    , Option ['q'] ["quiet"]   (NoArg (\o -> o { opts_quiet = True })) "only display errors"-    , Option ['n'] ["not"]     (ReqArg (\s o -> o { opts_negated = s : (opts_negated o) })-                                       "TEST_PATTERN") "tests to exclude"-    , Option ['b'] ["benchmarks"] (NoArg (\o -> o { opts_benchmarks = True })) "run benchmarks"-    , Option ['h'] ["help"]    (NoArg (\o -> o { opts_help = True })) "display this message"+    [ Option ['v']     ["verbose"] (NoArg (\o -> o { opts_quiet = False })) "chatty output"+    , Option ['q']     ["quiet"]   (NoArg (\o -> o { opts_quiet = True })) "only display errors"+    , Option ['n']     ["not"]     (ReqArg (\s o -> o { opts_negated = s : (opts_negated o) })+                                           "TEST_PATTERN") "tests to exclude"+    , Option ['h']     ["help"]    (NoArg (\o -> o { opts_help = True })) "display this message"     ] -runTestWithArgs :: TestableHTF t => [String] -> t -> IO ExitCode+-- | Run something testable, parse the 'TestOptions' from the given commandline arguments.+runTestWithArgs :: TestableHTF t => [String]        -- ^ Commandline arguments+                                 -> t               -- ^ Testable thing+                                 -> IO ExitCode     -- ^ See 'runTestWithOptions' for a specification of the 'ExitCode' result runTestWithArgs args t =     case parseTestArgs args of       Left err ->@@ -287,6 +320,23 @@       Right opts ->           runTestWithOptions opts t +{- |++Parse commandline arguments into 'TestOptions'. Here's a synopsis+of the format of the commandline arguments:++> [OPTION ...] TEST_PATTERN ...+>+>   where TEST_PATTERN is a posix regular expression matching+>   the names of the tests to run.+>+>   -v               --verbose           chatty output+>   -q               --quiet             only display errors+>   -n TEST_PATTERN  --not=TEST_PATTERN  tests to exclude+>   -h               --help              display this message++-}+ parseTestArgs :: [String] -> Either String TestOptions parseTestArgs args =     case getOpt Permute optionDescriptions args of@@ -295,7 +345,7 @@               negStrs = opts_negated opts               pos = map mkRegex posStrs               neg = map mkRegex negStrs-              pred (FlatTest _ id _ _ _) =+              pred (FlatTest _ id _ _) =                   if (any (\s -> s `matches` id) neg)                      then False                      else null pos || any (\s -> s `matches` id) pos@@ -309,34 +359,53 @@  usageHeader :: String usageHeader = ("USAGE: COMMAND [OPTION ...] TEST_PATTERN ...\n\n" ++-               "       where TEST_PATTERN is a posix regular expression.\n")+               "  where TEST_PATTERN is a posix regular expression matching\n" +++               "  the names of the tests to run.\n") +-- | A filter is a predicate on 'FlatTest'. If the predicate is 'True', the flat test is run. type Filter = FlatTest -> Bool +-- | Options for running tests. data TestOptions = TestOptions {-      opts_quiet :: Bool-    , opts_filter :: Filter-    , opts_help :: Bool-    , opts_benchmarks :: Bool-    , opts_negated :: [String]+      opts_quiet :: Bool          -- ^ Be quiet or not.+    , opts_filter :: Filter       -- ^ Run only tests matching this filter.+    , opts_help :: Bool           -- ^ If 'True', display a help message and exit.+    , opts_negated :: [String]    -- ^ Regular expressions matching test names which should /not/ run.     } +defaultTestOptions :: TestOptions+{- | The default 'TestOptions':++> TestOptions {+>       opts_quiet = False+>     , opts_filter = const True+>     , opts_help = False+>     , opts_negated = []+> }++-} defaultTestOptions = TestOptions {-      opts_quiet = tc_quiet defaultTestConfig+      opts_quiet = False     , opts_filter = const True     , opts_help = False-    , opts_benchmarks = False     , opts_negated = []     } +-- | Runs something testable with the given 'TestOptions'.+-- The result is 'ExitSuccess' if all tests were executed successfully,+-- 'ExitFailure' otherwise. In the latter case, an error code of @1@ indicates+-- that failures but no errors occurred, otherwise the error code @2@ is used.+--+-- A test is /successful/ if the test terminates and no assertion fails.+-- A test is said to /fail/ if an assertion fails but no other error occur. runTestWithOptions :: TestableHTF t => TestOptions -> t -> IO ExitCode runTestWithOptions opts t =     if opts_help opts        then do hPutStrLn stderr (usageInfo usageHeader optionDescriptions)                return $ ExitFailure 1        else-         do let tc = optsToConfig opts-                pred ft = ft_runnable ft tc && opts_filter opts ft+         do let pred = opts_filter opts+                tc = optsToConfig opts             (_, s, _) <- runRWST (runFlatTests (filter pred (flatten t))) tc initTestState             let passed = length (ts_passed s)                 pending = length (ts_pending s)@@ -368,8 +437,7 @@       renderTestNames l =           nest 2 (vcat (map (\name -> text "*" <+> text name) l))       optsToConfig opts =-          TestConfig { tc_quiet = opts_quiet opts-                     , tc_benchmarks = opts_benchmarks opts }+          TestConfig { tc_quiet = opts_quiet opts }  reportDoc :: TestConfig -> ReportLevel -> Doc -> IO () reportDoc tc level doc = report tc level (render doc)@@ -378,3 +446,12 @@ reportTR level msg =     do tc <- ask        liftIO $ report tc level msg++-- | Runs something testable by parsing the commandline arguments as test options+-- (using 'parseTestArgs'). Exits with the exit code returned by 'runTestWithArgs'.+-- This function is the main entry point for running tests.+htfMain :: TestableHTF t => t -> IO ()+htfMain tests =+    do args <- getArgs+       ecode <- runTestWithArgs args tests+       exitWith ecode

@@ -1,5 +1,5 @@ ----- Copyright (c) 2009-2011   Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2009-2012   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@@ -73,6 +73,7 @@     do assertFailureHTF s        error "unitTestFail: UNREACHABLE" +-- |Mark a unit test as pending without removing it from the test suite. unitTestPending :: String -> IO a unitTestPending s = unitTestFail (makePendingMessage s) 

@@ -1,21 +1,32 @@-{-|+module Test.Framework.Tutorial ( +{- | 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:+We start with a simple example. Then we show how to use HTF to easily+collect test definitions from multiple modules and discuss+backwards-compatibility for projects already using `HUnit`. Finally,+we give a brief cookbook-like summary on how to setup your tests with HTF. +-}++-- * A simple example+{- |++Suppose you are trying to write a function for reversing lists :+ @ myReverse :: [a] -> [a]-myReverse [] = []-myReverse [x] = [x]+myReverse []     = []+myReverse [x]    = [x] myReverse (x:xs) = myReverse xs @ -To test this function using the HTF, you first create a new source+To test this function using the HTF, you would first create a new source file with a @OPTIONS_GHC@ pragma in the first line.  @@@ -29,6 +40,7 @@  @ import System.Environment ( getArgs )+import System.Exit ( exitWith ) import Test.Framework @ @@ -48,11 +60,13 @@ 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. (Backwards-compatibility-with the HUnit library is discussed at the end of this tutorial.)+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'.+or @prop_@ in a test suite of type 'TestSuite' and name @htf_@/M/@_thisModulesTests@,+where /M/ is the name of the current module with dots @.@ replaced by underscores @_@.+For your convenience, the preprocessor also defines the token @htf_thisModulesTests@+as a shorthand for the rather lengthy name @htf_@/M/@_thisModulesTests@.  Definitions starting with @test_@ denote unit tests and must be of type 'Assertion'.@@ -60,13 +74,10 @@ 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.+To run the tests, use the 'htfMain' function.  @-main =-    do args <- getArgs-       runTestWithArgs args allHTFTests+main = htfMain htf_thisModulesTests @  Here is the skeleton of a @.cabal@ file which you may want to use to@@ -75,43 +86,57 @@ @ Name:          HTF-tutorial Version:       0.1-Cabal-Version: >= 1.6+Cabal-Version: >= 1.10 Build-type:    Simple  Executable tutorial-  Main-is: Tutorial.hs-  Build-depends: base >= 4 && < 5, HTF == 0.5.*+  Type:              exitcode-stdio-1.0+  Main-is:           Tutorial.hs+  Build-depends:     base == 4.*, HTF == 0.9.*+  Default-language:  Haskell2010 @  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]+> [TEST] Main:nonEmpty (Tutorial.hs:17)+> assertEqual failed at Tutorial.hs:18+> * expected: [3, 2, 1]+> * but got:  [3]+> * diff:     [3, 2, 1]+> *** Failed! >-> Main:empty (Tutorial.hs:19)+> [TEST] Main:empty (Tutorial.hs:19) > +++ OK >-> Main:reverse (Tutorial.hs:22)-> *** Failed! Falsifiable (after 3 tests and 1 shrink):+> [TEST] Main:reverse (Tutorial.hs:22)+> Falsifiable (after 7 tests and 4 shrinks): > [0,0]-> Replay argument: "Just (847701486 2147483396,2)"+> Replay argument: "Just (1982441876 2147483392,6)"+> *** Failed! > > * Tests:    3 > * Passed:   1+> * Pending:  0 > * Failures: 2 > * Errors:   0+>+> * Failures:+>   * Main:nonEmpty (Tutorial.hs:17)+>   * Main:reverse (Tutorial.hs:22)  (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+information, which is quite convenient. Also, HTF provides a diff between+the expected and the given output. (For this simple example, a diff is kind+of useless, but with longer output strings, a diff allows you to identify+very quickly where the expected and the given results disagree.)++For the QuickCheck property @Main.reverse@, the HTF 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@@ -123,11 +148,11 @@  @ prop_reverseReplay =-  'withQCArgs' (\a -> a { 'replay' = 'read' \"Just (1060394807 2147483396,2)\" })+  'withQCArgs' (\\a -> a { 'replay' = 'read' \"Just (1060394807 2147483396,2)\" })   prop_reverse @ -To finish this tutorial, we now give a correct definition for @myReverse@:+To finish this simple example, we now give a correct definition for @myReverse@:  @ myReverse :: [a] -> [a]@@ -138,28 +163,107 @@ Running our tests again on the fixed definition then yields the desired result: -> Main:nonEmpty (Tutorial.hs:17)+> [TEST] Main:nonEmpty (Tutorial.hs:17) > +++ OK >-> Main:empty (Tutorial.hs:19)+> [TEST] Main:empty (Tutorial.hs:19) > +++ OK >-> Main:reverse (Tutorial.hs:22)-> +++ OK, passed 100 tests.+> [TEST] Main:reverse (Tutorial.hs:22)+> Passed 100 tests.+> +++ OK >-> Main:reverseReplay (Tutorial.hs:24)-> +++ OK, passed 100 tests.+> [TEST] Main:reverseReplay (Tutorial.hs:24)+> Passed 100 tests.+> +++ OK > > * Tests:    4 > * Passed:   4+> * Pending:  0 > * 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.+The HTF also allows the definition of black box tests. Essentially, black box+tests allow you to verify that the output of your program matches your expectations.+See the documentation of the "Test.Framework.BlackBoxTest" module for further information. -/Backwards-compatibility with HUnit/+-} +-- * Test definitions in multiple modules++{- |++For testing real-world programs or libraries, it is often conventient to+split the tests into several modules. For example, suppose your library contains+of two modules @MyPkg.A@ and @MyPkg.B@, each containing test functions.+You can find a slightly extended of this scenario in the samples directory+of the HTF source tree, see <https://github.com/skogsbaer/HTF/tree/master/sample>.)++File @MyPkg/A.hs@++@+&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;+module MyPkg.A (funA, htf_thisModulesTests) where++import Test.Framework++funA :: Int -> Int+funA x = x + 1++test_funA1 = assertEqual (funA 41) 42++test_funA2 = assertEqual (funA 2) 3+@++File @MyPkg/B.hs@++@+&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;+module MyPkg.B (funB, htf_thisModulesTests) where++import Test.Framework++funB :: Int -> Int+funB x = x * 2++test_funB1 = assertEqual (funB 21) 42++test_funB2 = assertEqual (funB 0) 0+@++For module @MyPkg.A@, the @htfpp@ preprocessor collects the modules'+testcases into a variable @htf_MyPkg_A_thisModulesTests@ and defines a+preprocessor token @thisModulesTests@ as a shorthand for this variable.+Thus, to expose all HTF tests defined in @MyPkg.A@, we only+need to put @thisModulesTests@ into the export list. The same holds+analogously for module @MyPkg.B@.++To execute all tests defined in these two modules, you would create+a main module and import @MyPkg.A@ and @MyPkg.B@ with the special+import annotation @&#x7b;-&#x40; HTF_TESTS &#x40;-&#x7d;@. The effect of this annotation+is that the @htfpp@ preprocessor makes all test cases defined in+such modules imported+available in a variable called @htf_importedTests@. Thus, your+main module would look like this:++File @TestMain.hs@++@+&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;+module Main where++import Test.Framework+import &#x7b;-&#x40; HTF_TESTS &#x40;-&#x7d; MyPkg.A+import &#x7b;-&#x40; HTF_TESTS &#x40;-&#x7d; MyPkg.B++main = htfMain htf_importedTests+@++-}++-- * Backwards-compatibility with HUnit++{- | The types of the various @assert@-like macros of the HTF are not backwards-compatible with the corresponding functions of HUnit. This incompatibility is intentional, of course: with HUnit, the programmer has to provide suitable location information by explicitly@@ -173,8 +277,49 @@ @'assertEqualVerbose_' ('makeLoc' \"filename\" line)@, whose type @(Show a, Eq a) => String -> a -> a -> IO ()@ is compatible with the type of HUnit's 'Test.HUnit.Base.assertEqual' function.+ -}-module Test.Framework.Tutorial where++-- * Summary++{- |++Here is a quick summary of how to write, collect, and execute your tests.+You should also have a look at the sample project at+<https://github.com/skogsbaer/HTF/tree/master/sample>.++-}++-- ** Writing tests++{- |++* Place @&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;@ at the top of your module.++* Put @htf_thisModulesTests@ into the export list of your module.++* Import @Test.Framework@.++* Prefix your unit tests with @test_@, see "Test.Framework.HUnitWrapper" for the assertions provided.++* Prefix your QuickCheck properties with @prop_@.++-}++-- ** Collecting and executing tests++{- |+* Place @&#x7b;-&#x23; OPTIONS_GHC -F -pgmF htfpp &#x23;-&#x7d;@ at the top of your module.++* Import @Test.Framework@.++* Import modules defining HTF tests with @import &#x7b;-&#x40; HTF_TESTS &#x40;-&#x7d; MyPkg.A@.++* Use @main = htfMain htf_importedTests@ to run all imported tests.++-}++) where  import Test.Framework import qualified Test.HUnit.Base

@@ -1,6 +1,6 @@ {-# LANGUAGE PatternGuards #-} ----- Copyright (c) 2005   Stefan Wehr - http://www.stefanwehr.de+-- Copyright (c) 2005, 2012   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@@ -127,3 +127,6 @@            '\n':_ -> ""            _ | null s -> ""              | otherwise -> "\n"++strip :: String -> String+strip = reverse . dropWhile isSpace . reverse . dropWhile isSpace