diff --git a/HTF.cabal b/HTF.cabal --- a/HTF.cabal +++ b/HTF.cabal @@ -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 diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -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 - - diff --git a/Test/Framework/CriterionWrapper.hs b/Test/Framework/CriterionWrapper.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/CriterionWrapper.hs @@ -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 } diff --git a/Test/Framework/Preprocessor.hs b/Test/Framework/Preprocessor.hs --- a/Test/Framework/Preprocessor.hs +++ b/Test/Framework/Preprocessor.hs @@ -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) ++ ")" diff --git a/Test/Framework/TestConfig.hs b/Test/Framework/TestConfig.hs --- a/Test/Framework/TestConfig.hs +++ b/Test/Framework/TestConfig.hs @@ -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) diff --git a/Test/Framework/TestManager.hs b/Test/Framework/TestManager.hs --- a/Test/Framework/TestManager.hs +++ b/Test/Framework/TestManager.hs @@ -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)