{-# LANGUAGE CPP #-}
module Test.Tasty.Hspec
(
testSpec,
testSpecs,
TreatPendingAs (..),
)
where
import Control.Monad (guard)
import Data.Maybe (catMaybes, fromMaybe, mapMaybe)
import Data.Proxy
import Data.Typeable (Typeable)
import qualified Test.Hspec as H
import qualified Test.Hspec.Core.Formatters as H
import qualified Test.Hspec.Core.Spec as H
import qualified Test.Tasty as T
import Test.Tasty.Hspec.Compat
import qualified Test.Tasty.Options as T
import qualified Test.Tasty.Providers as T
import qualified Test.Tasty.QuickCheck as TQC
import qualified Test.Tasty.Runners as T
import qualified Test.Tasty.SmallCheck as TSC
testSpec :: T.TestName -> H.Spec -> IO T.TestTree
testSpec :: TestName -> Spec -> IO TestTree
testSpec TestName
name Spec
spec = do
[TestTree]
trees <- Spec -> IO [TestTree]
testSpecs Spec
spec
TestTree -> IO TestTree
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestName -> [TestTree] -> TestTree
T.testGroup TestName
name [TestTree]
trees)
testSpecs :: H.Spec -> IO [T.TestTree]
testSpecs :: Spec -> IO [TestTree]
testSpecs Spec
spec = do
[SpecTree ()]
trees <- Spec -> IO [SpecTree ()]
forall a. SpecWith a -> IO [SpecTree a]
H.runSpecM (Spec -> Spec
focus Spec
spec)
[TestTree] -> IO [TestTree]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((SpecTree () -> Maybe TestTree) -> [SpecTree ()] -> [TestTree]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SpecTree () -> Maybe TestTree
specTreeToTestTree [SpecTree ()]
trees)
specTreeToTestTree :: H.SpecTree () -> Maybe T.TestTree
specTreeToTestTree :: SpecTree () -> Maybe TestTree
specTreeToTestTree = \case
Node TestName
name [SpecTree ()]
trees -> TestTree -> Maybe TestTree
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestName -> [TestTree] -> TestTree
T.testGroup TestName
name ((SpecTree () -> Maybe TestTree) -> [SpecTree ()] -> [TestTree]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SpecTree () -> Maybe TestTree
specTreeToTestTree [SpecTree ()]
trees))
NodeWithCleanup ActionWith ()
cleanup [SpecTree ()]
trees -> do
TestTree
tree <- SpecTree () -> Maybe TestTree
specTreeToTestTree (TestName -> [SpecTree ()] -> SpecTree ()
forall c a. TestName -> [Tree c a] -> Tree c a
H.Node TestName
"(unnamed)" [SpecTree ()]
trees)
TestTree -> Maybe TestTree
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ResourceSpec () -> (IO () -> TestTree) -> TestTree
forall a. ResourceSpec a -> (IO a -> TestTree) -> TestTree
T.WithResource (IO () -> ActionWith () -> ResourceSpec ()
forall a. IO a -> (a -> IO ()) -> ResourceSpec a
T.ResourceSpec (ActionWith ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ActionWith ()
cleanup) (TestTree -> IO () -> TestTree
forall a b. a -> b -> a
const TestTree
tree))
Leaf Item ()
item -> do
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Item () -> Bool
forall a. Item a -> Bool
itemIsFocused Item ()
item)
TestTree -> Maybe TestTree
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestName -> Item -> TestTree
forall t. IsTest t => TestName -> t -> TestTree
T.singleTest (Item () -> TestName
forall a. Item a -> TestName
H.itemRequirement Item ()
item) (Item () -> Item
Item Item ()
item))
newtype Item
= Item (H.Item ())
deriving (Typeable)
instance T.IsTest Item where
run :: OptionSet -> Item -> (Progress -> IO ()) -> IO Result
run OptionSet
opts (Item Item ()
item) Progress -> IO ()
progress = do
Args
qcArgs <- OptionSet -> IO Args
optionSetToQuickCheckArgs OptionSet
opts
H.Result TestName
_ ResultStatus
result <- Item ()
-> Params
-> (ActionWith () -> IO ())
-> ProgressCallback
-> IO Result
forall a.
Item a
-> Params
-> (ActionWith a -> IO ())
-> ProgressCallback
-> IO Result
itemExample Item ()
item (Args -> Params
params Args
qcArgs) (ActionWith () -> ActionWith ()
forall a b. (a -> b) -> a -> b
$ ()) ProgressCallback
forall a a. (Integral a, Integral a) => (a, a) -> IO ()
progress'
Result -> IO Result
forall (f :: * -> *) a. Applicative f => a -> f a
pure
( case ResultStatus
result of
ResultStatus
H.Success -> TestName -> Result
T.testPassed TestName
""
H.Pending Maybe Location
_ Maybe TestName
reason ->
case OptionSet -> TreatPendingAs
forall v. IsOption v => OptionSet -> v
T.lookupOption OptionSet
opts of
TreatPendingAs
TreatPendingAsFailure -> TestName -> Result
T.testFailed TestName
reason'
TreatPendingAs
TreatPendingAsSuccess -> TestName -> Result
T.testPassed TestName
reason'
where
reason' :: TestName
reason' = TestName
"# PENDING: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName -> Maybe TestName -> TestName
forall a. a -> Maybe a -> a
fromMaybe TestName
"No reason given" Maybe TestName
reason
H.Failure Maybe Location
_ FailureReason
reason ->
case FailureReason
reason of
FailureReason
H.NoReason -> TestName -> Result
T.testFailed TestName
""
H.Reason TestName
x -> TestName -> Result
T.testFailed TestName
x
H.ExpectedButGot Maybe TestName
preface TestName
expected TestName
actual ->
TestName -> Result
T.testFailed (TestName -> Result)
-> ([Maybe TestName] -> TestName) -> [Maybe TestName] -> Result
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TestName] -> TestName
unlines ([TestName] -> TestName)
-> ([Maybe TestName] -> [TestName]) -> [Maybe TestName] -> TestName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe TestName] -> [TestName]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TestName] -> Result) -> [Maybe TestName] -> Result
forall a b. (a -> b) -> a -> b
$
[ Maybe TestName
preface,
TestName -> Maybe TestName
forall a. a -> Maybe a
Just (TestName
"expected: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
expected),
TestName -> Maybe TestName
forall a. a -> Maybe a
Just (TestName
" but got: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ TestName
actual)
]
H.Error Maybe TestName
_ SomeException
exception -> TestName -> Result
T.testFailed (TestName
"uncaught exception: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ SomeException -> TestName
H.formatException SomeException
exception)
)
where
params :: Args -> Params
params Args
qcArgs =
Params :: Args -> Int -> Params
H.Params
{ paramsQuickCheckArgs :: Args
H.paramsQuickCheckArgs = Args
qcArgs,
paramsSmallCheckDepth :: Int
H.paramsSmallCheckDepth =
case OptionSet -> SmallCheckDepth
forall v. IsOption v => OptionSet -> v
T.lookupOption OptionSet
opts of
TSC.SmallCheckDepth Int
depth ->
Int
depth
}
progress' :: (a, a) -> IO ()
progress' (a
x, a
y) =
Progress -> IO ()
progress
Progress :: TestName -> Float -> Progress
T.Progress
{ progressText :: TestName
T.progressText = TestName
"",
progressPercent :: Float
T.progressPercent = a -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ a -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
y
}
testOptions :: Tagged Item [OptionDescription]
testOptions =
[OptionDescription] -> Tagged Item [OptionDescription]
forall (f :: * -> *) a. Applicative f => a -> f a
pure
[ Proxy TreatPendingAs -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
T.Option (Proxy TreatPendingAs
forall k (t :: k). Proxy t
Proxy :: Proxy TreatPendingAs),
Proxy QuickCheckTests -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
T.Option (Proxy QuickCheckTests
forall k (t :: k). Proxy t
Proxy :: Proxy TQC.QuickCheckTests),
Proxy QuickCheckReplay -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
T.Option (Proxy QuickCheckReplay
forall k (t :: k). Proxy t
Proxy :: Proxy TQC.QuickCheckReplay),
Proxy QuickCheckMaxSize -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
T.Option (Proxy QuickCheckMaxSize
forall k (t :: k). Proxy t
Proxy :: Proxy TQC.QuickCheckMaxSize),
Proxy QuickCheckMaxRatio -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
T.Option (Proxy QuickCheckMaxRatio
forall k (t :: k). Proxy t
Proxy :: Proxy TQC.QuickCheckMaxRatio),
Proxy SmallCheckDepth -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
T.Option (Proxy SmallCheckDepth
forall k (t :: k). Proxy t
Proxy :: Proxy TSC.SmallCheckDepth)
]
data TreatPendingAs
=
TreatPendingAsFailure
| TreatPendingAsSuccess
instance T.IsOption TreatPendingAs where
defaultValue :: TreatPendingAs
defaultValue =
TreatPendingAs
TreatPendingAsFailure
parseValue :: TestName -> Maybe TreatPendingAs
parseValue = \case
TestName
"failure" -> TreatPendingAs -> Maybe TreatPendingAs
forall a. a -> Maybe a
Just TreatPendingAs
TreatPendingAsFailure
TestName
"success" -> TreatPendingAs -> Maybe TreatPendingAs
forall a. a -> Maybe a
Just TreatPendingAs
TreatPendingAsSuccess
TestName
_ -> Maybe TreatPendingAs
forall a. Maybe a
Nothing
optionName :: Tagged TreatPendingAs TestName
optionName =
TestName -> Tagged TreatPendingAs TestName
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestName
"treat-pending-as"
optionHelp :: Tagged TreatPendingAs TestName
optionHelp =
TestName -> Tagged TreatPendingAs TestName
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestName
"How to treat pending hspec tests ('failure' or 'success')"
#if MIN_VERSION_tasty(1,3,0)
showDefaultValue :: TreatPendingAs -> Maybe TestName
showDefaultValue TreatPendingAs
_ =
TestName -> Maybe TestName
forall a. a -> Maybe a
Just TestName
"failure"
#endif