{-# LANGUAGE CPP                #-}
{-# LANGUAGE DeriveDataTypeable #-}

-- | @hspec@ and @tasty@ serve similar purposes; consider using one or the
-- other.
--
-- However, in a pinch, this module allows you to run an @hspec@ 'H.Spec' as a
-- @tasty@ 'T.TestTree'.

module Test.Tasty.Hspec
    ( -- * Tests
      testSpec
    , testSpecs
    -- * Options
    , TreatPendingAs(..)
    -- * Re-exports
    , module Test.Hspec
      -- * Examples
      -- $examples
    ) 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

-- For re-export.
import Test.Hspec

-- $examples
--
-- The simplest usage of this library involves first creating a 'T.TestTree' in
-- @IO@, then running it with 'T.defaultMain'.
--
-- @
-- main = do
--   spec <- 'testSpec' "spec" mySpec
--   'T.defaultMain'
--     ('T.testGroup' "tests"
--       [ spec
--       , ...
--       ])
-- @
--
-- You can treat an 'H.pending'/'H.pendingWith' test as a success instead of a
-- failure (the default):
--
-- @
-- tests :: TestTree
-- tests =
--   localOption TreatPendingAsSuccess $ testGroup "My Hspec TestTree"
--     $ [ unsafePerformIO (testSpec "My first Hspec test" spec_firstHspecTest)
--       , ...
--       ]
-- @
--
-- However, if you don't do any @IO@ during 'Spec' creation, or the @IO@ need
-- not be performed at any particular time relative to other @IO@ actions, it's
-- perfectly fine to use 'System.IO.unsafePerformIO'.
--
-- @
-- main = do
--   'T.defaultMain'
--     ('T.testGroup' "tests"
--       [ 'System.IO.unsafePerformIO' ('testSpec' "spec" mySpec)
--       , ...
--       ])
-- @

-- | Create a <https://hackage.haskell.org/package/tasty tasty> 'T.TestTree' from an
-- <https://hackage.haskell.org/package/hspec Hspec> 'H.Spec'.
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

-- | Create a list of <https://hackage.haskell.org/package/tasty tasty>
-- 'T.TestTree' from an <https://hackage.haskell.org/package/hspec Hspec>
-- 'H.Spec'. This returns the same tests as 'testSpec' but doesn't create
-- a <https://hackage.haskell.org/package/tasty tasty> test group from them.
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
<$>
    -- In hspec 2.6.0, "focus" was introduced. Here we do as hspec does, which
    -- is pre-process a spec by focusing the whole thing, which is a no-op if
    -- anything inside is already focused, but otherwise focuses every item.
    -- Then, when creating a tasty test tree, we just toss the unfocused items.
    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 :: T.OptionSet -> Item -> (T.Progress -> IO ()) -> IO T.Result
  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 [T.OptionDescription]
  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)

-- FailureReason
--
-- - Introduced in 2.4.0
-- - Error constructor added in 2.5.0
#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)

-- | How to treat @hspec@ pending tests.
--
-- @tasty@ does not have the concept of pending tests, so we must map them to
-- either successes or failures. By default, they are treated as failures.
--
-- Set via the command line flag @--treat-pending-as (success|failure)@.
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