diff --git a/core/Test/Tasty/Core.hs b/core/Test/Tasty/Core.hs index bd53471d..7d685cb0 100644 --- a/core/Test/Tasty/Core.hs +++ b/core/Test/Tasty/Core.hs @@ -3,11 +3,17 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} module Test.Tasty.Core ( FailureReason(..) , Outcome(..) , Time , Result(..) + , SomeExtraData(..) + , attachExtraData + , lookupExtraData , resultSuccessful , exceptionResult , Progress(..) @@ -120,11 +126,38 @@ data Result = Result -- Usually this is set to 'noResultDetails', which does nothing. -- -- @since 1.3.1 + , resultExtraData :: Map.Map TypeRep SomeExtraData + -- ^ Any extra data attached to result of test evaluation + -- + -- @since NEXTVERSION } deriving ( Show -- ^ @since 1.2 ) +-- | @Dynamic@-like wrapper for data of arbitrary type but it carries +-- additional type class dictionaries. +data SomeExtraData where + SomeExtraData :: (Typeable a, Show a, Read a, Eq a) => a -> SomeExtraData + +deriving instance Show SomeExtraData + + +-- | Lookup values of given type o +-- +-- @since NEXTVERSION +lookupExtraData :: forall a. Typeable a => Result -> Maybe a +lookupExtraData r = do + SomeExtraData a <- typeOf (undefined :: a) `Map.lookup` resultExtraData r + cast a + +-- | Attach value of arbitrary type to result of execution +-- +-- @since NEXTVERSION +attachExtraData :: (Typeable a, Show a, Read a, Eq a) => a -> Result -> Result +attachExtraData a r = + r { resultExtraData = Map.insert (typeOf a) (SomeExtraData a) (resultExtraData r) } + {- Note [Skipped tests] ~~~~~~~~~~~~~~~~~~~~ There are two potential ways to represent the tests that are skipped @@ -164,6 +197,7 @@ exceptionResult e = Result , resultShortDescription = "FAIL" , resultTime = 0 , resultDetailsPrinter = noResultDetails + , resultExtraData = mempty } -- | Test progress information. diff --git a/core/Test/Tasty/Providers.hs b/core/Test/Tasty/Providers.hs index 06916896..8927d7e7 100644 --- a/core/Test/Tasty/Providers.hs +++ b/core/Test/Tasty/Providers.hs @@ -35,6 +35,7 @@ testPassed desc = Result , resultShortDescription = "OK" , resultTime = 0 , resultDetailsPrinter = noResultDetails + , resultExtraData = mempty } -- | 'Result' of a failed test. @@ -49,6 +50,7 @@ testFailed desc = Result , resultShortDescription = "FAIL" , resultTime = 0 , resultDetailsPrinter = noResultDetails + , resultExtraData = mempty } -- | 'Result' of a failed test with custom details printer diff --git a/core/Test/Tasty/Run.hs b/core/Test/Tasty/Run.hs index 17aa7102..d0713b27 100644 --- a/core/Test/Tasty/Run.hs +++ b/core/Test/Tasty/Run.hs @@ -194,6 +194,7 @@ executeTest action statusVar timeoutOpt hideProgressOpt inits fins = mask $ \res , resultShortDescription = "TIMEOUT" , resultTime = fromIntegral t , resultDetailsPrinter = noResultDetails + , resultExtraData = mempty } -- If compiled with unbounded-delays then t' :: Integer, otherwise t' :: Int let t' = fromInteger (min (max 0 t) (toInteger (maxBound :: Int64))) @@ -490,6 +491,7 @@ resolveDeps tests = maybeCheckCycles $ do , resultShortDescription = "SKIP" , resultTime = 0 , resultDetailsPrinter = noResultDetails + , resultExtraData = mempty } } return (TestAction { testAction = action, .. }, (testPath, dep_paths)) diff --git a/core/Test/Tasty/Runners.hs b/core/Test/Tasty/Runners.hs index 87937bf2..80a4024c 100644 --- a/core/Test/Tasty/Runners.hs +++ b/core/Test/Tasty/Runners.hs @@ -35,6 +35,8 @@ module Test.Tasty.Runners -- * Running tests , Status(..) , Result(..) + , attachExtraData + , lookupExtraData , Outcome(..) , FailureReason(..) , resultSuccessful