{-# 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 (Hspec.SpecM WriterT [SpecTree ()] IO ()
specWriter) = do
  (()
result, [SpecTree ()]
trees) <- IO ((), [SpecTree ()]) -> TestDefM '[] () ((), [SpecTree ()])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ((), [SpecTree ()]) -> TestDefM '[] () ((), [SpecTree ()]))
-> IO ((), [SpecTree ()]) -> TestDefM '[] () ((), [SpecTree ()])
forall a b. (a -> b) -> a -> b
$ WriterT [SpecTree ()] IO () -> IO ((), [SpecTree ()])
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT WriterT [SpecTree ()] IO ()
specWriter
  -- We have to use 'doNotRandomiseExecutionOrder' and 'sequential' because otherwise
  -- passing hspec tests would stop working when imported into sydtest
  Spec -> Spec
forall (a :: [*]) b c. TestDefM a b c -> TestDefM a b c
doNotRandomiseExecutionOrder (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ Spec -> Spec
forall (a :: [*]) b c. TestDefM a b c -> TestDefM a b c
sequential (Spec -> Spec) -> Spec -> Spec
forall a b. (a -> b) -> a -> b
$ (SpecTree () -> Spec) -> [SpecTree ()] -> Spec
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SpecTree () -> Spec
importSpecTree [SpecTree ()]
trees
  () -> Spec
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
result

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

importItem :: forall inner. Hspec.Item inner -> Syd.TestDefM '[] inner ()
importItem :: 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 -> TestDefM '[] inner () -> TestDefM '[] inner ()
forall (a :: [*]) b c. TestDefM a b c -> TestDefM a b c
parallel
        Just Bool
False -> TestDefM '[] inner () -> TestDefM '[] inner ()
forall (a :: [*]) b c. TestDefM a b c -> TestDefM a b c
sequential
        Maybe Bool
Nothing -> TestDefM '[] inner () -> TestDefM '[] inner ()
forall a. a -> a
id
   in TestDefM '[] inner () -> TestDefM '[] inner ()
parallelMod (TestDefM '[] inner () -> TestDefM '[] inner ())
-> TestDefM '[] inner () -> TestDefM '[] inner ()
forall a b. (a -> b) -> a -> b
$
        String -> ImportedItem inner -> TestDefM '[] inner ()
forall (outers :: [*]) inner test.
(HasCallStack, IsTest test, Arg1 test ~ (), Arg2 test ~ inner) =>
String -> test -> TestDefM outers inner ()
it String
itemRequirement (Item inner -> ImportedItem inner
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 = ImportedItem a
-> TestRunSettings
-> ProgressReporter
-> ((Arg1 (ImportedItem a) -> Arg2 (ImportedItem a) -> IO ())
    -> IO ())
-> IO TestRunResult
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' :: ((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 <- IO (MVar r)
forall a. IO (MVar a)
newEmptyMVar
  (outerArgs -> innerArg -> IO ()) -> IO ()
wrapper ((outerArgs -> innerArg -> IO ()) -> IO ())
-> (outerArgs -> innerArg -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \outerArgs
outerArgs innerArg
innerArg -> do
    r
res <- outerArgs -> innerArg -> IO r
func outerArgs
outerArgs innerArg
innerArg IO r -> (r -> IO r) -> IO r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= r -> IO r
forall a. a -> IO a
evaluate
    MVar r -> r -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar r
var r
res
  MVar r -> IO r
forall a. MVar a -> IO a
readMVar MVar r
var

runImportedItem ::
  ImportedItem inner ->
  TestRunSettings ->
  ProgressReporter ->
  ((() -> inner -> IO ()) -> IO ()) ->
  IO TestRunResult
runImportedItem :: ImportedItem inner
-> TestRunSettings
-> ProgressReporter
-> ((() -> inner -> IO ()) -> IO ())
-> IO TestRunResult
runImportedItem (ImportedItem Hspec.Item {Bool
String
Maybe Bool
Maybe Location
Params
-> ((inner -> IO ()) -> IO ()) -> ProgressCallback -> IO Result
itemExample :: Params
-> ((inner -> IO ()) -> 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 (() -> inner -> IO ()) -> 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 =
        Params :: Args -> Int -> Params
Hspec.Params
          { paramsQuickCheckArgs :: Args
Hspec.paramsQuickCheckArgs = Args
qcargs,
            -- TODO use the right depth when sydtest supports smallcheck
            paramsSmallCheckDepth :: Int
Hspec.paramsSmallCheckDepth = Params -> Int
Hspec.paramsSmallCheckDepth Params
Hspec.defaultParams
          }
      callback :: Hspec.ProgressCallback
      callback :: ProgressCallback
callback = IO () -> ProgressCallback
forall a b. a -> b -> a
const (IO () -> ProgressCallback) -> IO () -> ProgressCallback
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  TVar Word
exampleCounter <- Word -> IO (TVar Word)
forall a. a -> IO (TVar a)
newTVarIO Word
1
  let totalExamples :: Word
totalExamples = (Int -> Word
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
-> ((inner -> IO ()) -> IO ()) -> ProgressCallback -> IO Result
itemExample
      Params
params
      ( \inner -> IO ()
takeInner -> ((() -> inner -> IO ()) -> IO ())
-> (() -> inner -> IO ()) -> IO ()
forall r outerArgs innerArg.
((outerArgs -> innerArg -> IO ()) -> IO ())
-> (outerArgs -> innerArg -> IO r) -> IO r
applyWrapper2' (() -> inner -> IO ()) -> IO ()
wrapper ((() -> inner -> IO ()) -> IO ())
-> (() -> inner -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \() inner
inner -> do
          Word
exampleNr <- TVar Word -> IO Word
forall a. TVar a -> IO a
readTVarIO TVar Word
exampleCounter
          ProgressReporter
report ProgressReporter -> ProgressReporter
forall a b. (a -> b) -> a -> b
$ Word -> Word -> Progress
ProgressExampleStarting Word
totalExamples Word
exampleNr
          Timed ()
timedResult <- IO () -> IO (Timed ())
forall (m :: * -> *) a. MonadIO m => m a -> m (Timed a)
timeItT (IO () -> IO (Timed ())) -> IO () -> IO (Timed ())
forall a b. (a -> b) -> a -> b
$ inner -> IO ()
takeInner inner
inner
          ProgressReporter
report ProgressReporter -> ProgressReporter
forall a b. (a -> b) -> a -> b
$ Word -> Word -> Word64 -> Progress
ProgressExampleDone Word
totalExamples Word
exampleNr (Word64 -> Progress) -> Word64 -> Progress
forall a b. (a -> b) -> a -> b
$ Timed () -> Word64
forall a. Timed a -> Word64
timedTime Timed ()
timedResult
          STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Word -> (Word -> Word) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Word
exampleCounter Word -> Word
forall a. Enum a => a -> a
succ
          () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ Timed () -> ()
forall a. Timed a -> a
timedValue Timed ()
timedResult
      )
      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, Maybe SomeException
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, Maybe SomeException
forall a. Maybe a
Nothing)
        Hspec.Failure Maybe Location
mloc FailureReason
fr ->
          let withExtraContext :: Maybe String -> SomeException -> SomeException
              withExtraContext :: Maybe String -> SomeException -> SomeException
withExtraContext = (SomeException -> SomeException)
-> (String -> SomeException -> SomeException)
-> Maybe String
-> SomeException
-> SomeException
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SomeException -> SomeException
forall a. a -> a
id (\String
extraContext SomeException
se -> Contextual -> SomeException
forall e. Exception e => e -> SomeException
SomeException (Contextual -> SomeException) -> Contextual -> SomeException
forall a b. (a -> b) -> a -> b
$ SomeException -> String -> Contextual
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
..} = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
":" [String
locationFile, Int -> String
forall a. Show a => a -> String
show Int
locationLine, Int -> String
forall a. Show a => a -> String
show Int
locationColumn]
              withLocationContext :: SomeException -> SomeException
              withLocationContext :: SomeException -> SomeException
withLocationContext = Maybe String -> SomeException -> SomeException
withExtraContext (Maybe String -> SomeException -> SomeException)
-> Maybe String -> SomeException -> SomeException
forall a b. (a -> b) -> a -> b
$ Location -> String
niceLocation (Location -> String) -> Maybe Location -> Maybe String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Location
mloc
              exception :: SomeException
              exception :: SomeException
exception = case FailureReason
fr of
                FailureReason
Hspec.NoReason -> Assertion -> SomeException
forall e. Exception e => e -> SomeException
SomeException (Assertion -> SomeException) -> Assertion -> SomeException
forall a b. (a -> b) -> a -> b
$ String -> Assertion
ExpectationFailed String
"Hspec had no more information about this failure."
                Hspec.Reason String
s -> Assertion -> SomeException
forall e. Exception e => e -> SomeException
SomeException (Assertion -> SomeException) -> Assertion -> 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 (SomeException -> SomeException) -> SomeException -> SomeException
forall a b. (a -> b) -> a -> b
$ Assertion -> SomeException
forall e. Exception e => e -> SomeException
SomeException (Assertion -> SomeException) -> Assertion -> 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
           in ( TestStatus
TestFailed,
                SomeException -> Maybe SomeException
forall a. a -> Maybe a
Just (SomeException -> Maybe SomeException)
-> SomeException -> Maybe SomeException
forall a b. (a -> b) -> a -> b
$ Contextual -> SomeException
forall e. Exception e => e -> SomeException
SomeException (Contextual -> SomeException) -> Contextual -> SomeException
forall a b. (a -> b) -> a -> b
$ SomeException -> String -> Contextual
forall e. Exception e => e -> String -> Contextual
addContextToException (SomeException -> SomeException
withLocationContext SomeException
exception) (Result -> String
Hspec.resultInfo Result
result)
              )
  let testRunResultNumTests :: Maybe a
testRunResultNumTests = Maybe a
forall a. Maybe a
Nothing
  let testRunResultNumShrinks :: Maybe a
testRunResultNumShrinks = Maybe a
forall a. Maybe a
Nothing
  let testRunResultRetries :: Maybe a
testRunResultRetries = Maybe a
forall a. Maybe a
Nothing
  let testRunResultGoldenCase :: Maybe a
testRunResultGoldenCase = Maybe a
forall a. Maybe a
Nothing
  let testRunResultFailingInputs :: [a]
testRunResultFailingInputs = []
  let testRunResultExtraInfo :: Maybe a
testRunResultExtraInfo = Maybe a
forall a. Maybe a
Nothing
  let testRunResultLabels :: Maybe a
testRunResultLabels = Maybe a
forall a. Maybe a
Nothing
  let testRunResultClasses :: Maybe a
testRunResultClasses = Maybe a
forall a. Maybe a
Nothing
  let testRunResultTables :: Maybe a
testRunResultTables = Maybe a
forall a. Maybe a
Nothing
  let testRunResultFlakinessMessage :: Maybe a
testRunResultFlakinessMessage = Maybe a
forall a. Maybe a
Nothing

  TestRunResult -> IO TestRunResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestRunResult :: TestStatus
-> Maybe Int
-> Maybe SomeException
-> Maybe Word
-> Maybe Word
-> [String]
-> Maybe (Map [String] Int)
-> Maybe (Map String Int)
-> Maybe (Map String (Map String Int))
-> Maybe GoldenCase
-> Maybe String
-> Maybe String
-> TestRunResult
TestRunResult {[String]
Maybe Int
Maybe String
Maybe Word
Maybe (Map String Int)
Maybe (Map String (Map String Int))
Maybe (Map [String] Int)
Maybe SomeException
Maybe GoldenCase
TestStatus
forall a. [a]
forall a. Maybe a
testRunResultStatus :: TestStatus
testRunResultRetries :: Maybe Int
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
testRunResultFlakinessMessage :: Maybe String
testRunResultFlakinessMessage :: forall a. Maybe a
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
testRunResultRetries :: forall a. Maybe a
testRunResultNumShrinks :: forall a. Maybe a
testRunResultNumTests :: forall a. Maybe a
testRunResultException :: Maybe SomeException
testRunResultStatus :: TestStatus
..}