From a0cd89ac3a071b5d9658f24b1a582f7d47834cfe Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Wed, 2 Aug 2023 12:07:30 +0300 Subject: [PATCH 1/2] Add field to Result which allows storage of arbitrary data This feature is need for tasty-bench and tasty-papi which currently sneak data in `resultDescription' and then treat this field specially. But such feature seems generally useful. --- core/Test/Tasty/Core.hs | 21 +++++++++++++++++++++ core/Test/Tasty/Providers.hs | 2 ++ core/Test/Tasty/Run.hs | 2 ++ core/Test/Tasty/Runners.hs | 2 ++ 4 files changed, 27 insertions(+) diff --git a/core/Test/Tasty/Core.hs b/core/Test/Tasty/Core.hs index bd53471d..d54a3e58 100644 --- a/core/Test/Tasty/Core.hs +++ b/core/Test/Tasty/Core.hs @@ -8,6 +8,8 @@ module Test.Tasty.Core , Outcome(..) , Time , Result(..) + , attachExtraData + , lookupExtraData , resultSuccessful , exceptionResult , Progress(..) @@ -33,12 +35,14 @@ module Test.Tasty.Core import Control.Exception import qualified Data.Map as Map import Data.Bifunctor (Bifunctor(second, bimap)) +import Data.Foldable (asum) import Data.List (mapAccumR) import Data.Monoid (Any (getAny, Any)) import Data.Sequence ((|>)) import qualified Data.Sequence as Seq import Data.Tagged import Data.Typeable +import Data.Dynamic import GHC.Generics import Options.Applicative (internal) import Test.Tasty.Options @@ -120,11 +124,27 @@ data Result = Result -- Usually this is set to 'noResultDetails', which does nothing. -- -- @since 1.3.1 + , resultExtraData :: [Dynamic] + -- ^ Any extra data attached to result of test evaluation + -- + -- @since NEXTVERSION } deriving ( Show -- ^ @since 1.2 ) +-- | Lookup values of given type o +-- +-- @since NEXTVERSION +lookupExtraData :: Typeable a => Result -> Maybe a +lookupExtraData = asum . map fromDynamic . resultExtraData + +-- | Attach value of arbitrary type to result of execution +-- +-- @since NEXTVERSION +attachExtraData :: Typeable a => a -> Result -> Result +attachExtraData a r = r { resultExtraData = toDyn a : resultExtraData r } + {- Note [Skipped tests] ~~~~~~~~~~~~~~~~~~~~ There are two potential ways to represent the tests that are skipped @@ -164,6 +184,7 @@ exceptionResult e = Result , resultShortDescription = "FAIL" , resultTime = 0 , resultDetailsPrinter = noResultDetails + , resultExtraData = [] } -- | Test progress information. diff --git a/core/Test/Tasty/Providers.hs b/core/Test/Tasty/Providers.hs index 06916896..db575665 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 = [] } -- | 'Result' of a failed test. @@ -49,6 +50,7 @@ testFailed desc = Result , resultShortDescription = "FAIL" , resultTime = 0 , resultDetailsPrinter = noResultDetails + , resultExtraData = [] } -- | '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..05f9d10d 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 = [] } -- 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 = [] } } 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 From 4a7a879381fd7947d5dfcfa16aac83e7ff8f2172 Mon Sep 17 00:00:00 2001 From: Alexey Khudyakov Date: Mon, 21 Aug 2023 21:15:00 +0300 Subject: [PATCH 2/2] Use SomeExtraData in order to be able to carry more dictionaries This change is to carry mode type class dictionaries and to allow to define more possible instances for Result. --- core/Test/Tasty/Core.hs | 29 +++++++++++++++++++++-------- core/Test/Tasty/Providers.hs | 4 ++-- core/Test/Tasty/Run.hs | 4 ++-- 3 files changed, 25 insertions(+), 12 deletions(-) diff --git a/core/Test/Tasty/Core.hs b/core/Test/Tasty/Core.hs index d54a3e58..7d685cb0 100644 --- a/core/Test/Tasty/Core.hs +++ b/core/Test/Tasty/Core.hs @@ -3,11 +3,15 @@ {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE ScopedTypeVariables #-} module Test.Tasty.Core ( FailureReason(..) , Outcome(..) , Time , Result(..) + , SomeExtraData(..) , attachExtraData , lookupExtraData , resultSuccessful @@ -35,14 +39,12 @@ module Test.Tasty.Core import Control.Exception import qualified Data.Map as Map import Data.Bifunctor (Bifunctor(second, bimap)) -import Data.Foldable (asum) import Data.List (mapAccumR) import Data.Monoid (Any (getAny, Any)) import Data.Sequence ((|>)) import qualified Data.Sequence as Seq import Data.Tagged import Data.Typeable -import Data.Dynamic import GHC.Generics import Options.Applicative (internal) import Test.Tasty.Options @@ -124,7 +126,7 @@ data Result = Result -- Usually this is set to 'noResultDetails', which does nothing. -- -- @since 1.3.1 - , resultExtraData :: [Dynamic] + , resultExtraData :: Map.Map TypeRep SomeExtraData -- ^ Any extra data attached to result of test evaluation -- -- @since NEXTVERSION @@ -133,17 +135,28 @@ data Result = Result ( 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 :: Typeable a => Result -> Maybe a -lookupExtraData = asum . map fromDynamic . resultExtraData +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 => a -> Result -> Result -attachExtraData a r = r { resultExtraData = toDyn a : resultExtraData r } +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] ~~~~~~~~~~~~~~~~~~~~ @@ -184,7 +197,7 @@ exceptionResult e = Result , resultShortDescription = "FAIL" , resultTime = 0 , resultDetailsPrinter = noResultDetails - , resultExtraData = [] + , resultExtraData = mempty } -- | Test progress information. diff --git a/core/Test/Tasty/Providers.hs b/core/Test/Tasty/Providers.hs index db575665..8927d7e7 100644 --- a/core/Test/Tasty/Providers.hs +++ b/core/Test/Tasty/Providers.hs @@ -35,7 +35,7 @@ testPassed desc = Result , resultShortDescription = "OK" , resultTime = 0 , resultDetailsPrinter = noResultDetails - , resultExtraData = [] + , resultExtraData = mempty } -- | 'Result' of a failed test. @@ -50,7 +50,7 @@ testFailed desc = Result , resultShortDescription = "FAIL" , resultTime = 0 , resultDetailsPrinter = noResultDetails - , resultExtraData = [] + , 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 05f9d10d..d0713b27 100644 --- a/core/Test/Tasty/Run.hs +++ b/core/Test/Tasty/Run.hs @@ -194,7 +194,7 @@ executeTest action statusVar timeoutOpt hideProgressOpt inits fins = mask $ \res , resultShortDescription = "TIMEOUT" , resultTime = fromIntegral t , resultDetailsPrinter = noResultDetails - , resultExtraData = [] + , resultExtraData = mempty } -- If compiled with unbounded-delays then t' :: Integer, otherwise t' :: Int let t' = fromInteger (min (max 0 t) (toInteger (maxBound :: Int64))) @@ -491,7 +491,7 @@ resolveDeps tests = maybeCheckCycles $ do , resultShortDescription = "SKIP" , resultTime = 0 , resultDetailsPrinter = noResultDetails - , resultExtraData = [] + , resultExtraData = mempty } } return (TestAction { testAction = action, .. }, (testPath, dep_paths))