HTF 0.11.2.1 → 0.11.3.0
raw patch · 9 files changed
+445/−251 lines, 9 filesdep ~basesetup-changed
Dependency ranges changed: base
Files
- HTF.cabal +2/−1
- Setup.hs +3/−0
- Test/Framework.hs +4/−0
- Test/Framework/AssertM.hs +86/−0
- Test/Framework/HUnitWrapper.hs +210/−136
- Test/Framework/Preprocessor.hs +40/−28
- Test/Framework/QuickCheckWrapper.hs +66/−74
- tests/TestHTF.hs +31/−12
- tests/run-tests.sh +3/−0
HTF.cabal view
@@ -1,5 +1,5 @@ Name: HTF-Version: 0.11.2.1+Version: 0.11.3.0 License: LGPL License-File: LICENSE Copyright: (c) 2005-2012 Stefan Wehr@@ -187,6 +187,7 @@ Test.Framework.JsonOutput Test.Framework.XmlOutput Test.Framework.ThreadPool+ Test.Framework.AssertM Other-Modules: Test.Framework.TestManagerInternal Test.Framework.Utils
Setup.hs view
@@ -1,2 +1,5 @@+#!/usr/bin/runhaskell+ import Distribution.Simple+ main = defaultMain
Test/Framework.hs view
@@ -33,6 +33,9 @@ -- * Quickcheck module Test.Framework.QuickCheckWrapper, TM.makeQuickCheckTest, + -- * Generic assertions+ module Test.Framework.AssertM,+ -- * Organizing tests TM.makeTestSuite, TM.TestSuite, TM.htfMain, Loc.makeLoc @@ -40,5 +43,6 @@ import Test.Framework.HUnitWrapper import Test.Framework.QuickCheckWrapper+import Test.Framework.AssertM import qualified Test.Framework.TestManager as TM import qualified Test.Framework.Location as Loc
+ Test/Framework/AssertM.hs view
@@ -0,0 +1,86 @@+{-|++This module defines the 'AssertM' monad, which allows you either to run assertions+as ordinary unit tests or to evaluate them as pure functions.++-}+module Test.Framework.AssertM (++ AssertM(..), AssertStackElem(..), AssertBool(..), boolValue, eitherValue, formatStack++) where++import Data.Maybe+import qualified Data.Text as T++import Test.Framework.TestManagerInternal+import Test.Framework.Location+import Test.Framework.Colors++-- | A typeclass for generic assertions.+class Monad m => AssertM m where+ genericAssertFailure__ :: Location -> ColorString -> m a+ genericSubAssert :: Location -> Maybe String -> m a -> m a++instance AssertM IO where+ genericAssertFailure__ loc s = unitTestFail (Just loc) s+ genericSubAssert loc mMsg action = unitTestSubAssert loc mMsg action++-- | Stack trace element for generic assertions.+data AssertStackElem+ = AssertStackElem+ { ase_message :: Maybe String+ , ase_location :: Maybe Location+ }+ deriving (Eq, Ord, Show, Read)++-- | Type for evaluating a generic assertion as a pure function.+data AssertBool a+ -- | Assertion passes successfully and yields the given value.+ = AssertOk a+ -- | Assertion fails with the given stack trace. In the stack trace, the outermost stackframe comes first.+ | AssertFailed [AssertStackElem]+ deriving (Eq, Ord, Show, Read)++instance Monad AssertBool where+ return = AssertOk+ AssertFailed stack >>= _ = AssertFailed stack+ AssertOk x >>= k = k x+ fail msg = AssertFailed [AssertStackElem (Just msg) Nothing]++instance AssertM AssertBool where+ genericAssertFailure__ loc s =+ AssertFailed [AssertStackElem (Just (T.unpack $ renderColorString s False)) (Just loc)]++ genericSubAssert loc mMsg action =+ case action of+ AssertOk x -> AssertOk x+ AssertFailed stack ->+ AssertFailed (AssertStackElem mMsg (Just loc) : stack)++-- | Evaluates a generic assertion to a 'Bool' value.+boolValue :: AssertBool a -> Bool+boolValue x =+ case x of+ AssertOk _ -> True+ AssertFailed _ -> False++-- | Evaluates a generic assertion to an 'Either' value. The result+-- is @Right x@ if the assertion passes and yields value @x@, otherwise+-- the result is @Left err@, where @err@ is an error message.+eitherValue :: AssertBool a -> Either String a+eitherValue x =+ case x of+ AssertOk z -> Right z+ AssertFailed stack -> Left (formatStack stack)++-- | Formats a stack trace.+formatStack :: [AssertStackElem] -> String+formatStack stack =+ unlines $ map formatStackElem $ zip [0..] $ reverse stack+ where+ formatStackElem (pos, AssertStackElem mMsg mLoc) =+ let floc = fromMaybe "<unknown location>" $ fmap showLoc mLoc+ fmsg = fromMaybe "" $ fmap (\s -> ": " ++ s) mMsg+ pref = if pos > 0 then " called from " else ""+ in pref ++ floc ++ fmsg
Test/Framework/HUnitWrapper.hs view
@@ -2,6 +2,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE BangPatterns #-} -- -- Copyright (c) 2005, 2009, 2012 Stefan Wehr - http://www.stefanwehr.de@@ -41,19 +42,31 @@ -- * Assertions on Bool values assertBool_, assertBoolVerbose_,+ gassertBool_, gassertBoolVerbose_, -- * Equality assertions assertEqual_, assertEqualVerbose_,+ gassertEqual_, gassertEqualVerbose_, assertEqualPretty_, assertEqualPrettyVerbose_,+ gassertEqualPretty_, gassertEqualPrettyVerbose_, assertEqualNoShow_, assertEqualNoShowVerbose_,+ gassertEqualNoShow_, gassertEqualNoShowVerbose_, assertNotEqual_, assertNotEqualVerbose_,+ gassertNotEqual_, gassertNotEqualVerbose_, assertNotEqualPretty_, assertNotEqualPrettyVerbose_,+ gassertNotEqualPretty_, gassertNotEqualPrettyVerbose_, assertNotEqualNoShow_, assertNotEqualNoShowVerbose_,+ gassertNotEqualNoShow_, gassertNotEqualNoShowVerbose_, -- * Assertions on lists assertListsEqualAsSets_, assertListsEqualAsSetsVerbose_,+ gassertListsEqualAsSets_, gassertListsEqualAsSetsVerbose_, assertNotEmpty_, assertNotEmptyVerbose_,+ gassertNotEmpty_, gassertNotEmptyVerbose_, assertEmpty_, assertEmptyVerbose_,+ gassertEmpty_, gassertEmptyVerbose_,+ assertElem_, assertElemVerbose_,+ gassertElem_, gassertElemVerbose_, -- * Assertions for exceptions assertThrows_, assertThrowsVerbose_,@@ -65,53 +78,65 @@ -- * Assertions on Either values assertLeft_, assertLeftVerbose_,+ gassertLeft_, gassertLeftVerbose_, assertLeftNoShow_, assertLeftNoShowVerbose_,+ gassertLeftNoShow_, gassertLeftNoShowVerbose_, assertRight_, assertRightVerbose_,+ gassertRight_, gassertRightVerbose_, assertRightNoShow_, assertRightNoShowVerbose_,+ gassertRightNoShow_, gassertRightNoShowVerbose_, -- * Assertions on Just values assertJust_, assertJustVerbose_,+ gassertJust_, gassertJustVerbose_, assertNothing_, assertNothingVerbose_,+ gassertNothing_, gassertNothingVerbose_, assertNothingNoShow_, assertNothingNoShowVerbose_,+ gassertNothingNoShow_, gassertNothingNoShowVerbose_, -- * General failure assertFailure_,+ gassertFailure_, -- * Pending unit tests unitTestPending, unitTestPending', -- * Sub assertions- subAssert_, subAssertVerbose_+ subAssert_, subAssertVerbose_,+ gsubAssert_, gsubAssertVerbose_+ ) where import Control.Exception import qualified Control.Exception.Lifted as ExL import Control.Monad.Trans.Control import Control.Monad.Trans-import qualified Test.HUnit as HU hiding ( assertFailure ) import qualified Language.Haskell.Exts.Pretty as HE import qualified Language.Haskell.Exts.Parser as HE import Data.List ( (\\) )+import System.IO.Unsafe (unsafePerformIO) import Test.Framework.TestManagerInternal import Test.Framework.Location import Test.Framework.Diff import Test.Framework.Colors import Test.Framework.Pretty+import Test.Framework.AssertM -- WARNING: do not forget to add a preprocessor macro for new assertions!! -assertFailure__ :: Location -> ColorString -> IO a-assertFailure__ loc s = unitTestFail (Just loc) s- {- | Fail with the given reason, supplying the error location and the error message. -}+gassertFailure_ :: AssertM m => Location -> String -> m a+gassertFailure_ loc s =+ genericAssertFailure__ loc (mkMsg "assertFailure" ""+ ("failed at " ++ showLoc loc ++ ": " ++ s))++-- | Specialization of 'gassertFailure'. assertFailure_ :: Location -> String -> IO a-assertFailure_ loc s =- assertFailure__ loc (mkMsg "assertFailure" ""- ("failed at " ++ showLoc loc ++ ": " ++ s))+assertFailure_ = gassertFailure_ {- | Use @unitTestPending' msg test@ to mark the given test as pending@@ -133,38 +158,63 @@ -- -- Dirty macro hackery (I'm too lazy ...) ---#define CreateAssertionsGeneric(__name__, __ctx__, __type__, __ret__) \+#define CreateAssertionsGenericNoGVariant(__name__, __ctx__, __type__, __ret__) \ __name__##Verbose_ :: __ctx__ Location -> String -> __type__ -> __ret__; \ __name__##Verbose_ = _##__name__##_ (#__name__ ++ "Verbose"); \ __name__##_ :: __ctx__ Location -> __type__ -> __ret__; \ __name__##_ loc = _##__name__##_ #__name__ loc ""+#define CreateAssertionsGeneric(__name__, __ctx__, __ctx2__, __type__, __ret__) \+g##__name__##Verbose_ :: __ctx2__ Location -> String -> __type__ -> m __ret__; \+g##__name__##Verbose_ = _##__name__##_ (#__name__ ++ "Verbose"); \+g##__name__##_ :: __ctx2__ Location -> __type__ -> m __ret__; \+g##__name__##_ loc = _##__name__##_ #__name__ loc ""; \+CreateAssertionsGenericNoGVariant(__name__, __ctx__, __type__, IO __ret__) -#define CreateAssertionsCtx(__name__, __ctx__, __type__) \-CreateAssertionsGeneric(__name__, __ctx__ =>, __type__, HU.Assertion)+#define CreateAssertionsCtx(__name__, __ctx__, __ctx2__, __type__) \+CreateAssertionsGeneric(__name__, __ctx__ =>, __ctx2__ =>, __type__, ())+#define CreateAssertionsCtxNoGVariant(__name__, __ctx__, __type__) \+CreateAssertionsGenericNoGVariant(__name__, __ctx__ =>, __type__, IO ()) #define CreateAssertions(__name__, __type__) \-CreateAssertionsGeneric(__name__, , __type__, HU.Assertion)+CreateAssertionsGeneric(__name__, , AssertM m =>, __type__, ())+#define CreateAssertionsNoGVariant(__name__, __type__) \+CreateAssertionsGenericNoGVariant(__name__, , __type__, IO ()) -#define CreateAssertionsCtxRet(__name__, __ctx__, __type__, __ret__) \-CreateAssertionsGeneric(__name__, __ctx__ =>, __type__, __ret__)+#define CreateAssertionsCtxRet(__name__, __ctx__, __ctx2__, __type__, __ret__) \+CreateAssertionsGeneric(__name__, __ctx__ =>, __ctx2__ =>, __type__, __ret__)+#define CreateAssertionsCtxRetNoGVariant(__name__, __ctx__, __type__, __ret__) \+CreateAssertionsGenericNoGVariant(__name__, __ctx__ =>, __type__, IO __ret__) #define CreateAssertionsRet(__name__, __type__, __ret__) \-CreateAssertionsGeneric(__name__, , __type__, __ret__)+CreateAssertionsGeneric(__name__, , AssertM m =>, __type__, __ret__)+#define CreateAssertionsRetNoGVariant(__name__, __type__, __ret__) \+CreateAssertionsGenericNoGVariant(__name__, , __type__, IO __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, \+ variants can be used to provide extra information about the error. The \+ variants @g##__name__@ and @g##__name__##Verbose@ are generic assertions: \+ they run in the IO monad and can be evaluated to a 'Bool' value. \+ Do not use the \+ @__name__##_@, @__name__##Verbose_@, @g##__name__##_@, and @g##__name__##Verbose_@ \+ functions directly, use the macros @__name__@, @__name__##Verbose@, @g##__name__@, and \+ @g##__name__##Verbose@ instead. These macros, provided by the @htfpp@ preprocessor, \ insert the 'Location' parameter automatically. -}-+#define DocAssertionNoGVariant(__name__, __text__) \+ {- | __text__ The 'String' parameter in the @Verbose@ \+ variant can be used to provide extra information about the error. \+ Do not use the \+ @__name__##_@ and @__name__##Verbose_@ \+ functions 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_ :: AssertM m => String -> Location -> String -> Bool -> m () _assertBool_ name loc s False =- assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))+ genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc)) _assertBool_ _ _ _ True = return () DocAssertion(assertBool, Fail if the 'Bool' value is 'False'.)@@ -174,18 +224,18 @@ -- Equality Assertions -- -equalityFailedMessage :: String -> String -> IO ColorString+equalityFailedMessage :: String -> String -> ColorString equalityFailedMessage exp act =- do d <- diffWithSensibleConfig expP actP- let expected_ = colorize firstDiffColor "* expected:"- let but_got_ = colorize secondDiffColor "* but got:"- let diff_ = colorize diffColor "* diff:"- return ("\n" +++ expected_ +++ " " +++ noColor (withNewline expP) +++- "\n" +++ but_got_ +++ " " +++ noColor (withNewline actP) +++- "\n" +++ diff_ +++ " " +++ newlineBeforeDiff d +++ d +++- (if stringEq- then "\nWARNING: strings are equal but actual values differ!"- else ""))+ let !diff = unsafePerformIO (diffWithSensibleConfig expP actP)+ expected_ = colorize firstDiffColor "* expected:"+ but_got_ = colorize secondDiffColor "* but got:"+ diff_ = colorize diffColor "* diff:"+ in ("\n" +++ expected_ +++ " " +++ noColor (withNewline expP) ++++ "\n" +++ but_got_ +++ " " +++ noColor (withNewline actP) ++++ "\n" +++ diff_ +++ " " +++ newlineBeforeDiff diff +++ diff ++++ (if stringEq+ then "\nWARNING: strings are equal but actual values differ!"+ else "")) where withNewline s = case lines s of@@ -212,150 +262,161 @@ HE.ParseOk x -> Just $ HE.prettyPrint x HE.ParseFailed{} -> Nothing -notEqualityFailedMessage :: String -> IO String+notEqualityFailedMessage :: String -> String notEqualityFailedMessage exp =- do return (": Objects are equal\n" ++ pp exp)+ (": Objects are equal\n" ++ pp exp) where pp s = case HE.parseExp s of HE.ParseOk x -> HE.prettyPrint x HE.ParseFailed{} -> s -_assertEqual_ :: (Eq a, Show a)- => String -> Location -> String -> a -> a -> HU.Assertion+_assertEqual_ :: (Eq a, Show a, AssertM m)+ => String -> Location -> String -> a -> a -> m () _assertEqual_ name loc s expected actual = if expected /= actual- then do x <- equalityFailedMessage (show expected) (show actual)- assertFailure__ loc (mkColorMsg name s $- noColor ("failed at " ++ showLoc loc) +++ x)+ then do let x = equalityFailedMessage (show expected) (show actual)+ genericAssertFailure__ loc (mkColorMsg name s $+ noColor ("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)+CreateAssertionsCtx(assertEqual, (Eq a, Show a), (Eq a, Show a, AssertM m), a -> a) -_assertNotEqual_ :: (Eq a, Show a)- => String -> Location -> String -> a -> a -> HU.Assertion+_assertNotEqual_ :: (Eq a, Show a, AssertM m)+ => String -> Location -> String -> a -> a -> m () _assertNotEqual_ name loc s expected actual = if expected == actual- then do x <- notEqualityFailedMessage (show expected)- assertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x)+ then do let x = notEqualityFailedMessage (show expected)+ genericAssertFailure__ loc (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)+CreateAssertionsCtx(assertNotEqual, (Eq a, Show a), (Eq a, Show a, AssertM m), a -> a) -_assertEqualPretty_ :: (Eq a, Pretty a)- => String -> Location -> String -> a -> a -> HU.Assertion+_assertEqualPretty_ :: (Eq a, Pretty a, AssertM m)+ => String -> Location -> String -> a -> a -> m () _assertEqualPretty_ name loc s expected actual = if expected /= actual- then do x <- equalityFailedMessage (showPretty expected) (showPretty actual)- assertFailure__ loc (mkColorMsg name s- (noColor ("failed at " ++ showLoc loc) +++ x))+ then do let x = equalityFailedMessage (showPretty expected) (showPretty actual)+ genericAssertFailure__ loc (mkColorMsg name s+ (noColor ("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)+CreateAssertionsCtx(assertEqualPretty, (Eq a, Pretty a), (Eq a, Pretty a, AssertM m), a -> a) -_assertNotEqualPretty_ :: (Eq a, Pretty a)- => String -> Location -> String -> a -> a -> HU.Assertion+_assertNotEqualPretty_ :: (Eq a, Pretty a, AssertM m)+ => String -> Location -> String -> a -> a -> m () _assertNotEqualPretty_ name loc s expected actual = if expected == actual- then do x <- notEqualityFailedMessage (showPretty expected)- assertFailure__ loc (mkMsg name s $ "failed at " ++ showLoc loc ++ x)+ then do let x = notEqualityFailedMessage (showPretty expected)+ genericAssertFailure__ loc (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)+CreateAssertionsCtx(assertNotEqualPretty, (Eq a, Pretty a), (Eq a, Pretty a, AssertM m), a -> a) -_assertEqualNoShow_ :: Eq a- => String -> Location -> String -> a -> a -> HU.Assertion+_assertEqualNoShow_ :: (Eq a, AssertM m)+ => String -> Location -> String -> a -> a -> m () _assertEqualNoShow_ name loc s expected actual = if expected /= actual- then assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))- else return ()+ then genericAssertFailure__ loc (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)+CreateAssertionsCtx(assertEqualNoShow, Eq a, (Eq a, AssertM m), a -> a) -_assertNotEqualNoShow_ :: Eq a- => String -> Location -> String -> a -> a -> HU.Assertion+_assertNotEqualNoShow_ :: (Eq a, AssertM m)+ => String -> Location -> String -> a -> a -> m () _assertNotEqualNoShow_ name loc s expected actual = if expected == actual- then assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))+ then genericAssertFailure__ loc (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)+CreateAssertionsCtx(assertNotEqualNoShow, Eq a, (Eq a, AssertM m), a -> a) -- -- Assertions on Lists -- -_assertListsEqualAsSets_ :: (Eq a, Show a)- => String -> Location -> String -> [a] -> [a] -> HU.Assertion+_assertListsEqualAsSets_ :: (Eq a, Show a, AssertM m)+ => String -> Location -> String -> [a] -> [a] -> m () _assertListsEqualAsSets_ name loc s expected actual = let ne = length expected na = length actual in case () of _| ne /= na ->- assertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc- ++ "\n expected length: " ++ show ne- ++ "\n actual length: " ++ show na))+ genericAssertFailure__ loc (mkMsg name s+ ("failed at " ++ showLoc loc+ ++ "\n expected length: " ++ show ne+ ++ "\n actual length: " ++ show na)) | not (unorderedEq expected actual) ->- do x <- equalityFailedMessage (show expected) (show actual)- assertFailure__ loc (mkColorMsg "assertSetEqual" s- (noColor ("failed at " ++ showLoc loc) +++ x))+ do let x = equalityFailedMessage (show expected) (show actual)+ genericAssertFailure__ loc (mkColorMsg "assertSetEqual" s+ (noColor ("failed at " ++ showLoc loc) +++ x)) | 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])+CreateAssertionsCtx(assertListsEqualAsSets, (Eq a, Show a), (Eq a, Show a, AssertM m), [a] -> [a]) -_assertNotEmpty_ :: String -> Location -> String -> [a] -> HU.Assertion+_assertNotEmpty_ :: AssertM m => String -> Location -> String -> [a] -> m () _assertNotEmpty_ name loc s [] =- assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))+ genericAssertFailure__ loc (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_ :: AssertM m => String -> Location -> String -> [a] -> m () _assertEmpty_ name loc s (_:_) =- assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc))+ genericAssertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc)) _assertEmpty_ _ _ _ [] = return () DocAssertion(assertEmpty, Fail if the given list is a non-empty list.) CreateAssertions(assertEmpty, [a]) +_assertElem_ :: (Eq a, Show a, AssertM m) => String -> Location -> String -> a -> [a] -> m ()+_assertElem_ name loc s x l =+ if x `elem` l+ then return ()+ else genericAssertFailure__ loc (mkMsg name s+ ("failed at " ++ showLoc loc +++ "\n element: " ++ show x +++ "\n list: " ++ show l))+DocAssertion(assertElem, Fail if the given element is not in the list.)+CreateAssertionsCtx(assertElem, (Eq a, Show a), (Eq a, Show a, AssertM m), a -> [a])+ -- -- Assertions for Exceptions -- _assertThrowsIO_ :: Exception e- => String -> Location -> String -> IO a -> (e -> Bool) -> HU.Assertion+ => String -> Location -> String -> IO a -> (e -> Bool) -> IO () _assertThrowsIO_ name loc s x f = _assertThrowsM_ name loc s x f-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))+DocAssertionNoGVariant(assertThrowsIO, Fail if executing the 'IO' action does not+ throw an exception satisfying the given predicate @(e -> Bool)@.)+CreateAssertionsCtxNoGVariant(assertThrowsIO, Exception e, IO a -> (e -> Bool)) -_assertThrowsSomeIO_ :: String -> Location -> String -> IO a -> HU.Assertion+_assertThrowsSomeIO_ :: String -> Location -> String -> IO a -> IO () _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)+DocAssertionNoGVariant(assertThrowsSomeIO, Fail if executing the 'IO' action does not+ throw an exception.)+CreateAssertionsNoGVariant(assertThrowsSomeIO, IO a) _assertThrowsM_ :: (MonadBaseControl IO m, MonadIO m, Exception e) => String -> Location -> String -> m a -> (e -> Bool) -> m ()@@ -363,111 +424,117 @@ do res <- ExL.try x case res of Right _ -> liftIO $- assertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": no exception was thrown"))+ genericAssertFailure__ loc (mkMsg name s+ ("failed at " ++ showLoc loc +++ ": no exception was thrown")) Left e -> if f e then return () else liftIO $- assertFailure__ loc (mkMsg name s- ("failed at " ++- showLoc loc ++- ": wrong exception was thrown: " ++- show e))-DocAssertion(assertThrowsM, Fail if executing the 'm' action does not- throw an exception satisfying the given predicate @(e -> Bool)@.)-CreateAssertionsGeneric(assertThrowsM, (MonadBaseControl IO m, MonadIO m, Exception e) =>,- m a -> (e -> Bool), m ())+ genericAssertFailure__ loc (mkMsg name s+ ("failed at " +++ showLoc loc +++ ": wrong exception was thrown: " +++ show e))+DocAssertionNoGVariant(assertThrowsM, Fail if executing the 'm' action does not+ throw an exception satisfying the given predicate @(e -> Bool)@.)+CreateAssertionsGenericNoGVariant(assertThrowsM, (MonadBaseControl IO m, MonadIO m, Exception e) =>,+ m a -> (e -> Bool), m ()) _assertThrowsSomeM_ :: (MonadBaseControl IO m, MonadIO m) => String -> Location -> String -> m a -> m () _assertThrowsSomeM_ name loc s x = _assertThrowsM_ name loc s x (\ (_e::SomeException) -> True)-DocAssertion(assertThrowsSomeM, Fail if executing the 'm' action does not- throw an exception.)-CreateAssertionsGeneric(assertThrowsSomeM, (MonadBaseControl IO m, MonadIO m) =>, m a, m ())+DocAssertionNoGVariant(assertThrowsSomeM, Fail if executing the 'm' action does not+ throw an exception.)+CreateAssertionsGenericNoGVariant(assertThrowsSomeM, (MonadBaseControl IO m, MonadIO m) =>, m a, m ()) _assertThrows_ :: Exception e- => String -> Location -> String -> a -> (e -> Bool) -> HU.Assertion+ => String -> Location -> String -> a -> (e -> Bool) -> IO () _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))+DocAssertionNoGVariant(assertThrows, Fail if evaluating the expression of type @a@ does not+ throw an exception satisfying the given predicate @(e -> Bool)@.)+CreateAssertionsCtxNoGVariant(assertThrows, Exception e, a -> (e -> Bool)) -_assertThrowsSome_ :: String -> Location -> String -> a -> HU.Assertion+_assertThrowsSome_ :: String -> Location -> String -> a -> IO () _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)+DocAssertionNoGVariant(assertThrowsSome, Fail if evaluating the expression of type @a@ does not+ throw an exception.)+CreateAssertionsNoGVariant(assertThrowsSome, IO a) -- -- Assertions on Either -- -_assertLeft_ :: forall a b . Show b- => String -> Location -> String -> Either a b -> IO a+_assertLeft_ :: forall a b m . (AssertM m, Show b)+ => String -> Location -> String -> Either a b -> m a _assertLeft_ _ _ _ (Left x) = return x _assertLeft_ name loc s (Right x) =- assertFailure__ loc (mkMsg name s- ("failed at " ++ showLoc loc ++- ": expected a Left value, given " ++- show (Right x :: Either b b)))+ genericAssertFailure__ loc (mkMsg name s+ ("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)+CreateAssertionsCtxRet(assertLeft, Show b, (Show b, AssertM m), Either a b, a) -_assertLeftNoShow_ :: String -> Location -> String -> Either a b -> IO a+_assertLeftNoShow_ :: AssertM m => String -> Location -> String -> Either a b -> m a _assertLeftNoShow_ _ _ _ (Left x) = return x _assertLeftNoShow_ name loc s (Right _) =- assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc +++ genericAssertFailure__ loc (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)+CreateAssertionsRet(assertLeftNoShow, Either a b, a) -_assertRight_ :: forall a b . Show a- => String -> Location -> String -> Either a b -> IO b+_assertRight_ :: forall a b m . (Show a, AssertM m)+ => String -> Location -> String -> Either a b -> m b _assertRight_ _ _ _ (Right x) = return x _assertRight_ name loc s (Left x) =- assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc +++ genericAssertFailure__ loc (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)+CreateAssertionsCtxRet(assertRight, Show a, (Show a, AssertM m), Either a b, b) -_assertRightNoShow_ :: String -> Location -> String -> Either a b -> IO b+_assertRightNoShow_ :: AssertM m => String -> Location -> String -> Either a b -> m b _assertRightNoShow_ _ _ _ (Right x) = return x _assertRightNoShow_ name loc s (Left _) =- assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc +++ genericAssertFailure__ loc (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)+CreateAssertionsRet(assertRightNoShow, Either a b, b) -- -- Assertions on Maybe -- -_assertJust_ :: String -> Location -> String -> Maybe a -> IO a+_assertJust_ :: AssertM m => String -> Location -> String -> Maybe a -> m a _assertJust_ _ _ _ (Just x) = return x _assertJust_ name loc s Nothing =- assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc +++ genericAssertFailure__ loc (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)+CreateAssertionsRet(assertJust, Maybe a, a) -_assertNothing_ :: Show a- => String -> Location -> String -> Maybe a -> HU.Assertion+_assertNothing_ :: (Show a, AssertM m)+ => String -> Location -> String -> Maybe a -> m () _assertNothing_ _ _ _ Nothing = return () _assertNothing_ name loc s jx =- assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc +++ genericAssertFailure__ loc (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)+CreateAssertionsCtx(assertNothing, Show a, (Show a, AssertM m), Maybe a) -_assertNothingNoShow_ :: String -> Location -> String -> Maybe a -> HU.Assertion+_assertNothingNoShow_ :: AssertM m => String -> Location -> String -> Maybe a -> m () _assertNothingNoShow_ _ _ _ Nothing = return () _assertNothingNoShow_ name loc s _ =- assertFailure__ loc (mkMsg name s ("failed at " ++ showLoc loc +++ genericAssertFailure__ loc (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)@@ -493,7 +560,14 @@ subAssert_ :: MonadBaseControl IO m => Location -> m a -> m a subAssert_ loc ass = unitTestSubAssert loc Nothing ass +-- | Generic variant of 'subAssert_'.+gsubAssert_ :: AssertM m => Location -> m a -> m a+gsubAssert_ loc ass = genericSubAssert loc Nothing ass -- | Same as 'subAssert_' but with an additional error message. subAssertVerbose_ :: MonadBaseControl IO m => Location -> String -> m a -> m a subAssertVerbose_ loc msg ass = unitTestSubAssert loc (Just msg) ass++-- | Generic variant of 'subAssertVerbose_'.+gsubAssertVerbose_ :: AssertM m => Location -> String -> m a -> m a+gsubAssertVerbose_ loc msg ass = genericSubAssert loc (Just msg) ass
Test/Framework/Preprocessor.hs view
@@ -21,6 +21,7 @@ module Test.Framework.Preprocessor ( transform, progName ) where +import Control.Monad import qualified Data.Text as T import Data.Char ( toLower, isSpace, isDigit ) import Data.Maybe ( mapMaybe )@@ -34,6 +35,9 @@ import Test.Framework.HaskellParser import Test.Framework.Location +_DEBUG_ :: Bool+_DEBUG_ = False+ progName :: String progName = "htfpp" @@ -66,31 +70,36 @@ (importedTestListName, importedTestListFullName (mi_moduleName info))] allAsserts :: [String]-allAsserts = ["assertBool"- ,"assertEqual"- ,"assertEqualPretty"- ,"assertEqualNoShow"- ,"assertNotEqual"- ,"assertNotEqualPretty"- ,"assertNotEqualNoShow"- ,"assertListsEqualAsSets"- ,"assertEmpty"- ,"assertNotEmpty"- ,"assertThrows"- ,"assertThrowsSome"- ,"assertThrowsIO"- ,"assertThrowsSomeIO"- ,"assertThrowsM"- ,"assertThrowsSomeM"- ,"assertLeft"- ,"assertLeftNoShow"- ,"assertRight"- ,"assertRightNoShow"- ,"assertJust"- ,"assertNothing"- ,"assertNothingNoShow"- ,"subAssert"- ]+allAsserts =+ withGs ["assertBool"+ ,"assertEqual"+ ,"assertEqualPretty"+ ,"assertEqualNoShow"+ ,"assertNotEqual"+ ,"assertNotEqualPretty"+ ,"assertNotEqualNoShow"+ ,"assertListsEqualAsSets"+ ,"assertElem"+ ,"assertEmpty"+ ,"assertNotEmpty"+ ,"assertLeft"+ ,"assertLeftNoShow"+ ,"assertRight"+ ,"assertRightNoShow"+ ,"assertJust"+ ,"assertNothing"+ ,"assertNothingNoShow"+ ,"subAssert"+ ,"subAssertVerbose"+ ] ++ ["assertThrows"+ ,"assertThrowsSome"+ ,"assertThrowsIO"+ ,"assertThrowsSomeIO"+ ,"assertThrowsM"+ ,"assertThrowsSomeM"]+ where+ withGs l =+ concatMap (\s -> [s, 'g':s]) l assertDefines :: Bool -> String -> [(String, String)] assertDefines hunitBackwardsCompat prefix =@@ -107,6 +116,10 @@ warn s = hPutStrLn stderr $ progName ++ " warning: " ++ s +note :: String -> IO ()+note s =+ when _DEBUG_ $ hPutStrLn stderr $ progName ++ " note: " ++ s+ data ModuleInfo = ModuleInfo { mi_htfPrefix :: String , mi_htfImports :: [ImportDecl] , mi_defs :: [Definition]@@ -233,7 +246,7 @@ case analyseResult of ParseError loc err -> do poorInfo <- poorMensAnalyse originalFileName input- warn ("Parsing of " ++ originalFileName ++ " failed at line "+ note ("Parsing of " ++ originalFileName ++ " failed at line " ++ show (lineNumber loc) ++ ": " ++ err ++ "\nFalling back to poor man's parser. This parser may " ++ "return incomplete results. The result returned was: " ++@@ -286,8 +299,7 @@ " " ++ name codeForDef pref (PropDef s loc name) = locPragma loc ++ pref ++ "makeQuickCheckTest " ++ (show s) ++ " " ++- codeForLoc pref loc ++ " (" ++ pref ++ "testableAsAssertion (" ++- pref ++ "asTestableWithQCArgs " ++ name ++ "))"+ codeForLoc pref loc ++ " (" ++ pref ++ "qcAssertion " ++ name ++ ")" locPragma :: Location -> String locPragma loc = "{-# LINE " ++ show (lineNumber loc) ++ " " ++ show (fileName loc) ++ " #-}\n "
Test/Framework/QuickCheckWrapper.hs view
@@ -1,5 +1,5 @@-{-# LANGUAGE FlexibleInstances,OverlappingInstances,ExistentialQuantification,- DeriveDataTypeable,ScopedTypeVariables,CPP #-}+{-# LANGUAGE FlexibleInstances,OverlappingInstances,UndecidableInstances,+ ExistentialQuantification,DeriveDataTypeable,ScopedTypeVariables,CPP #-} -- -- Copyright (c) 2005,2009-2012 Stefan Wehr - http://www.stefanwehr.de@@ -32,14 +32,13 @@ -- * Arguments for evaluating properties defaultArgs, getCurrentArgs, setDefaultArgs,- withQCArgs,+ withQCArgs, WithQCArgs, -- * Pending properties qcPending, -- * Internal functions- testableAsAssertion, asTestableWithQCArgs,- TestableWithQCArgs, WithQCArgs+ qcAssertion ) where @@ -52,17 +51,17 @@ import Data.Char import qualified Data.List as List import System.IO.Unsafe (unsafePerformIO)-import Control.Concurrent.MVar+import Data.IORef import Test.QuickCheck import Test.Framework.TestManager import Test.Framework.TestManagerInternal -data QCState = QCState { qc_args :: Args }+data QCState = QCState { qc_args :: !Args } -qcState :: MVar QCState-qcState = unsafePerformIO (newMVar (QCState defaultArgs))+qcState :: IORef QCState+qcState = unsafePerformIO (newIORef (QCState defaultArgs)) {-# NOINLINE qcState #-} -- | The 'Args' used if not explicitly changed.@@ -72,13 +71,13 @@ -- | 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 ()+ atomicModifyIORef' qcState $ \state -> (state { qc_args = args }, ()) -- | Retrieve the 'Args' currently used per default when evaluating quick check properties. getCurrentArgs :: IO Args getCurrentArgs =- withMVar qcState $ \state -> return (qc_args state)+ do state <- readIORef qcState+ return (qc_args state) data QCPendingException = QCPendingException String deriving (Show,Read,Eq,Typeable)@@ -87,45 +86,46 @@ -- | 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 ->- do eitherArgs <-- (let a = (argsModifier t) (qc_args state)- in do _ <- evaluate (length (show a))- return (Right a))- `catch`- (\e -> return $ Left (show (e :: SomeException)))- case eitherArgs of- Left err -> quickCheckTestError- (Just ("Cannot evaluate custom arguments: "- ++ err))- Right args ->- do res <- do t' <- evaluate t- x <- quickCheckWithResult args t'- return (Right x)- `catches`- [Handler $ \(QCPendingException msg) -> return $ Left (True, msg)- ,Handler $ \(e::SomeException) -> return $ Left (False, show (e::SomeException))]- case res of- Left (isPending, err) ->- if isPending- then quickCheckTestPending err- else quickCheckTestError (Just err)- Right (Success { output=msg }) ->- quickCheckTestPass (adjustOutput msg)- Right (Failure { usedSize=size, usedSeed=gen, output=msg, reason=reason }) ->- if pendingPrefix `List.isPrefixOf` reason- then let pendingMsg = let s = drop (length pendingPrefix) reason- in take (length s - length pendingSuffix) s- in quickCheckTestPending pendingMsg- else do let replay = "Replay argument: " ++ (show (show (Just (gen, size))))- quickCheckTestFail (Just (adjustOutput msg ++ "\n" ++ replay))- Right (GaveUp { output=msg }) ->- quickCheckTestFail (Just (adjustOutput msg))- Right (NoExpectedFailure { output=msg }) ->- quickCheckTestFail (Just (adjustOutput msg))- return ()+qcAssertion :: (QCAssertion t) => t -> Assertion+qcAssertion qc =+ do origArgs <- getCurrentArgs+ eitherArgs <-+ (let a = (argsModifier qc) origArgs+ in do _ <- evaluate (length (show a))+ return (Right a))+ `catch`+ (\e -> return $ Left (show (e :: SomeException)))+ case eitherArgs of+ Left err -> quickCheckTestError+ (Just ("Cannot evaluate custom arguments: "+ ++ err))+ Right args ->+ do res <- do anyTestable <- evaluate (testable qc)+ x <- case anyTestable of+ AnyTestable t' -> quickCheckWithResult args t'+ return (Right x)+ `catches`+ [Handler $ \(QCPendingException msg) -> return $ Left (True, msg)+ ,Handler $ \(e::SomeException) -> return $ Left (False, show (e::SomeException))]+ case res of+ Left (isPending, err) ->+ if isPending+ then quickCheckTestPending err+ else quickCheckTestError (Just err)+ Right (Success { output=msg }) ->+ quickCheckTestPass (adjustOutput msg)+ Right (Failure { usedSize=size, usedSeed=gen, output=msg, reason=reason }) ->+ if pendingPrefix `List.isPrefixOf` reason+ then let pendingMsg = let s = drop (length pendingPrefix) reason+ in take (length s - length pendingSuffix) s+ in quickCheckTestPending pendingMsg+ else do let replay = "Replay argument: " ++ (show (show (Just (gen, size))))+ quickCheckTestFail (Just (adjustOutput msg ++ "\n" ++ replay))+ Right (GaveUp { output=msg }) ->+ quickCheckTestFail (Just (adjustOutput msg))+ Right (NoExpectedFailure { output=msg }) ->+ quickCheckTestFail (Just (adjustOutput msg))+ return () where pendingPrefix = "Exception: 'QCPendingException \"" pendingSuffix = "\"'"@@ -139,39 +139,31 @@ -- | Abstract type for representing quick check properties with custom 'Args'. -- Used only internally.-data TestableWithQCArgs = forall a . Testable a =>- TestableWithQCArgs (Args -> Args) a+data WithQCArgs a = WithQCArgs (Args -> Args) a -instance Testable TestableWithQCArgs where- property (TestableWithQCArgs _ t) = property t+-- | Existential holding a 'Testable' value.+-- Used only internally.+data AnyTestable = forall a . Testable a => AnyTestable a -- | Type class providing access to the custom 'Args' of a quick check property. -- Used only internally.-class WithQCArgs a where+class QCAssertion a where argsModifier :: a -> (Args -> Args)- original :: a -> Maybe TestableWithQCArgs+ testable :: a -> AnyTestable -instance WithQCArgs a where+instance Testable a => QCAssertion a where argsModifier _ = id- original _ = Nothing+ testable = AnyTestable -instance WithQCArgs TestableWithQCArgs where- argsModifier (TestableWithQCArgs f _) = f- original a = Just a+instance Testable a => QCAssertion (WithQCArgs a) where+ argsModifier (WithQCArgs f _) = f+ testable (WithQCArgs _ x) = AnyTestable x -- | 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+withQCArgs :: (Testable a) => (Args -> Args) -- ^ Modification function for the default 'Args'+ -> a -- ^ Property+ -> WithQCArgs a+withQCArgs = WithQCArgs -- | 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.
tests/TestHTF.hs view
@@ -20,6 +20,7 @@ -- 02111-1307, USA. -- import Test.Framework+import Test.Framework.Location import Test.Framework.TestManager import Test.Framework.BlackBoxTest @@ -77,6 +78,8 @@ test_assertEmpty = assertEmpty [1] +test_assertElem = assertElem 1 [0,2,3]+ test_assertThrows = assertThrows (return () :: IO ()) (handleExc True) test_assertThrows' = assertThrows (error "ERROR") (handleExc False)@@ -135,37 +138,53 @@ where prop xs = xs == (reverse xs) where types = xs::[Int] -prop_error' :: TestableWithQCArgs+prop_error' :: WithQCArgs Bool prop_error' = withQCArgs changeArgs $ (error "Lisa" :: Bool) +test_genericAssertions =+ case test1 of+ AssertOk _ -> fail "did not expect AssertOk"+ AssertFailed stack ->+ do assertEqual 2 (length stack)+ let [se1, se2] = stack+ assertNothing (ase_message se1)+ loc1 <- assertJust (ase_location se1)+ _ <- assertJust (ase_message se2)+ loc2 <- assertJust (ase_location se2)+ assertEqual (fileName loc1) (fileName loc2)+ assertEqual (lineNumber loc1 + 1) (lineNumber loc2)+ where+ test1 = gsubAssert test2+ test2 = gassertEqual 1 (2::Int)+ checkOutput output = do bsl <- BSL.readFile output let jsons = map (fromJust . J.decode) (splitJson bsl) check jsons (J.object ["type" .= J.String "test-results"])- (J.object ["failures" .= J.toJSON (30::Int)- ,"passed" .= J.toJSON (12::Int)+ (J.object ["failures" .= J.toJSON (31::Int)+ ,"passed" .= J.toJSON (13::Int) ,"pending" .= J.toJSON (2::Int) ,"errors" .= J.toJSON (1::Int)]) check jsons (J.object ["type" .= J.String "test-end" ,"test" .= J.object ["flatName" .= J.String "Main:diff"]])- (J.object ["test" .= J.object ["location" .= J.object ["file" .= J.String "TestHTF.hs$"- ,"line" .= J.toJSON (103::Int)]]- ,"location" .= J.object ["file" .= J.String "TestHTF.hs$"- ,"line" .= J.toJSON (104::Int)]])+ (J.object ["test" .= J.object ["location" .= J.object ["file" .= J.String "TestHTF.hs"+ ,"line" .= J.toJSON (106::Int)]]+ ,"location" .= J.object ["file" .= J.String "TestHTF.hs"+ ,"line" .= J.toJSON (107::Int)]]) check jsons (J.object ["type" .= J.String "test-end" ,"test" .= J.object ["flatName" .= J.String "Foo.A:a"]])- (J.object ["test" .= J.object ["location" .= J.object ["file" .= J.String "Foo/A.hs$"+ (J.object ["test" .= J.object ["location" .= J.object ["file" .= J.String "Foo/A.hs" ,"line" .= J.toJSON (10::Int)]] ,"location" .= J.object ["file" .= J.String "./Foo/A.hs" ,"line" .= J.toJSON (11::Int)]]) check jsons (J.object ["type" .= J.String "test-end" ,"test" .= J.object ["flatName" .= J.String "Main:subAssert"]]) (J.object ["callers" .= J.toJSON [J.object ["message" .= J.Null- ,"location" .= J.object ["file" .= J.String "TestHTF.hs$"- ,"line" .= J.toJSON (92::Int)]]+ ,"location" .= J.object ["file" .= J.String "TestHTF.hs"+ ,"line" .= J.toJSON (95::Int)]] ,J.object ["message" .= J.String "I'm another sub"- ,"location" .= J.object ["file" .= J.String "TestHTF.hs$"- ,"line" .= J.toJSON (94::Int)]]]])+ ,"location" .= J.object ["file" .= J.String "TestHTF.hs"+ ,"line" .= J.toJSON (97::Int)]]]]) where check jsons pred assert = case filter (\j -> matches j pred) jsons of
tests/run-tests.sh view
@@ -5,6 +5,9 @@ cabal clean || exit 1 fi mkdir -p dist/build/htfpp || exit 1+pushd ..+cabal build || exit 1+popd cp ../dist/build/htfpp/htfpp dist/build/htfpp || exit 1 cabal-1.16.0 configure || exit 1 cabal-1.16.0 build || exit 1