{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}

module Test.Syd.Hspec (fromHspec) where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception
import Control.Monad.Writer
import Data.List
import qualified Test.Hspec.Core.Spec as Hspec
import Test.QuickCheck
import Test.Syd as Syd

-- | Import an Hspec 'Test.Hspec.Spec' as a Sydtest 'Test.Syd.Spec'.
--
-- The reasoning behind this function is that, eventhough migration from hspec
-- to sydtest is usually very simple, you might depend on certain libraries
-- beyond your control that still use hspec.  In that case you want to be able
-- to still use those libraries but also use sydtest already.
--
-- For this reason, and because hspec doesn't tell you wether a test is pending
-- until after you run it, pending tests are imported as passing tests.
fromHspec :: Hspec.Spec -> Syd.Spec
fromHspec :: Spec -> Spec
fromHspec Spec
spec = do
  [SpecTree ()]
trees <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Spec -> IO [SpecTree ()]
runSpecM_ Spec
spec
  -- We have to use 'doNotRandomiseExecutionOrder' and 'sequential' because otherwise
  -- passing hspec tests would stop working when imported into sydtest
  forall (a :: [*]) b c. TestDefM a b c -> TestDefM a b c
doNotRandomiseExecutionOrder forall a b. (a -> b) -> a -> b
$ forall (a :: [*]) b c. TestDefM a b c -> TestDefM a b c
sequential forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SpecTree () -> Spec
importSpecTree [SpecTree ()]
trees

runSpecM_ :: Hspec.SpecWith () -> IO [Hspec.SpecTree ()]
#if MIN_VERSION_hspec_core(2,11,0)
runSpecM_ :: Spec -> IO [SpecTree ()]
runSpecM_ = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. SpecWith a -> IO (Endo Config, [SpecTree a])
Hspec.runSpecM
#else
runSpecM_ = Hspec.runSpecM
#endif

-- Hspec.NodeWithCleanup's semantics are so weird that we can only do
-- this translation if inner equals ().
importSpecTree :: Hspec.SpecTree () -> Syd.Spec
importSpecTree :: SpecTree () -> Spec
importSpecTree = SpecTree () -> Spec
go
  where
    go :: Hspec.SpecTree () -> Syd.Spec
    go :: SpecTree () -> Spec
go = \case
      Hspec.Leaf Item ()
item -> forall inner. Item inner -> TestDefM '[] inner ()
importItem Item ()
item
      Hspec.Node String
d [SpecTree ()]
ts -> forall (outers :: [*]) inner.
String -> TestDefM outers inner () -> TestDefM outers inner ()
describe String
d forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SpecTree () -> Spec
go [SpecTree ()]
ts
#if MIN_VERSION_hspec_core(2,11,0)
      Hspec.NodeWithCleanup Maybe (String, Location)
_ IO ()
cleanup [SpecTree ()]
ts -> forall (outers :: [*]) inner result.
IO ()
-> TestDefM outers inner result -> TestDefM outers inner result
afterAll_ IO ()
cleanup (forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SpecTree () -> Spec
go [SpecTree ()]
ts)
#else
#if MIN_VERSION_hspec_core(2,8,0)
      Hspec.NodeWithCleanup _ cleanup ts -> afterAll_ (cleanup ()) (mapM_ go ts)
#else
      Hspec.NodeWithCleanup cleanup ts ->   afterAll_ (cleanup ()) (mapM_ go ts)
#endif
#endif

importItem :: forall inner. Hspec.Item inner -> Syd.TestDefM '[] inner ()
importItem :: forall inner. Item inner -> TestDefM '[] inner ()
importItem item :: Item inner
item@Hspec.Item {Bool
String
Maybe Bool
Maybe Location
Params
-> (ActionWith inner -> IO ()) -> ProgressCallback -> IO Result
itemRequirement :: forall a. Item a -> String
itemLocation :: forall a. Item a -> Maybe Location
itemIsParallelizable :: forall a. Item a -> Maybe Bool
itemIsFocused :: forall a. Item a -> Bool
itemExample :: forall a.
Item a
-> Params
-> (ActionWith a -> IO ())
-> ProgressCallback
-> IO Result
itemExample :: Params
-> (ActionWith inner -> IO ()) -> ProgressCallback -> IO Result
itemIsFocused :: Bool
itemIsParallelizable :: Maybe Bool
itemLocation :: Maybe Location
itemRequirement :: String
..} =
  let parallelMod :: TestDefM '[] inner () -> TestDefM '[] inner ()
parallelMod = case Maybe Bool
itemIsParallelizable of
        Just Bool
True -> forall (a :: [*]) b c. TestDefM a b c -> TestDefM a b c
parallel
        Just Bool
False -> forall (a :: [*]) b c. TestDefM a b c -> TestDefM a b c
sequential
        Maybe Bool
Nothing -> forall a. a -> a
id
   in TestDefM '[] inner () -> TestDefM '[] inner ()
parallelMod forall a b. (a -> b) -> a -> b
$
        forall (outers :: [*]) inner test.
(HasCallStack, IsTest test, Arg1 test ~ (), Arg2 test ~ inner) =>
String -> test -> TestDefM outers inner ()
it String
itemRequirement (forall a. Item a -> ImportedItem a
ImportedItem Item inner
item :: ImportedItem inner)

newtype ImportedItem a = ImportedItem (Hspec.Item a)

instance IsTest (ImportedItem a) where
  type Arg1 (ImportedItem a) = ()
  type Arg2 (ImportedItem a) = a
  runTest :: ImportedItem a
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (ImportedItem a) -> Arg2 (ImportedItem a) -> IO ())
    -> IO ())
-> IO TestRunResult
runTest = forall inner.
ImportedItem inner
-> TestRunSettings
-> ProgressReporter
-> ((() -> inner -> IO ()) -> IO ())
-> IO TestRunResult
runImportedItem

applyWrapper2' ::
  forall r outerArgs innerArg.
  ((outerArgs -> innerArg -> IO ()) -> IO ()) ->
  (outerArgs -> innerArg -> IO r) ->
  IO r
applyWrapper2' :: forall r outerArgs innerArg.
((outerArgs -> innerArg -> IO ()) -> IO ())
-> (outerArgs -> innerArg -> IO r) -> IO r
applyWrapper2' (outerArgs -> innerArg -> IO ()) -> IO ()
wrapper outerArgs -> innerArg -> IO r
func = do
  MVar r
var <- forall a. IO (MVar a)
newEmptyMVar
  (outerArgs -> innerArg -> IO ()) -> IO ()
wrapper forall a b. (a -> b) -> a -> b
$ \outerArgs
outerArgs innerArg
innerArg -> do
    r
res <- outerArgs -> innerArg -> IO r
func outerArgs
outerArgs innerArg
innerArg forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. a -> IO a
evaluate
    forall a. MVar a -> a -> IO ()
putMVar MVar r
var r
res
  forall a. MVar a -> IO a
readMVar MVar r
var

runImportedItem ::
  ImportedItem inner ->
  TestRunSettings ->
  ProgressReporter ->
  ((() -> inner -> IO ()) -> IO ()) ->
  IO TestRunResult
runImportedItem :: forall inner.
ImportedItem inner
-> TestRunSettings
-> ProgressReporter
-> ((() -> inner -> IO ()) -> IO ())
-> IO TestRunResult
runImportedItem (ImportedItem Hspec.Item {Bool
String
Maybe Bool
Maybe Location
Params
-> (ActionWith inner -> IO ()) -> ProgressCallback -> IO Result
itemExample :: Params
-> (ActionWith inner -> IO ()) -> ProgressCallback -> IO Result
itemIsFocused :: Bool
itemIsParallelizable :: Maybe Bool
itemLocation :: Maybe Location
itemRequirement :: String
itemRequirement :: forall a. Item a -> String
itemLocation :: forall a. Item a -> Maybe Location
itemIsParallelizable :: forall a. Item a -> Maybe Bool
itemIsFocused :: forall a. Item a -> Bool
itemExample :: forall a.
Item a
-> Params
-> (ActionWith a -> IO ())
-> ProgressCallback
-> IO Result
..}) TestRunSettings
trs ProgressReporter
progressReporter (() -> ActionWith inner) -> IO ()
wrapper = do
  let report :: ProgressReporter
report = ProgressReporter -> ProgressReporter
reportProgress ProgressReporter
progressReporter
  let qcargs :: Args
qcargs = TestRunSettings -> Args
makeQuickCheckArgs TestRunSettings
trs
  let params :: Hspec.Params
      params :: Params
params =
        Hspec.Params
          { paramsQuickCheckArgs :: Args
Hspec.paramsQuickCheckArgs = Args
qcargs,
            -- TODO use the right depth when sydtest supports smallcheck
            paramsSmallCheckDepth :: Maybe Int
Hspec.paramsSmallCheckDepth = Params -> Maybe Int
Hspec.paramsSmallCheckDepth Params
Hspec.defaultParams
          }
      callback :: Hspec.ProgressCallback
      callback :: ProgressCallback
callback = forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  TVar Word
exampleCounter <- forall a. a -> IO (TVar a)
newTVarIO Word
1
  let totalExamples :: Word
totalExamples = (forall a b. (Integral a, Num b) => a -> b
fromIntegral :: Int -> Word) (Args -> Int
maxSuccess Args
qcargs)
  -- There's no real nice way to do progress reporting here because:
  --   * hspec does not tell us whether we're using a property or not
  --   * we could use the 'callback' above, but then we cannot time the examples.
  --
  -- The tradeoff that we are making is that the output is more verbose:
  -- You'll see 'ProgressExampleStarting' even for unit tests, but at least the
  -- examples in a property test are timed.
  ProgressReporter
report Progress
ProgressTestStarting
  Result
result <-
    Params
-> (ActionWith inner -> IO ()) -> ProgressCallback -> IO Result
itemExample
      Params
params
      ( \ActionWith inner
takeInner -> forall r outerArgs innerArg.
((outerArgs -> innerArg -> IO ()) -> IO ())
-> (outerArgs -> innerArg -> IO r) -> IO r
applyWrapper2' (() -> ActionWith inner) -> IO ()
wrapper forall a b. (a -> b) -> a -> b
$ \() inner
inner -> do
          Word
exampleNr <- forall a. TVar a -> IO a
readTVarIO TVar Word
exampleCounter
          ProgressReporter
report forall a b. (a -> b) -> a -> b
$ Word -> Word -> Progress
ProgressExampleStarting Word
totalExamples Word
exampleNr
          (()
result, Word64
duration) <- forall (m :: * -> *) a. MonadIO m => m a -> m (a, Word64)
timeItDuration forall a b. (a -> b) -> a -> b
$ ActionWith inner
takeInner inner
inner
          ProgressReporter
report forall a b. (a -> b) -> a -> b
$ Word -> Word -> Word64 -> Progress
ProgressExampleDone Word
totalExamples Word
exampleNr Word64
duration
          forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Word
exampleCounter forall a. Enum a => a -> a
succ
          forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
result
      )
      ProgressCallback
callback
  ProgressReporter
report Progress
ProgressTestDone
  let (TestStatus
testRunResultStatus, Maybe SomeException
testRunResultException) = case Result -> ResultStatus
Hspec.resultStatus Result
result of
        ResultStatus
Hspec.Success -> (TestStatus
TestPassed, forall a. Maybe a
Nothing)
        -- This is certainly a debatable choice, but there's no need to make
        -- tests fail here, and there's no way to know ahead of time whether
        -- a test is pending so we have no choice.
        Hspec.Pending Maybe Location
_ Maybe String
_ -> (TestStatus
TestPassed, forall a. Maybe a
Nothing)
        Hspec.Failure Maybe Location
mloc FailureReason
fr ->
          let withExtraContext :: Maybe String -> SomeException -> SomeException
              withExtraContext :: Maybe String -> SomeException -> SomeException
withExtraContext = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (\String
extraContext SomeException
se -> forall e. Exception e => e -> SomeException
SomeException forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String -> Contextual
addContextToException SomeException
se String
extraContext)
              niceLocation :: Hspec.Location -> String
              niceLocation :: Location -> String
niceLocation Hspec.Location {Int
String
locationFile :: Location -> String
locationLine :: Location -> Int
locationColumn :: Location -> Int
locationColumn :: Int
locationLine :: Int
locationFile :: String
..} = forall a. [a] -> [[a]] -> [a]
intercalate String
":" [String
locationFile, forall a. Show a => a -> String
show Int
locationLine, forall a. Show a => a -> String
show Int
locationColumn]
              withLocationContext :: SomeException -> SomeException
              withLocationContext :: SomeException -> SomeException
withLocationContext = Maybe String -> SomeException -> SomeException
withExtraContext forall a b. (a -> b) -> a -> b
$ Location -> String
niceLocation forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Location
mloc
              exception :: SomeException
exception = (Maybe String -> SomeException -> SomeException)
-> FailureReason -> SomeException
failureReasonToException Maybe String -> SomeException -> SomeException
withExtraContext FailureReason
fr
           in ( TestStatus
TestFailed,
                forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
SomeException forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String -> Contextual
addContextToException (SomeException -> SomeException
withLocationContext SomeException
exception) (Result -> String
Hspec.resultInfo Result
result)
              )
  let testRunResultNumTests :: Maybe a
testRunResultNumTests = forall a. Maybe a
Nothing
  let testRunResultNumShrinks :: Maybe a
testRunResultNumShrinks = forall a. Maybe a
Nothing
  let testRunResultGoldenCase :: Maybe a
testRunResultGoldenCase = forall a. Maybe a
Nothing
  let testRunResultFailingInputs :: [a]
testRunResultFailingInputs = []
  let testRunResultExtraInfo :: Maybe a
testRunResultExtraInfo = forall a. Maybe a
Nothing
  let testRunResultLabels :: Maybe a
testRunResultLabels = forall a. Maybe a
Nothing
  let testRunResultClasses :: Maybe a
testRunResultClasses = forall a. Maybe a
Nothing
  let testRunResultTables :: Maybe a
testRunResultTables = forall a. Maybe a
Nothing

  forall (f :: * -> *) a. Applicative f => a -> f a
pure TestRunResult {Maybe SomeException
TestStatus
forall a. [a]
forall a. Maybe a
testRunResultStatus :: TestStatus
testRunResultException :: Maybe SomeException
testRunResultNumTests :: Maybe Word
testRunResultNumShrinks :: Maybe Word
testRunResultFailingInputs :: [String]
testRunResultLabels :: Maybe (Map [String] Int)
testRunResultClasses :: Maybe (Map String Int)
testRunResultTables :: Maybe (Map String (Map String Int))
testRunResultGoldenCase :: Maybe GoldenCase
testRunResultExtraInfo :: Maybe String
testRunResultTables :: forall a. Maybe a
testRunResultClasses :: forall a. Maybe a
testRunResultLabels :: forall a. Maybe a
testRunResultExtraInfo :: forall a. Maybe a
testRunResultFailingInputs :: forall a. [a]
testRunResultGoldenCase :: forall a. Maybe a
testRunResultNumShrinks :: forall a. Maybe a
testRunResultNumTests :: forall a. Maybe a
testRunResultException :: Maybe SomeException
testRunResultStatus :: TestStatus
..}

failureReasonToException :: (Maybe String -> SomeException -> SomeException) -> Hspec.FailureReason -> SomeException
failureReasonToException :: (Maybe String -> SomeException -> SomeException)
-> FailureReason -> SomeException
failureReasonToException Maybe String -> SomeException -> SomeException
withExtraContext = \case
  FailureReason
Hspec.NoReason -> forall e. Exception e => e -> SomeException
SomeException forall a b. (a -> b) -> a -> b
$ String -> Assertion
ExpectationFailed String
"Hspec had no more information about this failure."
  Hspec.Reason String
s -> forall e. Exception e => e -> SomeException
SomeException forall a b. (a -> b) -> a -> b
$ String -> Assertion
ExpectationFailed String
s
  Hspec.ExpectedButGot Maybe String
mExtraContext String
expected String
actual -> Maybe String -> SomeException -> SomeException
withExtraContext Maybe String
mExtraContext forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> SomeException
SomeException forall a b. (a -> b) -> a -> b
$ String -> String -> Assertion
NotEqualButShouldHaveBeenEqual String
actual String
expected
  Hspec.Error Maybe String
mExtraContext SomeException
e -> Maybe String -> SomeException -> SomeException
withExtraContext Maybe String
mExtraContext SomeException
e
#if MIN_VERSION_hspec_core(2,11,0)
  Hspec.ColorizedReason String
s -> forall e. Exception e => e -> SomeException
SomeException forall a b. (a -> b) -> a -> b
$ String -> Assertion
ExpectationFailed String
s
#endif