{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleContexts,
ExistentialQuantification, RankNTypes, DeriveDataTypeable,
DeriveGeneric #-}
module Test.Tasty.Core where
import Control.Exception
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
}
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 r :: Result
r =
case Result -> Outcome
resultOutcome Result
r of
Success -> Bool
True
Failure {} -> Bool
False
exceptionResult :: SomeException -> Result
exceptionResult :: SomeException -> Result
exceptionResult e :: SomeException
e = Result :: Outcome -> String -> String -> Time -> Result
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 = "Exception: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SomeException -> String
forall a. Show a => a -> String
show SomeException
e
, resultShortDescription :: String
resultShortDescription = "FAIL"
, resultTime :: Time
resultTime = 0
}
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 NotRunningTests =
"Unhandled resource. Probably a bug in the runner you're using."
show (UnexpectedState where_ :: String
where_ what :: String
what) =
String -> String -> ShowS
forall r. PrintfType r => String -> r
printf "Unexpected state of the resource (%s) in %s. Report as a tasty bug."
String
what String
where_
show UseOutsideOfTest =
"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 deptype :: DependencyType
deptype s :: String
s =
case String -> Maybe Expr
parseExpr String
s of
Nothing -> String -> TestTree -> TestTree
forall a. HasCallStack => String -> a
error (String -> TestTree -> TestTree) -> String -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$ "Could not parse pattern " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
s
Just e :: Expr
e -> DependencyType -> Expr -> TestTree -> TestTree
after_ DependencyType
deptype Expr
e
data TreeFold b = TreeFold
{ TreeFold b -> forall t. IsTest t => OptionSet -> String -> t -> b
foldSingle :: forall t . IsTest t => OptionSet -> TestName -> t -> b
, TreeFold b -> String -> b -> b
foldGroup :: TestName -> b -> b
, TreeFold b -> forall a. ResourceSpec a -> (IO a -> b) -> b
foldResource :: forall a . ResourceSpec a -> (IO a -> b) -> b
, TreeFold b -> DependencyType -> Expr -> b -> b
foldAfter :: DependencyType -> Expr -> b -> b
}
trivialFold :: Monoid b => TreeFold b
trivialFold :: TreeFold b
trivialFold = TreeFold :: forall b.
(forall t. IsTest t => OptionSet -> String -> t -> b)
-> (String -> b -> b)
-> (forall a. ResourceSpec a -> (IO a -> b) -> b)
-> (DependencyType -> Expr -> b -> b)
-> TreeFold b
TreeFold
{ foldSingle :: forall t. IsTest t => OptionSet -> String -> t -> b
foldSingle = \_ _ _ -> b
forall a. Monoid a => a
mempty
, foldGroup :: String -> b -> b
foldGroup = (b -> b) -> String -> b -> b
forall a b. a -> b -> a
const b -> b
forall a. a -> a
id
, foldResource :: forall a. ResourceSpec a -> (IO a -> b) -> b
foldResource = \_ f :: 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 :: DependencyType -> Expr -> b -> b
foldAfter = \_ _ b :: b
b -> b
b
}
foldTestTree
:: Monoid b
=> TreeFold b
-> OptionSet
-> TestTree
-> b
foldTestTree :: TreeFold b -> OptionSet -> TestTree -> b
foldTestTree (TreeFold fTest :: forall t. IsTest t => OptionSet -> String -> t -> b
fTest fGroup :: String -> b -> b
fGroup fResource :: forall a. ResourceSpec a -> (IO a -> b) -> b
fResource fAfter :: DependencyType -> Expr -> b -> b
fAfter) opts0 :: OptionSet
opts0 tree0 :: TestTree
tree0 =
let pat :: TestPattern
pat = OptionSet -> TestPattern
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts0
in TestPattern -> Seq String -> OptionSet -> TestTree -> b
go TestPattern
pat Seq String
forall a. Monoid a => a
mempty OptionSet
opts0 TestTree
tree0
where
go :: TestPattern -> Seq String -> OptionSet -> TestTree -> b
go pat :: TestPattern
pat path :: Seq String
path opts :: OptionSet
opts tree1 :: TestTree
tree1 =
case TestTree
tree1 of
SingleTest name :: String
name test :: 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 name :: String
name trees :: [TestTree]
trees ->
String -> b -> b
fGroup 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 (TestPattern -> Seq String -> OptionSet -> TestTree -> b
go TestPattern
pat (Seq String
path Seq String -> String -> Seq String
forall a. Seq a -> a -> Seq a
Seq.|> String
name) OptionSet
opts) [TestTree]
trees
PlusTestOptions f :: OptionSet -> OptionSet
f tree :: TestTree
tree -> TestPattern -> Seq String -> OptionSet -> TestTree -> b
go TestPattern
pat Seq String
path (OptionSet -> OptionSet
f OptionSet
opts) TestTree
tree
WithResource res0 :: ResourceSpec a
res0 tree :: IO a -> TestTree
tree -> ResourceSpec a -> (IO a -> b) -> b
forall a. ResourceSpec a -> (IO a -> b) -> b
fResource ResourceSpec a
res0 ((IO a -> b) -> b) -> (IO a -> b) -> b
forall a b. (a -> b) -> a -> b
$ \res :: IO a
res -> TestPattern -> Seq String -> OptionSet -> TestTree -> b
go TestPattern
pat Seq String
path OptionSet
opts (IO a -> TestTree
tree IO a
res)
AskOptions f :: OptionSet -> TestTree
f -> TestPattern -> Seq String -> OptionSet -> TestTree -> b
go TestPattern
pat Seq String
path OptionSet
opts (OptionSet -> TestTree
f OptionSet
opts)
After deptype :: DependencyType
deptype dep :: Expr
dep tree :: TestTree
tree -> DependencyType -> Expr -> b -> b
fAfter DependencyType
deptype Expr
dep (b -> b) -> b -> b
forall a b. (a -> b) -> a -> b
$ TestPattern -> Seq String -> OptionSet -> TestTree -> b
go TestPattern
pat Seq String
path OptionSet
opts TestTree
tree
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 = \_ _ -> 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 :: t -> Map TypeRep [OptionDescription]
getTestOptions t :: 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