{-# 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 name spec = T.testGroup name <$> testSpecs spec
testSpecs :: H.Spec -> IO [T.TestTree]
testSpecs spec =
catMaybes . map specTreeToTestTree <$>
H.runSpecM (doFocus spec)
where
doFocus :: H.Spec -> H.Spec
doFocus =
#if MIN_VERSION_hspec(2,6,0)
H.focus
#else
id
#endif
specTreeToTestTree :: H.SpecTree () -> Maybe T.TestTree
specTreeToTestTree spec_tree =
case spec_tree of
H.Node name spec_trees ->
Just (T.testGroup name (mapMaybe specTreeToTestTree spec_trees))
H.NodeWithCleanup cleanup spec_trees ->
T.WithResource (T.ResourceSpec (return ()) cleanup) . const <$> test_tree
where
test_tree :: Maybe T.TestTree
test_tree = specTreeToTestTree (H.Node "(unnamed)" spec_trees)
H.Leaf item -> do
guard (hspecItemIsFocused item)
Just (T.singleTest (H.itemRequirement item) (Item item))
newtype Item
= Item (H.Item ())
deriving Typeable
instance T.IsTest Item where
run opts (Item item) progress = do
qc_args <- tastyOptionSetToQuickCheckArgs opts
let
pending_ :: String -> T.Result
pending_ =
case T.lookupOption opts of
Failure ->
T.testFailed
Success ->
T.testPassed
let
params :: H.Params
params = H.Params
{ H.paramsQuickCheckArgs = qc_args
, H.paramsSmallCheckDepth = sc_depth
}
#if MIN_VERSION_hspec(2,4,0) && !MIN_VERSION_hspec(2,5,0)
either handleUncaughtException (hspecResultToTastyResult pending_)
#else
hspecResultToTastyResult pending_
#endif
<$> hspecItemToExample item params ($ ()) hprogress
where
sc_depth :: Int
sc_depth = depth
where
TSC.SmallCheckDepth depth = T.lookupOption opts
hprogress :: H.Progress -> IO ()
hprogress (x,y) = progress T.Progress
{ T.progressText = ""
, T.progressPercent = fromIntegral x / fromIntegral y
}
testOptions = return
[ T.Option (Proxy :: Proxy TreatPendingAs)
, T.Option (Proxy :: Proxy TQC.QuickCheckTests)
, T.Option (Proxy :: Proxy TQC.QuickCheckReplay)
, T.Option (Proxy :: Proxy TQC.QuickCheckMaxSize)
, T.Option (Proxy :: Proxy TQC.QuickCheckMaxRatio)
, T.Option (Proxy :: Proxy TSC.SmallCheckDepth)
]
tastyOptionSetToQuickCheckArgs :: T.OptionSet -> IO QC.Args
tastyOptionSetToQuickCheckArgs opts =
#if MIN_VERSION_tasty_quickcheck(0,9,1)
snd <$> TQC.optionSetToArgs 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 pending_ (H.Result _ result) =
#else
hspecResultToTastyResult pending_ result =
#endif
case result of
H.Success ->
T.testPassed ""
#if MIN_VERSION_hspec(2,5,0)
H.Pending _ x ->
#else
H.Pending x ->
#endif
handleResultPending pending_ x
#if MIN_VERSION_hspec(2,4,0)
H.Failure _ x ->
handleResultFailure 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 =
#if MIN_VERSION_hspec(2,6,0)
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 (H.Item _ _ _ _ ex) = ex
#else
hspecItemToExample (H.Item _ _ _ ex) = ex
#endif
handleResultPending :: (String -> T.Result) -> Maybe String -> T.Result
handleResultPending pending_ x =
pending_ ("# PENDING: " ++ fromMaybe "No reason given" x)
#if MIN_VERSION_hspec(2,4,0)
handleResultFailure :: H.FailureReason -> T.Result
handleResultFailure reason =
case reason of
H.NoReason -> T.testFailed ""
H.Reason x -> T.testFailed x
H.ExpectedButGot preface expected actual ->
T.testFailed . unlines . catMaybes $
[ preface
, Just ("expected: " ++ expected)
, Just (" but got: " ++ actual)
]
#if MIN_VERSION_hspec(2,5,0)
H.Error _ ex ->
handleUncaughtException ex
#endif
#endif
handleUncaughtException :: SomeException -> T.Result
handleUncaughtException ex =
T.testFailed ("uncaught exception: " ++ H.formatException ex)
data TreatPendingAs
= Failure
| Success
instance T.IsOption TreatPendingAs where
defaultValue =
Failure
parseValue s =
case s of
"failure" -> Just Failure
"success" -> Just Success
_ -> Nothing
optionName =
pure "treat-pending-as"
optionHelp =
pure "How to treat pending hspec tests ('failure' or 'success')"