diff --git a/HTF.cabal b/HTF.cabal --- a/HTF.cabal +++ b/HTF.cabal @@ -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 diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,5 @@ +#!/usr/bin/runhaskell + import Distribution.Simple + main = defaultMain diff --git a/Test/Framework.hs b/Test/Framework.hs --- a/Test/Framework.hs +++ b/Test/Framework.hs @@ -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 diff --git a/Test/Framework/AssertM.hs b/Test/Framework/AssertM.hs new file mode 100644 --- /dev/null +++ b/Test/Framework/AssertM.hs @@ -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 "" $ fmap showLoc mLoc + fmsg = fromMaybe "" $ fmap (\s -> ": " ++ s) mMsg + pref = if pos > 0 then " called from " else "" + in pref ++ floc ++ fmsg diff --git a/Test/Framework/HUnitWrapper.hs b/Test/Framework/HUnitWrapper.hs --- a/Test/Framework/HUnitWrapper.hs +++ b/Test/Framework/HUnitWrapper.hs @@ -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 diff --git a/Test/Framework/Preprocessor.hs b/Test/Framework/Preprocessor.hs --- a/Test/Framework/Preprocessor.hs +++ b/Test/Framework/Preprocessor.hs @@ -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 " diff --git a/Test/Framework/QuickCheckWrapper.hs b/Test/Framework/QuickCheckWrapper.hs --- a/Test/Framework/QuickCheckWrapper.hs +++ b/Test/Framework/QuickCheckWrapper.hs @@ -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. diff --git a/tests/TestHTF.hs b/tests/TestHTF.hs --- a/tests/TestHTF.hs +++ b/tests/TestHTF.hs @@ -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 diff --git a/tests/run-tests.sh b/tests/run-tests.sh --- a/tests/run-tests.sh +++ b/tests/run-tests.sh @@ -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