{-# LANGUAGE CPP #-}

-- | @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 (..),

    -- * Examples
    -- $examples
  )
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

-- $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)
--     , ...
--     ]
-- @
--
-- 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 = 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)

-- | 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 = do
  -- 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.
  [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)
      ]

-- | 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
  = -- | Default.
    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