{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoFieldSelectors #-}

module Skeletest.Internal.Spec (
  -- * Spec interface
  X.Spec,
  X.SpecM,
  X.SpecTree (..),

  -- ** Execution
  SpecRunner,
  newSpecRunner,

  -- ** Entrypoint
  X.SpecRegistry,
  X.SpecInfo (..),

  -- ** Defining a Spec
  X.describe,
  X.Testable (..),
  X.test,
  X.it,

  -- ** Modifiers
  X.xfail,
  X.skip,
  X.focus,
  X.markManual,

  -- ** Markers
  X.IsMarker (..),
  X.withMarkers,
  X.withMarker,

  -- ** Runtime functionality
  skipTest,

  -- ** Plugin
  specTreePlugin,
) where

import Control.Concurrent (myThreadId)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Trans.State.Strict qualified as State
import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Time (NominalDiffTime)
import GHC.Records (HasField (..))
import Skeletest.Internal.Error (SkeletestError (..))
import Skeletest.Internal.Exit (TestExitCode (..))
import Skeletest.Internal.Fixtures (FixtureScopeKey (..), cleanupFixtures)
import Skeletest.Internal.Hooks (
  ModifyTestSummaryHookContext (..),
  OnTestFailureHookContext (..),
  RunTestHookContext (..),
  userHooks,
 )
import Skeletest.Internal.Hooks qualified as Hooks
import Skeletest.Internal.Markers (
  findMarker,
 )
import Skeletest.Internal.Spec.TestReporter (
  TestReporter,
  newTestReporter,
 )
import Skeletest.Internal.Spec.Tree (
  MarkerFocus (..),
  MarkerManual (..),
  MarkerSkip (..),
  MarkerXFail (..),
  SpecInfo (..),
  SpecRegistry,
  SpecTest (..),
  SpecTree (..),
  applyTestSelections,
  getSpecTrees,
  mapSpecs,
  pruneSpec,
  traverseSpecTests,
  traverseSpecs,
 )
import Skeletest.Internal.Spec.Tree qualified as X
import Skeletest.Internal.TestInfo (TestInfo (TestInfo), withTestInfo)
import Skeletest.Internal.TestInfo qualified as TestInfo
import Skeletest.Internal.TestRunner (
  TestResult (..),
  TestResultMessage (..),
  TestResultStatus (..),
  testResultFromAssertionFail,
  testResultFromError,
 )
import Skeletest.Internal.Utils.Color qualified as Color
import Skeletest.Internal.Utils.Term qualified as Term
import Skeletest.Internal.Utils.Text (pluralize)
import Skeletest.Internal.Utils.Timer (renderDuration, withTimer)
import Skeletest.Plugin (Hooks (..), Plugin (..), defaultHooks, defaultPlugin, filterSpecTests, hasMarker)
import Skeletest.Plugin qualified as Plugin
import UnliftIO.Exception (
  catch,
  finally,
  fromException,
  throwIO,
 )

{----- Execute spec -----}

data SpecRunner = SpecRunner
  { SpecRunner -> TestSummary
testSummary :: TestSummary
  , SpecRunner -> TestReporter
testReporter :: TestReporter
  }

newSpecRunner :: SpecRegistry -> IO SpecRunner
newSpecRunner :: SpecRegistry -> IO SpecRunner
newSpecRunner SpecRegistry
initialSpecs = do
  TestSummary
testSummary <- SpecRegistry -> IO TestSummary
newTestSummary SpecRegistry
initialSpecs
  TestReporter
testReporter <- IO TestReporter
newTestReporter
  SpecRunner -> IO SpecRunner
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    SpecRunner
      { TestSummary
testSummary :: TestSummary
testSummary :: TestSummary
testSummary
      , TestReporter
testReporter :: TestReporter
testReporter :: TestReporter
testReporter
      }

instance HasField "run" SpecRunner (SpecRegistry -> IO TestExitCode) where
  getField :: SpecRunner -> SpecRegistry -> IO TestExitCode
getField SpecRunner
runner SpecRegistry
specs = IO TestExitCode -> IO TestExitCode
forall {b}. IO b -> IO b
withTestSummary (IO TestExitCode -> IO TestExitCode)
-> IO TestExitCode -> IO TestExitCode
forall a b. (a -> b) -> a -> b
$ do
    (IO TestExitCode -> IO () -> IO TestExitCode
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` FixtureScopeKey -> IO ()
cleanupFixtures FixtureScopeKey
PerSessionFixtureKey) (IO TestExitCode -> IO TestExitCode)
-> IO TestExitCode -> IO TestExitCode
forall a b. (a -> b) -> a -> b
$
      [TestExitCode] -> TestExitCode
resolveExitCode ([TestExitCode] -> TestExitCode)
-> IO [TestExitCode] -> IO TestExitCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (SpecInfo -> IO TestExitCode) -> SpecRegistry -> IO [TestExitCode]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM SpecRunner
runner.runFile (SpecRegistry -> SpecRegistry
pruneSpec SpecRegistry
specs)
   where
    withTestSummary :: IO b -> IO b
withTestSummary IO b
action = do
      SpecRunner
runner.testSummary.update ((TestSummaryData -> TestSummaryData) -> IO ())
-> (TestSummaryData -> TestSummaryData) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TestSummaryData
d -> TestSummaryData
d{testsSelected = getTotalTests specs}
      TestSummary -> IO b -> IO b
forall a. TestSummary -> IO a -> IO a
recordDuration SpecRunner
runner.testSummary IO b
action

instance HasField "runFile" SpecRunner (SpecInfo -> IO TestExitCode) where
  getField :: SpecRunner -> SpecInfo -> IO TestExitCode
getField SpecRunner
runner SpecInfo
info = do
    (IO TestExitCode -> IO () -> IO TestExitCode
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` FixtureScopeKey -> IO ()
cleanupFixtures (FilePath -> FixtureScopeKey
PerFileFixtureKey SpecInfo
info.specPath)) (IO TestExitCode -> IO TestExitCode)
-> IO TestExitCode -> IO TestExitCode
forall a b. (a -> b) -> a -> b
$ do
      SpecRunner
runner.testReporter.reportFilePre SpecInfo
info.specPath
      (TestExitCode
code, NominalDiffTime
duration) <- IO TestExitCode -> IO (TestExitCode, NominalDiffTime)
forall a. IO a -> IO (a, NominalDiffTime)
withTimer (IO TestExitCode -> IO (TestExitCode, NominalDiffTime))
-> IO TestExitCode -> IO (TestExitCode, NominalDiffTime)
forall a b. (a -> b) -> a -> b
$ SpecRunner
runner.runTrees TestInfo
emptyTestInfo [SpecTree]
trees
      SpecRunner
runner.testReporter.reportFilePost SpecInfo
info.specPath (TestExitCode
code, NominalDiffTime
duration)
      TestExitCode -> IO TestExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestExitCode
code
   where
    trees :: [SpecTree]
trees = Spec -> [SpecTree]
getSpecTrees SpecInfo
info.spec
    emptyTestInfo :: TestInfo
emptyTestInfo =
      TestInfo
        { contexts :: [Text]
contexts = []
        , name :: Text
name = Text
""
        , markers :: [SomeMarker]
markers = []
        , file :: FilePath
file = SpecInfo
info.specPath
        }

instance HasField "runTrees" SpecRunner (TestInfo -> [SpecTree] -> IO TestExitCode) where
  getField :: SpecRunner -> TestInfo -> [SpecTree] -> IO TestExitCode
getField SpecRunner
runner TestInfo
testInfo = ([TestExitCode] -> TestExitCode)
-> IO [TestExitCode] -> IO TestExitCode
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [TestExitCode] -> TestExitCode
resolveExitCode (IO [TestExitCode] -> IO TestExitCode)
-> ([SpecTree] -> IO [TestExitCode])
-> [SpecTree]
-> IO TestExitCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpecTree -> IO TestExitCode) -> [SpecTree] -> IO [TestExitCode]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM SpecTree -> IO TestExitCode
runTree
   where
    runTree :: SpecTree -> IO TestExitCode
runTree = \case
      SpecTree_Group{Text
label :: Text
label :: SpecTree -> Text
label, [SpecTree]
trees :: [SpecTree]
trees :: SpecTree -> [SpecTree]
trees} -> SpecRunner
runner.runGroup TestInfo
testInfo Text
label [SpecTree]
trees
      SpecTree_Test SpecTest
test ->
        SpecRunner
runner.runTest
          TestInfo
testInfo
            { TestInfo.name = test.name
            , TestInfo.markers = test.markers
            }
          SpecTest
test

instance HasField "runGroup" SpecRunner (TestInfo -> Text -> [SpecTree] -> IO TestExitCode) where
  getField :: SpecRunner -> TestInfo -> Text -> [SpecTree] -> IO TestExitCode
getField SpecRunner
runner TestInfo
testInfo Text
label [SpecTree]
trees = do
    SpecRunner
runner.testReporter.reportGroupPre TestInfo
testInfo Text
label
    (TestExitCode
code, NominalDiffTime
duration) <- IO TestExitCode -> IO (TestExitCode, NominalDiffTime)
forall a. IO a -> IO (a, NominalDiffTime)
withTimer (IO TestExitCode -> IO (TestExitCode, NominalDiffTime))
-> IO TestExitCode -> IO (TestExitCode, NominalDiffTime)
forall a b. (a -> b) -> a -> b
$ SpecRunner
runner.runTrees TestInfo
testInfo' [SpecTree]
trees
    SpecRunner
runner.testReporter.reportGroupPost TestInfo
testInfo Text
label (TestExitCode
code, NominalDiffTime
duration)
    TestExitCode -> IO TestExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestExitCode
code
   where
    testInfo' :: TestInfo
testInfo' = TestInfo
testInfo{TestInfo.contexts = testInfo.contexts <> [label]}

instance HasField "runTest" SpecRunner (TestInfo -> SpecTest -> IO TestExitCode) where
  getField :: SpecRunner -> TestInfo -> SpecTest -> IO TestExitCode
getField SpecRunner
runner TestInfo
testInfo SpecTest
test = TestInfo -> IO TestExitCode -> IO TestExitCode
forall (m :: * -> *) a. MonadUnliftIO m => TestInfo -> m a -> m a
withTestInfo TestInfo
testInfo (IO TestExitCode -> IO TestExitCode)
-> IO TestExitCode -> IO TestExitCode
forall a b. (a -> b) -> a -> b
$ do
    SpecRunner
runner.testReporter.reportTestPre TestInfo
testInfo
    ThreadId
tid <- IO ThreadId
myThreadId
    (TestResult
result, NominalDiffTime
duration) <-
      (IO (TestResult, NominalDiffTime)
-> IO () -> IO (TestResult, NominalDiffTime)
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` FixtureScopeKey -> IO ()
cleanupFixtures (ThreadId -> FixtureScopeKey
PerTestFixtureKey ThreadId
tid)) (IO (TestResult, NominalDiffTime)
 -> IO (TestResult, NominalDiffTime))
-> IO (TestResult, NominalDiffTime)
-> IO (TestResult, NominalDiffTime)
forall a b. (a -> b) -> a -> b
$ do
        IO TestResult -> IO (TestResult, NominalDiffTime)
forall a. IO a -> IO (a, NominalDiffTime)
withTimer (IO TestResult -> IO (TestResult, NominalDiffTime))
-> (IO TestResult -> IO TestResult)
-> IO TestResult
-> IO (TestResult, NominalDiffTime)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO TestResult -> IO TestResult
runTestHook (IO TestResult -> IO (TestResult, NominalDiffTime))
-> IO TestResult -> IO (TestResult, NominalDiffTime)
forall a b. (a -> b) -> a -> b
$ SpecTest
test.action IO TestResult -> (SomeException -> IO TestResult) -> IO TestResult
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` (SomeException -> IO TestResult) -> SomeException -> IO TestResult
onTestFailureHook SomeException -> IO TestResult
mkTestResultError
    SpecRunner
runner.testReporter.reportTestPost TestInfo
testInfo (TestResult
result, NominalDiffTime
duration)

    SpecRunner
runner.testSummary.update ((TestSummaryData -> TestSummaryData) -> IO ())
-> (TestSummaryData -> TestSummaryData) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TestSummaryData
d ->
      TestSummaryData
d
        { testCategories =
            Map.alter
              (Just . (+ 1) . fromMaybe 0)
              result.status
              d.testCategories
        }

    TestExitCode -> IO TestExitCode
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestExitCode -> IO TestExitCode)
-> TestExitCode -> IO TestExitCode
forall a b. (a -> b) -> a -> b
$ if TestResult
result.status.success then TestExitCode
ExitSuccess else TestExitCode
ExitTestFailure
   where
    runTestHook :: IO TestResult -> IO TestResult
runTestHook IO TestResult
action =
      let ctx :: RunTestHookContext
ctx =
            RunTestHookContext
              { TestInfo
testInfo :: TestInfo
testInfo :: TestInfo
testInfo
              }
       in UserHooks
userHooks.runTest RunTestHookContext
ctx () ((() -> IO TestResult) -> IO TestResult)
-> (() -> IO TestResult) -> IO TestResult
forall a b. (a -> b) -> a -> b
$ \() -> IO TestResult
action
    onTestFailureHook :: (SomeException -> IO TestResult) -> SomeException -> IO TestResult
onTestFailureHook SomeException -> IO TestResult
action SomeException
e =
      let ctx :: OnTestFailureHookContext
ctx =
            OnTestFailureHookContext
              { TestInfo
testInfo :: TestInfo
testInfo :: TestInfo
testInfo
              }
       in UserHooks
userHooks.onTestFailure OnTestFailureHookContext
ctx SomeException
e SomeException -> IO TestResult
action
    mkTestResultError :: SomeException -> IO TestResult
mkTestResultError SomeException
e =
      case SomeException -> Maybe AssertionFail
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
        Just AssertionFail
e' -> AssertionFail -> IO TestResult
testResultFromAssertionFail AssertionFail
e'
        Maybe AssertionFail
Nothing -> SomeException -> IO TestResult
testResultFromError SomeException
e

instance HasField "printSummary" SpecRunner (IO ()) where
  getField :: SpecRunner -> IO ()
getField SpecRunner
runner = do
    Text
summary0 <- SpecRunner
runner.testSummary.render
    Text
summary <-
      UserHooks
userHooks.modifyTestSummary
        ModifyTestSummaryHookContext
ModifyTestSummaryHookContext
        Text
summary0
        Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    Text -> IO ()
Term.output Text
""
    Text -> IO ()
Term.outputN (Text -> IO ()) -> (Text -> Text) -> Text -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
colorize (Text -> Text) -> (Text -> Text) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
Text.strip (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
summary
   where
    colorize :: Text -> Text
colorize = [Text] -> Text
Text.unlines ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
Color.yellow ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
Text.lines

-- | Resolve the given exit codes, returning the first non-success code.
resolveExitCode :: [TestExitCode] -> TestExitCode
resolveExitCode :: [TestExitCode] -> TestExitCode
resolveExitCode = [TestExitCode] -> TestExitCode
go
 where
  go :: [TestExitCode] -> TestExitCode
go = \case
    [] -> TestExitCode
ExitSuccess
    TestExitCode
ExitSuccess : [TestExitCode]
rest -> [TestExitCode] -> TestExitCode
go [TestExitCode]
rest
    TestExitCode
code : [TestExitCode]
_ -> TestExitCode
code

{----- Test summary -----}

newtype TestSummary = TestSummary (IORef TestSummaryData)

data TestSummaryData = TestSummaryData
  { TestSummaryData -> Int
totalTests :: !Int
  , TestSummaryData -> Int
testsSelected :: !Int
  , TestSummaryData -> Map TestResultStatus Int
testCategories :: !(Map TestResultStatus Int)
  , TestSummaryData -> Int
snapshotsUpdated :: !Int
  , TestSummaryData -> NominalDiffTime
totalDuration :: !NominalDiffTime
  }

newTestSummary :: SpecRegistry -> IO TestSummary
newTestSummary :: SpecRegistry -> IO TestSummary
newTestSummary SpecRegistry
specs = do
  (IORef TestSummaryData -> TestSummary)
-> IO (IORef TestSummaryData) -> IO TestSummary
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IORef TestSummaryData -> TestSummary
TestSummary (IO (IORef TestSummaryData) -> IO TestSummary)
-> (TestSummaryData -> IO (IORef TestSummaryData))
-> TestSummaryData
-> IO TestSummary
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestSummaryData -> IO (IORef TestSummaryData)
forall a. a -> IO (IORef a)
newIORef (TestSummaryData -> IO TestSummary)
-> TestSummaryData -> IO TestSummary
forall a b. (a -> b) -> a -> b
$
    TestSummaryData
      { totalTests :: Int
totalTests = SpecRegistry -> Int
getTotalTests SpecRegistry
specs
      , testsSelected :: Int
testsSelected = Int
0
      , testCategories :: Map TestResultStatus Int
testCategories = Map TestResultStatus Int
forall k a. Map k a
Map.empty
      , snapshotsUpdated :: Int
snapshotsUpdated = Int
0
      , totalDuration :: NominalDiffTime
totalDuration = NominalDiffTime
0
      }

getTotalTests :: SpecRegistry -> Int
getTotalTests :: SpecRegistry -> Int
getTotalTests SpecRegistry
specs = State Int SpecRegistry -> Int -> Int
forall s a. State s a -> s -> s
State.execState (SpecRegistry -> State Int SpecRegistry
count SpecRegistry
specs) Int
0
 where
  count :: SpecRegistry -> State Int SpecRegistry
count = (Spec -> StateT Int Identity Spec)
-> SpecRegistry -> State Int SpecRegistry
forall (f :: * -> *).
Applicative f =>
(Spec -> f Spec) -> SpecRegistry -> f SpecRegistry
traverseSpecs ((Spec -> StateT Int Identity Spec)
 -> SpecRegistry -> State Int SpecRegistry)
-> ((SpecTest -> StateT Int Identity SpecTest)
    -> Spec -> StateT Int Identity Spec)
-> (SpecTest -> StateT Int Identity SpecTest)
-> SpecRegistry
-> State Int SpecRegistry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpecTest -> StateT Int Identity SpecTest)
-> Spec -> StateT Int Identity Spec
forall (m :: * -> *).
Monad m =>
(SpecTest -> m SpecTest) -> Spec -> m Spec
traverseSpecTests ((SpecTest -> StateT Int Identity SpecTest)
 -> SpecRegistry -> State Int SpecRegistry)
-> (SpecTest -> StateT Int Identity SpecTest)
-> SpecRegistry
-> State Int SpecRegistry
forall a b. (a -> b) -> a -> b
$ \SpecTest
x -> (Int -> Int) -> StateT Int Identity ()
forall (m :: * -> *) s. Monad m => (s -> s) -> StateT s m ()
State.modify (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) StateT Int Identity ()
-> StateT Int Identity SpecTest -> StateT Int Identity SpecTest
forall a b.
StateT Int Identity a
-> StateT Int Identity b -> StateT Int Identity b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> SpecTest -> StateT Int Identity SpecTest
forall a. a -> StateT Int Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpecTest
x

recordDuration :: TestSummary -> IO a -> IO a
recordDuration :: forall a. TestSummary -> IO a -> IO a
recordDuration (TestSummary IORef TestSummaryData
ref) IO a
m = do
  (a
a, NominalDiffTime
duration) <- IO a -> IO (a, NominalDiffTime)
forall a. IO a -> IO (a, NominalDiffTime)
withTimer IO a
m
  IORef TestSummaryData
-> (TestSummaryData -> TestSummaryData) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef TestSummaryData
ref ((TestSummaryData -> TestSummaryData) -> IO ())
-> (TestSummaryData -> TestSummaryData) -> IO ()
forall a b. (a -> b) -> a -> b
$ \TestSummaryData
d -> TestSummaryData
d{totalDuration = duration}
  a -> IO a
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

instance HasField "update" TestSummary ((TestSummaryData -> TestSummaryData) -> IO ()) where
  getField :: TestSummary -> (TestSummaryData -> TestSummaryData) -> IO ()
getField (TestSummary IORef TestSummaryData
ref) = IORef TestSummaryData
-> (TestSummaryData -> TestSummaryData) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef TestSummaryData
ref
instance HasField "render" TestSummary (IO Text) where
  getField :: TestSummary -> IO Text
getField (TestSummary IORef TestSummaryData
ref) = do
    TestSummaryData{Int
Map TestResultStatus Int
NominalDiffTime
testsSelected :: TestSummaryData -> Int
testCategories :: TestSummaryData -> Map TestResultStatus Int
totalTests :: TestSummaryData -> Int
snapshotsUpdated :: TestSummaryData -> Int
totalDuration :: TestSummaryData -> NominalDiffTime
totalTests :: Int
testsSelected :: Int
testCategories :: Map TestResultStatus Int
snapshotsUpdated :: Int
totalDuration :: NominalDiffTime
..} <- IORef TestSummaryData -> IO TestSummaryData
forall a. IORef a -> IO a
readIORef IORef TestSummaryData
ref
    let testsDeselected :: Int
testsDeselected = Int
totalTests Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
testsSelected
    Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> IO Text) -> ([[Text]] -> Text) -> [[Text]] -> IO Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
Text.unlines ([Text] -> Text) -> ([[Text]] -> [Text]) -> [[Text]] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [[Text]] -> [Text]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[Text]] -> IO Text) -> [[Text]] -> IO Text
forall a b. (a -> b) -> a -> b
$
      [ [Text
"═════ Test report ═════"]
      , [Text
"➤ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
forall a. (Num a, Eq a, Show a) => a -> Text -> Text
pluralize Int
testsSelected Text
"test" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" ran in " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> NominalDiffTime -> Text
renderDuration NominalDiffTime
totalDuration]
      , [ Text
"  • " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
forall a. (Num a, Eq a, Show a) => a -> Text -> Text
pluralize Int
count Text
"test" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> TestResultStatus
status.name Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
icon
        | (TestResultStatus
status, Int
count) <- Map TestResultStatus Int -> [(TestResultStatus, Int)]
forall k a. Map k a -> [(k, a)]
Map.toAscList Map TestResultStatus Int
testCategories
        , let icon :: Text
icon =
                case TestResultStatus
status of
                  TestResultStatus
TestPassed -> Text -> Text
Color.green Text
"✔"
                  TestResultStatus
TestFailed -> Text -> Text
Color.red Text
"✘"
                  TestResultStatus
TestSkipped -> Text -> Text
Color.yellow Text
"≫"
                  TestStatus{Bool
success_ :: Bool
success_ :: TestResultStatus -> Bool
success_}
                    | Bool
success_ -> Text -> Text
Color.green Text
"✔"
                    | Bool
otherwise -> Text -> Text
Color.red Text
"✘"
        ]
      , Bool -> Text -> [Text]
forall {a}. Bool -> a -> [a]
when_ (Int
testsDeselected Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$
          Text
"  • " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text -> Text
forall a. (Num a, Eq a, Show a) => a -> Text -> Text
pluralize Int
testsDeselected Text
"test" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" deselected"
      ]
   where
    when_ :: Bool -> a -> [a]
when_ Bool
p a
x = if Bool
p then [a
x] else []

{----- Built-in hooks -----}

specTreePlugin :: Plugin
specTreePlugin :: Plugin
specTreePlugin =
  Plugin
defaultPlugin
    { Plugin.hooks =
        mconcat
          [ xfailHook
          , skipHook
          , focusHook
          , applyTestSelectionsHook
          , manualTestsHook
          ]
    }

applyTestSelectionsHook :: Hooks
applyTestSelectionsHook :: Hooks
applyTestSelectionsHook =
  Hooks
defaultHooks
    { modifySpecRegistry = Hooks.runLate . Hooks.mkPreHook $ \ModifySpecRegistryHookContext
ctx SpecRegistry
inp ->
        SpecRegistry -> IO SpecRegistry
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpecRegistry -> IO SpecRegistry)
-> SpecRegistry -> IO SpecRegistry
forall a b. (a -> b) -> a -> b
$
          case ModifySpecRegistryHookContext
ctx.testTargets of
            Just TestTarget
selections -> (SpecInfo -> SpecInfo) -> SpecRegistry -> SpecRegistry
forall a b. (a -> b) -> [a] -> [b]
map (TestTarget -> SpecInfo -> SpecInfo
applyTestSelections TestTarget
selections) SpecRegistry
inp
            Maybe TestTarget
Nothing -> SpecRegistry
inp
    }

manualTestsHook :: Hooks
manualTestsHook :: Hooks
manualTestsHook =
  Hooks
defaultHooks
    { modifySpecRegistry = Hooks.mkPreHook $ \ModifySpecRegistryHookContext
ctx SpecRegistry
inp ->
        SpecRegistry -> IO SpecRegistry
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpecRegistry -> IO SpecRegistry)
-> SpecRegistry -> IO SpecRegistry
forall a b. (a -> b) -> a -> b
$
          case ModifySpecRegistryHookContext
ctx.testTargets of
            -- only hide manual tests when no selections are specified
            Just TestTarget
_ -> SpecRegistry
inp
            Maybe TestTarget
Nothing -> (Spec -> Spec) -> SpecRegistry -> SpecRegistry
mapSpecs Spec -> Spec
hideManual SpecRegistry
inp
    }
 where
  hideManual :: Spec -> Spec
hideManual = (SpecTest -> Bool) -> Spec -> Spec
filterSpecTests (Bool -> Bool
not (Bool -> Bool) -> (SpecTest -> Bool) -> SpecTest -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. IsMarker a => [SomeMarker] -> Bool
hasMarker @MarkerManual ([SomeMarker] -> Bool)
-> (SpecTest -> [SomeMarker]) -> SpecTest -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.markers))

xfailHook :: Hooks
xfailHook :: Hooks
xfailHook =
  Hooks
defaultHooks
    { runTest = Hooks.mkPostHook $ \RunTestHookContext
ctx ()
_ ->
        case [SomeMarker] -> Maybe MarkerXFail
forall a. IsMarker a => [SomeMarker] -> Maybe a
findMarker RunTestHookContext
ctx.testInfo.markers of
          Just (MarkerXFail Text
reason) -> TestResult -> IO TestResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestResult -> IO TestResult)
-> (TestResult -> TestResult) -> TestResult -> IO TestResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> TestResult -> TestResult
forall {r} {r}.
(HasField "success" r Bool, HasField "status" r r) =>
Text -> r -> TestResult
modify Text
reason
          Maybe MarkerXFail
Nothing -> TestResult -> IO TestResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    }
 where
  modify :: Text -> r -> TestResult
modify Text
reason r
result =
    if r
result.status.success
      then
        TestResult
          { status :: TestResultStatus
status =
              TestStatus
                { name_ :: Text
name_ = Text
"xpassed"
                , success_ :: Bool
success_ = Bool
False
                }
          , label :: Text
label = Text -> Text
Color.red Text
"XPASS"
          , message :: TestResultMessage
message = Text -> TestResultMessage
TestResultMessageInline Text
reason
          }
      else
        TestResult
          { status :: TestResultStatus
status = TestResultStatus
TestPassed
          , label :: Text
label = Text -> Text
Color.yellow Text
"XFAIL"
          , message :: TestResultMessage
message = Text -> TestResultMessage
TestResultMessageInline Text
reason
          }

skipHook :: Hooks
skipHook :: Hooks
skipHook =
  Hooks
defaultHooks
    { runTest = Hooks.mkHook $ \RunTestHookContext
ctx () -> IO TestResult
run ->
        case [SomeMarker] -> Maybe MarkerSkip
forall a. IsMarker a => [SomeMarker] -> Maybe a
findMarker (RunTestHookContext
ctx.testInfo.markers) of
          Just (MarkerSkip Text
reason) -> \()
_ -> TestResult -> IO TestResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestResult -> IO TestResult) -> TestResult -> IO TestResult
forall a b. (a -> b) -> a -> b
$ Text -> TestResult
skipResult Text
reason
          Maybe MarkerSkip
Nothing -> () -> IO TestResult
run
    , onTestFailure = Hooks.mkHook $ \OnTestFailureHookContext
_ SomeException -> IO TestResult
run SomeException
e ->
        case SomeException -> Maybe SkeletestError
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
          Just (SkipTest Text
reason) -> TestResult -> IO TestResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestResult -> IO TestResult) -> TestResult -> IO TestResult
forall a b. (a -> b) -> a -> b
$ Text -> TestResult
skipResult Text
reason
          Maybe SkeletestError
_ -> SomeException -> IO TestResult
run SomeException
e
    }
 where
  skipResult :: Text -> TestResult
skipResult Text
reason =
    TestResult
      { status :: TestResultStatus
status = TestResultStatus
TestSkipped
      , label :: Text
label = Text -> Text
Color.yellow Text
"SKIP"
      , message :: TestResultMessage
message = Text -> TestResultMessage
TestResultMessageInline Text
reason
      }

-- | Like 'X.skip', except allows skipping tests at runtime.
--
-- @since 0.4.0
skipTest :: (MonadIO m) => String -> m a
skipTest :: forall (m :: * -> *) a. MonadIO m => FilePath -> m a
skipTest FilePath
reason = SkeletestError -> m a
forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (SkeletestError -> m a) -> SkeletestError -> m a
forall a b. (a -> b) -> a -> b
$ Text -> SkeletestError
SkipTest (FilePath -> Text
Text.pack FilePath
reason)

focusHook :: Hooks
focusHook :: Hooks
focusHook =
  Hooks
defaultHooks
    { modifySpecRegistry = Hooks.runEarly . Hooks.mkPreHook $ \ModifySpecRegistryHookContext
_ SpecRegistry
specs ->
        SpecRegistry -> IO SpecRegistry
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpecRegistry -> IO SpecRegistry)
-> SpecRegistry -> IO SpecRegistry
forall a b. (a -> b) -> a -> b
$
          if SpecRegistry -> Bool
hasFocus SpecRegistry
specs
            then (Spec -> Spec) -> SpecRegistry -> SpecRegistry
mapSpecs Spec -> Spec
hideNotFocused SpecRegistry
specs
            else SpecRegistry
specs
    }
 where
  hasFocus :: SpecRegistry -> Bool
hasFocus = (SpecInfo -> Bool) -> SpecRegistry -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((SpecTest -> Bool) -> Spec -> Bool
anySpecTests SpecTest -> Bool
forall {r}. HasField "markers" r [SomeMarker] => r -> Bool
isFocused (Spec -> Bool) -> (SpecInfo -> Spec) -> SpecInfo -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (.spec))
  anySpecTests :: (SpecTest -> Bool) -> Spec -> Bool
anySpecTests SpecTest -> Bool
f Spec
spec =
    let go :: SpecTree -> [SpecTest]
go = \case
          SpecTree_Group{[SpecTree]
trees :: SpecTree -> [SpecTree]
trees :: [SpecTree]
trees} -> (SpecTree -> [SpecTest]) -> [SpecTree] -> [SpecTest]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SpecTree -> [SpecTest]
go [SpecTree]
trees
          SpecTree_Test SpecTest
test -> [SpecTest
test]
     in (SpecTest -> Bool) -> [SpecTest] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any SpecTest -> Bool
f ([SpecTest] -> Bool) -> [SpecTest] -> Bool
forall a b. (a -> b) -> a -> b
$ (SpecTree -> [SpecTest]) -> [SpecTree] -> [SpecTest]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap SpecTree -> [SpecTest]
go (Spec -> [SpecTree]
getSpecTrees Spec
spec)
  isFocused :: r -> Bool
isFocused r
test = forall a. IsMarker a => [SomeMarker] -> Bool
hasMarker @MarkerFocus r
test.markers
  hideNotFocused :: Spec -> Spec
hideNotFocused = (SpecTest -> Bool) -> Spec -> Spec
filterSpecTests SpecTest -> Bool
forall {r}. HasField "markers" r [SomeMarker] => r -> Bool
isFocused