{-# 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
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
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
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,
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)
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)
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