HTF 0.8.2.1 → 0.8.2.2

raw patch · 6 files changed

+207/−34 lines, 6 filesdep +criteriondep ~QuickCheckdep ~bytestringdep ~directorynew-uploaderPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: criterion

Dependency ranges changed: QuickCheck, bytestring, directory, haskell-src-exts, mtl, unix

API changes (from Hackage documentation)

Files

• HTF.cabal +11/−9
• Test/Framework.hs +4/−4
• Test/Framework/CriterionWrapper.hs +151/−0
• Test/Framework/Preprocessor.hs +7/−0
• Test/Framework/TestConfig.hs +4/−2
• Test/Framework/TestManager.hs +30/−19

@@ -1,5 +1,5 @@ Name:             HTF-Version:          0.8.2.1+Version:          0.8.2.2 License:          LGPL License-File:     LICENSE Copyright:        (c) 2005-2011 Stefan Wehr@@ -24,7 +24,7 @@     The documentation of the "Test.Framework.Tutorial" module     provides a tutorial for the HTF. -Tested-With:      GHC==6.10.4, GHC==6.12, GHC==7.0, GHC==7.4.1+Tested-With:      GHC==6.10.4, GHC==6.12, GHC==7.0 Build-Type:       Simple Cabal-Version:    >= 1.6 Extra-Source-Files:@@ -39,7 +39,7 @@ Executable htfpp   Main-Is:          HTFPP.hs   Build-Depends:    cpphs >= 1.12,-                    haskell-src-exts == 1.11.*,+                    haskell-src-exts >= 1.11 && < 1.14,                     base == 4.*   Other-Modules:     Test.Framework.Preprocessor@@ -47,22 +47,24 @@  Library   Build-Depends:    HUnit == 1.2.*,-                    QuickCheck >= 2.5 && < 2.6,+                    QuickCheck >= 2.3 && < 2.6,                     base == 4.*,                     random == 1.0.*,                     containers >= 0.3 && < 0.6,                     process >= 1.0 && < 1.2,-                    directory >= 1.0 && < 1.2,-                    mtl >= 1.1 && < 2.1,+                    directory >= 1.0 && < 1.3,+                    mtl >= 1.1 && < 2.2,                     pretty >= 1.0 && < 1.2,                     Diff >= 0.1.3 && < 0.2,-                    unix >= 2.4 && < 2.6,-                    bytestring == 0.9.*,+                    unix >= 2.4 && < 2.7,+                    bytestring >= 0.9 && < 0.11,                     regex-compat >= 0.92 && < 0.96,-                    haskell-src-exts == 1.11.*+                    haskell-src-exts >= 1.11 && < 1.14,+                    criterion >= 0.5 && < 0.7   Exposed-Modules:     Test.Framework     Test.Framework.HUnitWrapper+    Test.Framework.CriterionWrapper     Test.Framework.TestManager     Test.Framework.TestConfig     Test.Framework.QuickCheckWrapper

@@ -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,6 +22,7 @@    module Test.Framework.HUnitWrapper,   module Test.Framework.QuickCheckWrapper,+  module Test.Framework.CriterionWrapper,   module Test.Framework.BlackBoxTest,   module Test.Framework.TestManager, @@ -31,8 +32,7 @@  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--          

@@ -0,0 +1,151 @@+{-# 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 }

@@ -82,6 +82,7 @@  data Definition = TestDef String Location String                 | PropDef String Location String+                | BenchDef String Location String  analyse :: FilePath -> String         -> IO (ParseResult ModuleInfo)@@ -118,6 +119,8 @@                 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  transform :: Bool -> FilePath -> String -> IO String@@ -159,6 +162,10 @@           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) ++ ")"

@@ -32,11 +32,13 @@ import System.Posix.Types (Fd) import System.Posix.Env (getEnv) -data TestConfig = TestConfig { tc_quiet :: Bool }+data TestConfig = TestConfig { tc_quiet :: Bool+                             , tc_benchmarks :: Bool }                 deriving (Read,Show,Eq)  defaultTestConfig :: TestConfig-defaultTestConfig = TestConfig { tc_quiet = False }+defaultTestConfig = TestConfig { tc_quiet = False+                               , tc_benchmarks = False }  data ReportLevel = Debug | Info                  deriving (Eq,Ord)

@@ -21,7 +21,7 @@   TestID, Assertion, Test, TestSuite, Filter, FlatTest(..), TestSort(..),   TestableHTF, -  makeQuickCheckTest, makeUnitTest, makeBlackBoxTest, makeTestSuite,+  makeQuickCheckTest, makeBenchmarkTest, makeUnitTest, makeBlackBoxTest, makeTestSuite,   makeAnonTestSuite,   addToTestSuite, testSuiteAsTest, @@ -57,13 +57,16 @@ type TestID = String  makeQuickCheckTest :: TestID -> Location -> Assertion -> Test-makeQuickCheckTest id loc ass = BaseTest QuickCheckTest id (Just loc) ass+makeQuickCheckTest id loc ass = BaseTest QuickCheckTest id (Just loc) (const True) ass  makeUnitTest :: TestID -> Location -> IO a -> Test-makeUnitTest id loc ass = BaseTest UnitTest id (Just loc) (ass >> return ())+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)+ makeBlackBoxTest :: TestID -> Assertion -> Test-makeBlackBoxTest id ass = BaseTest BlackBoxTest id Nothing ass+makeBlackBoxTest id ass = BaseTest BlackBoxTest id Nothing (const True) ass  makeTestSuite :: TestID -> [Test] -> TestSuite makeTestSuite = TestSuite@@ -78,16 +81,20 @@ addToTestSuite (TestSuite id ts) ts' = TestSuite id (ts ++ ts') addToTestSuite (AnonTestSuite ts) ts' = AnonTestSuite (ts ++ ts') -data TestSort = UnitTest | QuickCheckTest | BlackBoxTest+data TestSort = UnitTest | QuickCheckTest | BlackBoxTest | BenchmarkTest               deriving (Eq,Show,Read) -data Test = BaseTest TestSort TestID (Maybe Location) Assertion+data Test = BaseTest TestSort TestID (Maybe Location) (TestConfig -> Bool) Assertion           | CompoundTest TestSuite  data TestSuite = TestSuite TestID [Test]                | AnonTestSuite [Test] -data FlatTest = FlatTest TestSort TestID (Maybe Location) Assertion+data FlatTest = FlatTest { ft_sort :: TestSort+                         , ft_id :: TestID+                         , ft_loc :: Maybe Location+                         , ft_runnable :: TestConfig -> Bool+                         , ft_action :: Assertion }  class TestableHTF t where     flatten :: t -> [FlatTest]@@ -107,8 +114,8 @@ type Path = Maybe String  flattenTest :: Path -> Test -> [FlatTest]-flattenTest path (BaseTest sort id mloc ass) =-    [FlatTest sort (path `concatPath` id) mloc ass]+flattenTest path (BaseTest sort id mloc pred ass) =+    [FlatTest sort (path `concatPath` id) mloc pred ass] flattenTest path (CompoundTest ts) =     flattenTestSuite path ts @@ -162,7 +169,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 ++ ")"@@ -263,11 +270,12 @@  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 ['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 ['b'] ["benchmarks"] (NoArg (\o -> o { opts_benchmarks = True })) "run benchmarks"+    , Option ['h'] ["help"]    (NoArg (\o -> o { opts_help = True })) "display this message"     ]  runTestWithArgs :: TestableHTF t => [String] -> t -> IO ExitCode@@ -287,7 +295,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,6 +317,7 @@       opts_quiet :: Bool     , opts_filter :: Filter     , opts_help :: Bool+    , opts_benchmarks :: Bool     , opts_negated :: [String]     } @@ -316,6 +325,7 @@       opts_quiet = tc_quiet defaultTestConfig     , opts_filter = const True     , opts_help = False+    , opts_benchmarks = False     , opts_negated = []     } @@ -325,8 +335,8 @@        then do hPutStrLn stderr (usageInfo usageHeader optionDescriptions)                return $ ExitFailure 1        else-         do let pred = opts_filter opts-                tc = optsToConfig opts+         do let tc = optsToConfig opts+                pred ft = ft_runnable ft tc && opts_filter opts ft             (_, s, _) <- runRWST (runFlatTests (filter pred (flatten t))) tc initTestState             let passed = length (ts_passed s)                 pending = length (ts_pending s)@@ -358,7 +368,8 @@       renderTestNames l =           nest 2 (vcat (map (\name -> text "*" <+> text name) l))       optsToConfig opts =-          TestConfig { tc_quiet = opts_quiet opts }+          TestConfig { tc_quiet = opts_quiet opts+                     , tc_benchmarks = opts_benchmarks opts }  reportDoc :: TestConfig -> ReportLevel -> Doc -> IO () reportDoc tc level doc = report tc level (render doc)