{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts,
ExistentialQuantification, RankNTypes, DeriveDataTypeable, NoMonomorphismRestriction,
DeriveGeneric #-}
module Test.Tasty.Core where
import Control.Exception
import Test.Tasty.Providers.ConsoleFormat
import Test.Tasty.Options
import Test.Tasty.Patterns
import Test.Tasty.Patterns.Types
import Data.Foldable
import qualified Data.Sequence as Seq
import Data.Monoid
import Data.Typeable
import qualified Data.Map as Map
import Data.Tagged
import GHC.Generics
import Prelude
import Text.Printf
data FailureReason
= TestFailed
| TestThrewException SomeException
| TestTimedOut Integer
| TestDepFailed
deriving Int -> FailureReason -> ShowS
[FailureReason] -> ShowS
FailureReason -> String
(Int -> FailureReason -> ShowS)
-> (FailureReason -> String)
-> ([FailureReason] -> ShowS)
-> Show FailureReason
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FailureReason] -> ShowS
$cshowList :: [FailureReason] -> ShowS
show :: FailureReason -> String
$cshow :: FailureReason -> String
showsPrec :: Int -> FailureReason -> ShowS
$cshowsPrec :: Int -> FailureReason -> ShowS
Show
data Outcome
= Success
| Failure FailureReason
deriving (Int -> Outcome -> ShowS
[Outcome] -> ShowS
Outcome -> String
(Int -> Outcome -> ShowS)
-> (Outcome -> String) -> ([Outcome] -> ShowS) -> Show Outcome
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Outcome] -> ShowS
$cshowList :: [Outcome] -> ShowS
show :: Outcome -> String
$cshow :: Outcome -> String
showsPrec :: Int -> Outcome -> ShowS
$cshowsPrec :: Int -> Outcome -> ShowS
Show, (forall x. Outcome -> Rep Outcome x)
-> (forall x. Rep Outcome x -> Outcome) -> Generic Outcome
forall x. Rep Outcome x -> Outcome
forall x. Outcome -> Rep Outcome x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Outcome x -> Outcome
$cfrom :: forall x. Outcome -> Rep Outcome x
Generic)
type Time = Double
data Result = Result
{ Result -> Outcome
resultOutcome :: Outcome
, Result -> String
resultDescription :: String
, Result -> String
resultShortDescription :: String
, Result -> Time
resultTime :: Time
, Result -> ResultDetailsPrinter
resultDetailsPrinter :: ResultDetailsPrinter
}
deriving Int -> Result -> ShowS
[Result] -> ShowS
Result -> String
(Int -> Result -> ShowS)
-> (Result -> String) -> ([Result] -> ShowS) -> Show Result
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Result] -> ShowS
$cshowList :: [Result] -> ShowS
show :: Result -> String
$cshow :: Result -> String
showsPrec :: Int -> Result -> ShowS
$cshowsPrec :: Int -> Result -> ShowS
Show
resultSuccessful :: Result -> Bool
resultSuccessful :: Result -> Bool
resultSuccessful Result
r =
case Result -> Outcome
resultOutcome Result
r of
Outcome
Success -> Bool
True
Failure {} -> Bool
False
exceptionResult :: SomeException -> Result
exceptionResult :: SomeException -> Result
exceptionResult SomeException
e = Result
{ resultOutcome :: Outcome
resultOutcome = FailureReason -> Outcome
Failure (FailureReason -> Outcome) -> FailureReason -> Outcome
forall a b. (a -> b) -> a -> b
$ SomeException -> FailureReason
TestThrewException SomeException
e
, resultDescription :: String
resultDescription = String
"Exception: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
, resultShortDescription :: String
resultShortDescription = String
"FAIL"
, resultTime :: Time
resultTime = Time
0
, resultDetailsPrinter :: ResultDetailsPrinter
resultDetailsPrinter = ResultDetailsPrinter
noResultDetails
}
data Progress = Progress
{ Progress -> String
progressText :: String
, Progress -> Float
progressPercent :: Float
}
deriving Int -> Progress -> ShowS
[Progress] -> ShowS
Progress -> String
(Int -> Progress -> ShowS)
-> (Progress -> String) -> ([Progress] -> ShowS) -> Show Progress
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Progress] -> ShowS
$cshowList :: [Progress] -> ShowS
show :: Progress -> String
$cshow :: Progress -> String
showsPrec :: Int -> Progress -> ShowS
$cshowsPrec :: Int -> Progress -> ShowS
Show
class Typeable t => IsTest t where
run
:: OptionSet
-> t
-> (Progress -> IO ())
-> IO Result
testOptions :: Tagged t [OptionDescription]
type TestName = String
data ResourceSpec a = ResourceSpec (IO a) (a -> IO ())
data ResourceError
= NotRunningTests
| UnexpectedState String String
| UseOutsideOfTest
deriving Typeable
instance Show ResourceError where
show :: ResourceError -> String
show ResourceError
NotRunningTests =
String
"Unhandled resource. Probably a bug in the runner you're using."
show (UnexpectedState String
where_ String
what) =
String -> String -> ShowS
forall r. PrintfType r => String -> r
printf String
"Unexpected state of the resource (%s) in %s. Report as a tasty bug."
String
what String
where_
show ResourceError
UseOutsideOfTest =
String
"It looks like you're attempting to use a resource outside of its test. Don't do that!"
instance Exception ResourceError
data DependencyType
= AllSucceed
| AllFinish
deriving (DependencyType -> DependencyType -> Bool
(DependencyType -> DependencyType -> Bool)
-> (DependencyType -> DependencyType -> Bool) -> Eq DependencyType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DependencyType -> DependencyType -> Bool
$c/= :: DependencyType -> DependencyType -> Bool
== :: DependencyType -> DependencyType -> Bool
$c== :: DependencyType -> DependencyType -> Bool
Eq, Int -> DependencyType -> ShowS
[DependencyType] -> ShowS
DependencyType -> String
(Int -> DependencyType -> ShowS)
-> (DependencyType -> String)
-> ([DependencyType] -> ShowS)
-> Show DependencyType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DependencyType] -> ShowS
$cshowList :: [DependencyType] -> ShowS
show :: DependencyType -> String
$cshow :: DependencyType -> String
showsPrec :: Int -> DependencyType -> ShowS
$cshowsPrec :: Int -> DependencyType -> ShowS
Show)
data TestTree
= forall t . IsTest t => SingleTest TestName t
| TestGroup TestName [TestTree]
| PlusTestOptions (OptionSet -> OptionSet) TestTree
| forall a . WithResource (ResourceSpec a) (IO a -> TestTree)
| AskOptions (OptionSet -> TestTree)
| After DependencyType Expr TestTree
testGroup :: TestName -> [TestTree] -> TestTree
testGroup :: String -> [TestTree] -> TestTree
testGroup = String -> [TestTree] -> TestTree
TestGroup
after_
:: DependencyType
-> Expr
-> TestTree
-> TestTree
after_ :: DependencyType -> Expr -> TestTree -> TestTree
after_ = DependencyType -> Expr -> TestTree -> TestTree
After
after
:: DependencyType
-> String
-> TestTree
-> TestTree
after :: DependencyType -> String -> TestTree -> TestTree
after DependencyType
deptype String
s =
case String -> Maybe Expr
parseExpr String
s of
Maybe Expr
Nothing -> String -> TestTree -> TestTree
forall a. HasCallStack => String -> a
error (String -> TestTree -> TestTree) -> String -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ String
"Could not parse pattern " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
s
Just Expr
e -> DependencyType -> Expr -> TestTree -> TestTree
after_ DependencyType
deptype Expr
e
data TreeFold b = TreeFold
{ forall b.
TreeFold b -> forall t. IsTest t => OptionSet -> String -> t -> b
foldSingle :: forall t . IsTest t => OptionSet -> TestName -> t -> b
, forall b. TreeFold b -> OptionSet -> String -> b -> b
foldGroup :: OptionSet -> TestName -> b -> b
, forall b.
TreeFold b
-> forall a. OptionSet -> ResourceSpec a -> (IO a -> b) -> b
foldResource :: forall a . OptionSet -> ResourceSpec a -> (IO a -> b) -> b
, forall b.
TreeFold b -> OptionSet -> DependencyType -> Expr -> b -> b
foldAfter :: OptionSet -> DependencyType -> Expr -> b -> b
}
trivialFold :: Monoid b => TreeFold b
trivialFold :: forall b. Monoid b => TreeFold b
trivialFold = TreeFold
{ foldSingle :: forall t. IsTest t => OptionSet -> String -> t -> b
foldSingle = \OptionSet
_ String
_ t
_ -> b
forall a. Monoid a => a
mempty
, foldGroup :: OptionSet -> String -> b -> b
foldGroup = \OptionSet
_ String
_ b
b -> b
b
, foldResource :: forall a. OptionSet -> ResourceSpec a -> (IO a -> b) -> b
foldResource = \OptionSet
_ ResourceSpec a
_ IO a -> b
f -> IO a -> b
f (IO a -> b) -> IO a -> b
forall a b. (a -> b) -> a -> b
$ ResourceError -> IO a
forall e a. Exception e => e -> IO a
throwIO ResourceError
NotRunningTests
, foldAfter :: OptionSet -> DependencyType -> Expr -> b -> b
foldAfter = \OptionSet
_ DependencyType
_ Expr
_ b
b -> b
b
}
foldTestTree
:: forall b . Monoid b
=> TreeFold b
-> OptionSet
-> TestTree
-> b
foldTestTree :: forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree (TreeFold forall t. IsTest t => OptionSet -> String -> t -> b
fTest OptionSet -> String -> b -> b
fGroup forall a. OptionSet -> ResourceSpec a -> (IO a -> b) -> b
fResource OptionSet -> DependencyType -> Expr -> b -> b
fAfter) OptionSet
opts0 TestTree
tree0 =
Seq String -> OptionSet -> TestTree -> b
go Seq String
forall a. Monoid a => a
mempty OptionSet
opts0 TestTree
tree0
where
go :: (Seq.Seq TestName -> OptionSet -> TestTree -> b)
go :: Seq String -> OptionSet -> TestTree -> b
go Seq String
path OptionSet
opts TestTree
tree1 =
case TestTree
tree1 of
SingleTest String
name t
test
| TestPattern -> Seq String -> Bool
testPatternMatches TestPattern
pat (Seq String
path Seq String -> String -> Seq String
forall a. Seq a -> a -> Seq a
Seq.|> String
name)
-> OptionSet -> String -> t -> b
forall t. IsTest t => OptionSet -> String -> t -> b
fTest OptionSet
opts String
name t
test
| Bool
otherwise -> b
forall a. Monoid a => a
mempty
TestGroup String
name [TestTree]
trees ->
OptionSet -> String -> b -> b
fGroup OptionSet
opts String
name (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$ (TestTree -> b) -> [TestTree] -> b
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Seq String -> OptionSet -> TestTree -> b
go (Seq String
path Seq String -> String -> Seq String
forall a. Seq a -> a -> Seq a
Seq.|> String
name) OptionSet
opts) [TestTree]
trees
PlusTestOptions OptionSet -> OptionSet
f TestTree
tree -> Seq String -> OptionSet -> TestTree -> b
go Seq String
path (OptionSet -> OptionSet
f OptionSet
opts) TestTree
tree
WithResource ResourceSpec a
res0 IO a -> TestTree
tree -> OptionSet -> ResourceSpec a -> (IO a -> b) -> b
forall a. OptionSet -> ResourceSpec a -> (IO a -> b) -> b
fResource OptionSet
opts ResourceSpec a
res0 ((IO a -> b) -> b) -> (IO a -> b) -> b
forall a b. (a -> b) -> a -> b
$ \IO a
res -> Seq String -> OptionSet -> TestTree -> b
go Seq String
path OptionSet
opts (IO a -> TestTree
tree IO a
res)
AskOptions OptionSet -> TestTree
f -> Seq String -> OptionSet -> TestTree -> b
go Seq String
path OptionSet
opts (OptionSet -> TestTree
f OptionSet
opts)
After DependencyType
deptype Expr
dep TestTree
tree -> OptionSet -> DependencyType -> Expr -> b -> b
fAfter OptionSet
opts DependencyType
deptype Expr
dep (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$ Seq String -> OptionSet -> TestTree -> b
go Seq String
path OptionSet
opts TestTree
tree
where
pat :: TestPattern
pat = OptionSet -> TestPattern
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts :: TestPattern
treeOptions :: TestTree -> [OptionDescription]
treeOptions :: TestTree -> [OptionDescription]
treeOptions =
[[OptionDescription]] -> [OptionDescription]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
Prelude.concat ([[OptionDescription]] -> [OptionDescription])
-> (TestTree -> [[OptionDescription]])
-> TestTree
-> [OptionDescription]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Map TypeRep [OptionDescription] -> [[OptionDescription]]
forall k a. Map k a -> [a]
Map.elems (Map TypeRep [OptionDescription] -> [[OptionDescription]])
-> (TestTree -> Map TypeRep [OptionDescription])
-> TestTree
-> [[OptionDescription]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
TreeFold (Map TypeRep [OptionDescription])
-> OptionSet -> TestTree -> Map TypeRep [OptionDescription]
forall b. Monoid b => TreeFold b -> OptionSet -> TestTree -> b
foldTestTree
TreeFold (Map TypeRep [OptionDescription])
forall b. Monoid b => TreeFold b
trivialFold { foldSingle :: forall t.
IsTest t =>
OptionSet -> String -> t -> Map TypeRep [OptionDescription]
foldSingle = \OptionSet
_ String
_ -> t -> Map TypeRep [OptionDescription]
forall t. IsTest t => t -> Map TypeRep [OptionDescription]
getTestOptions }
OptionSet
forall a. Monoid a => a
mempty
where
getTestOptions
:: forall t . IsTest t
=> t -> Map.Map TypeRep [OptionDescription]
getTestOptions :: forall t. IsTest t => t -> Map TypeRep [OptionDescription]
getTestOptions t
t =
TypeRep -> [OptionDescription] -> Map TypeRep [OptionDescription]
forall k a. k -> a -> Map k a
Map.singleton (t -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf t
t) ([OptionDescription] -> Map TypeRep [OptionDescription])
-> [OptionDescription] -> Map TypeRep [OptionDescription]
forall a b. (a -> b) -> a -> b
$
Tagged t [OptionDescription] -> t -> [OptionDescription]
forall a b. Tagged a b -> a -> b
witness Tagged t [OptionDescription]
forall t. IsTest t => Tagged t [OptionDescription]
testOptions t
t