{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Test.Tasty.Hspec
(
testSpec
, testSpecs
, TreatPendingAs(..)
, module Test.Hspec
) where
import Control.Applicative ((<$>))
import Control.Exception (SomeException)
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.QuickCheck as QC
import qualified Test.Tasty as T
import qualified Test.Tasty.SmallCheck as TSC
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 Test.Hspec
testSpec :: T.TestName -> H.Spec -> IO T.TestTree
testSpec :: TestName -> Spec -> IO TestTree
testSpec TestName
name Spec
spec = TestName -> [TestTree] -> TestTree
T.testGroup TestName
name ([TestTree] -> TestTree) -> IO [TestTree] -> IO TestTree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Spec -> IO [TestTree]
testSpecs Spec
spec
testSpecs :: H.Spec -> IO [T.TestTree]
testSpecs :: Spec -> IO [TestTree]
testSpecs Spec
spec =
[Maybe TestTree] -> [TestTree]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TestTree] -> [TestTree])
-> ([SpecTree ()] -> [Maybe TestTree])
-> [SpecTree ()]
-> [TestTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpecTree () -> Maybe TestTree)
-> [SpecTree ()] -> [Maybe TestTree]
forall a b. (a -> b) -> [a] -> [b]
map SpecTree () -> Maybe TestTree
specTreeToTestTree ([SpecTree ()] -> [TestTree]) -> IO [SpecTree ()] -> IO [TestTree]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Spec -> IO [SpecTree ()]
forall a. SpecWith a -> IO [SpecTree a]
H.runSpecM (Spec -> Spec
doFocus Spec
spec)
where
doFocus :: H.Spec -> H.Spec
doFocus :: Spec -> Spec
doFocus =
#if MIN_VERSION_hspec(2,6,0)
Spec -> Spec
forall a. SpecWith a -> SpecWith a
H.focus
#else
id
#endif
specTreeToTestTree :: H.SpecTree () -> Maybe T.TestTree
specTreeToTestTree :: SpecTree () -> Maybe TestTree
specTreeToTestTree SpecTree ()
spec_tree =
case SpecTree ()
spec_tree of
H.Node TestName
name [SpecTree ()]
spec_trees ->
TestTree -> Maybe TestTree
forall a. a -> Maybe a
Just (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 ()]
spec_trees))
H.NodeWithCleanup ActionWith ()
cleanup [SpecTree ()]
spec_trees ->
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) ((IO () -> TestTree) -> TestTree)
-> (TestTree -> IO () -> TestTree) -> TestTree -> TestTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestTree -> IO () -> TestTree
forall a b. a -> b -> a
const (TestTree -> TestTree) -> Maybe TestTree -> Maybe TestTree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe TestTree
test_tree
where
test_tree :: Maybe T.TestTree
test_tree :: Maybe TestTree
test_tree = SpecTree () -> Maybe TestTree
specTreeToTestTree (TestName -> [SpecTree ()] -> SpecTree ()
forall c a. TestName -> [Tree c a] -> Tree c a
H.Node TestName
"(unnamed)" [SpecTree ()]
spec_trees)
H.Leaf Item ()
item -> do
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Item () -> Bool
forall a. Item a -> Bool
hspecItemIsFocused Item ()
item)
TestTree -> Maybe TestTree
forall a. a -> Maybe a
Just (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
qc_args <- OptionSet -> IO Args
tastyOptionSetToQuickCheckArgs OptionSet
opts
let
pending_ :: String -> T.Result
pending_ :: TestName -> Result
pending_ =
case OptionSet -> TreatPendingAs
forall v. IsOption v => OptionSet -> v
T.lookupOption OptionSet
opts of
TreatPendingAs
TreatPendingAsFailure -> TestName -> Result
T.testFailed
TreatPendingAs
TreatPendingAsSuccess -> TestName -> Result
T.testPassed
let
params :: H.Params
params :: Params
params = Params :: Args -> Int -> Params
H.Params
{ paramsQuickCheckArgs :: Args
H.paramsQuickCheckArgs = Args
qc_args
, paramsSmallCheckDepth :: Int
H.paramsSmallCheckDepth = Int
sc_depth
}
#if MIN_VERSION_hspec(2,4,0) && !MIN_VERSION_hspec(2,5,0)
either handleUncaughtException (hspecResultToTastyResult pending_)
#else
(TestName -> Result) -> Result -> Result
hspecResultToTastyResult TestName -> Result
pending_
#endif
(Result -> Result) -> IO Result -> IO Result
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Item ()
-> Params
-> (ActionWith () -> IO ())
-> ProgressCallback
-> IO Result
forall a.
Item a
-> Params
-> (ActionWith a -> IO ())
-> ProgressCallback
-> IO Result
hspecItemToExample Item ()
item Params
params (ActionWith () -> ActionWith ()
forall a b. (a -> b) -> a -> b
$ ()) ProgressCallback
hprogress
where
sc_depth :: Int
sc_depth :: Int
sc_depth =
case OptionSet -> SmallCheckDepth
forall v. IsOption v => OptionSet -> v
T.lookupOption OptionSet
opts of
TSC.SmallCheckDepth Int
depth ->
Int
depth
hprogress :: H.Progress -> IO ()
hprogress :: ProgressCallback
hprogress (Int
x,Int
y) =
Progress -> IO ()
progress Progress :: TestName -> Float -> Progress
T.Progress
{ progressText :: TestName
T.progressText = TestName
""
, progressPercent :: Float
T.progressPercent = Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
x Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y
}
testOptions :: Tagged Item [OptionDescription]
testOptions =
[OptionDescription] -> Tagged Item [OptionDescription]
forall (m :: * -> *) a. Monad m => a -> m a
return
[ 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)
]
tastyOptionSetToQuickCheckArgs :: T.OptionSet -> IO QC.Args
tastyOptionSetToQuickCheckArgs :: OptionSet -> IO Args
tastyOptionSetToQuickCheckArgs OptionSet
opts =
#if MIN_VERSION_tasty_quickcheck(0,9,1)
(Int, Args) -> Args
forall a b. (a, b) -> b
snd ((Int, Args) -> Args) -> IO (Int, Args) -> IO Args
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OptionSet -> IO (Int, Args)
TQC.optionSetToArgs OptionSet
opts
#else
return QC.stdArgs
{ QC.chatty = False
, QC.maxDiscardRatio = max_ratio
, QC.maxSize = max_size
, QC.maxSuccess = num_tests
, QC.replay = replay
}
where
TQC.QuickCheckTests num_tests = T.lookupOption opts
TQC.QuickCheckReplay replay = T.lookupOption opts
TQC.QuickCheckMaxSize max_size = T.lookupOption opts
TQC.QuickCheckMaxRatio max_ratio = T.lookupOption opts
#endif
hspecResultToTastyResult :: (String -> T.Result) -> H.Result -> T.Result
#if MIN_VERSION_hspec(2,5,0)
hspecResultToTastyResult :: (TestName -> Result) -> Result -> Result
hspecResultToTastyResult TestName -> Result
pending_ (H.Result TestName
_ ResultStatus
result) =
#else
hspecResultToTastyResult pending_ result =
#endif
case ResultStatus
result of
ResultStatus
H.Success ->
TestName -> Result
T.testPassed TestName
""
#if MIN_VERSION_hspec(2,5,0)
H.Pending Maybe Location
_ Maybe TestName
x ->
#else
H.Pending x ->
#endif
(TestName -> Result) -> Maybe TestName -> Result
handleResultPending TestName -> Result
pending_ Maybe TestName
x
#if MIN_VERSION_hspec(2,4,0)
H.Failure Maybe Location
_ FailureReason
x ->
FailureReason -> Result
handleResultFailure FailureReason
x
#elif MIN_VERSION_hspec(2,2,0)
H.Fail _ str -> T.testFailed str
#else
H.Fail str -> T.testFailed str
#endif
hspecItemIsFocused :: H.Item a -> Bool
hspecItemIsFocused :: Item a -> Bool
hspecItemIsFocused =
#if MIN_VERSION_hspec(2,6,0)
Item a -> Bool
forall a. Item a -> Bool
H.itemIsFocused
#else
const True
#endif
hspecItemToExample
:: H.Item a
-> H.Params
-> (H.ActionWith a -> IO ())
-> H.ProgressCallback
-> IO H.Result
#if MIN_VERSION_hspec(2,6,0)
hspecItemToExample :: Item a
-> Params
-> (ActionWith a -> IO ())
-> ProgressCallback
-> IO Result
hspecItemToExample (H.Item TestName
_ Maybe Location
_ Maybe Bool
_ Bool
_ Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result
ex) = Params -> (ActionWith a -> IO ()) -> ProgressCallback -> IO Result
ex
#else
hspecItemToExample (H.Item _ _ _ ex) = ex
#endif
handleResultPending :: (String -> T.Result) -> Maybe String -> T.Result
handleResultPending :: (TestName -> Result) -> Maybe TestName -> Result
handleResultPending TestName -> Result
pending_ Maybe TestName
x =
TestName -> Result
pending_ (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
x)
#if MIN_VERSION_hspec(2,4,0)
handleResultFailure :: H.FailureReason -> T.Result
handleResultFailure :: FailureReason -> Result
handleResultFailure 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)
]
#if MIN_VERSION_hspec(2,5,0)
H.Error Maybe TestName
_ SomeException
ex ->
SomeException -> Result
handleUncaughtException SomeException
ex
#endif
#endif
handleUncaughtException :: SomeException -> T.Result
handleUncaughtException :: SomeException -> Result
handleUncaughtException SomeException
ex =
TestName -> Result
T.testFailed (TestName
"uncaught exception: " TestName -> TestName -> TestName
forall a. [a] -> [a] -> [a]
++ SomeException -> TestName
H.formatException SomeException
ex)
data TreatPendingAs
= TreatPendingAsFailure
| TreatPendingAsSuccess
instance T.IsOption TreatPendingAs where
defaultValue :: TreatPendingAs
defaultValue =
TreatPendingAs
TreatPendingAsFailure
parseValue :: TestName -> Maybe TreatPendingAs
parseValue TestName
s =
case TestName
s of
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