{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

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

  -- ** Entrypoint
  SpecRegistry,
  SpecInfo (..),
  pruneSpec,
  applyTestSelections,

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

  -- ** Modifiers
  xfail,
  skip,
  markManual,

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

import Control.Concurrent (myThreadId)
import Control.Monad (forM, guard)
import Control.Monad.Trans.Reader qualified as Trans
import Control.Monad.Trans.Writer (Writer, execWriter, tell)
import Data.Functor.Identity (runIdentity)
import Data.Maybe (catMaybes, isJust, mapMaybe)
import Data.Text (Text)
import Data.Text qualified as Text
import Data.Text.IO qualified as Text
import UnliftIO.Exception (
  finally,
  fromException,
  try,
 )

import Skeletest.Assertions (Testable, runTestable)
import Skeletest.Internal.Fixtures (FixtureScopeKey (..), cleanupFixtures)
import Skeletest.Internal.Markers (
  AnonMarker (..),
  IsMarker (..),
  SomeMarker (..),
  findMarker,
 )
import Skeletest.Internal.TestInfo (TestInfo (TestInfo), withTestInfo)
import Skeletest.Internal.TestInfo qualified as TestInfo
import Skeletest.Internal.TestRunner (
  TestResult (..),
  TestResultMessage (..),
  testResultFromAssertionFail,
  testResultFromError,
 )
import Skeletest.Internal.TestTargets (TestTarget, TestTargets, matchesTest)
import Skeletest.Internal.TestTargets qualified as TestTargets
import Skeletest.Internal.Utils.Color qualified as Color
import Skeletest.Plugin (Hooks (..), defaultHooks)
import Skeletest.Prop.Internal (Property)

type Spec = Spec' ()

newtype Spec' a = Spec (Writer [SpecTree] a)
  deriving ((forall a b. (a -> b) -> Spec' a -> Spec' b)
-> (forall a b. a -> Spec' b -> Spec' a) -> Functor Spec'
forall a b. a -> Spec' b -> Spec' a
forall a b. (a -> b) -> Spec' a -> Spec' b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> Spec' a -> Spec' b
fmap :: forall a b. (a -> b) -> Spec' a -> Spec' b
$c<$ :: forall a b. a -> Spec' b -> Spec' a
<$ :: forall a b. a -> Spec' b -> Spec' a
Functor, Functor Spec'
Functor Spec' =>
(forall a. a -> Spec' a)
-> (forall a b. Spec' (a -> b) -> Spec' a -> Spec' b)
-> (forall a b c. (a -> b -> c) -> Spec' a -> Spec' b -> Spec' c)
-> (forall a b. Spec' a -> Spec' b -> Spec' b)
-> (forall a b. Spec' a -> Spec' b -> Spec' a)
-> Applicative Spec'
forall a. a -> Spec' a
forall a b. Spec' a -> Spec' b -> Spec' a
forall a b. Spec' a -> Spec' b -> Spec' b
forall a b. Spec' (a -> b) -> Spec' a -> Spec' b
forall a b c. (a -> b -> c) -> Spec' a -> Spec' b -> Spec' c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
$cpure :: forall a. a -> Spec' a
pure :: forall a. a -> Spec' a
$c<*> :: forall a b. Spec' (a -> b) -> Spec' a -> Spec' b
<*> :: forall a b. Spec' (a -> b) -> Spec' a -> Spec' b
$cliftA2 :: forall a b c. (a -> b -> c) -> Spec' a -> Spec' b -> Spec' c
liftA2 :: forall a b c. (a -> b -> c) -> Spec' a -> Spec' b -> Spec' c
$c*> :: forall a b. Spec' a -> Spec' b -> Spec' b
*> :: forall a b. Spec' a -> Spec' b -> Spec' b
$c<* :: forall a b. Spec' a -> Spec' b -> Spec' a
<* :: forall a b. Spec' a -> Spec' b -> Spec' a
Applicative, Applicative Spec'
Applicative Spec' =>
(forall a b. Spec' a -> (a -> Spec' b) -> Spec' b)
-> (forall a b. Spec' a -> Spec' b -> Spec' b)
-> (forall a. a -> Spec' a)
-> Monad Spec'
forall a. a -> Spec' a
forall a b. Spec' a -> Spec' b -> Spec' b
forall a b. Spec' a -> (a -> Spec' b) -> Spec' b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall a b. Spec' a -> (a -> Spec' b) -> Spec' b
>>= :: forall a b. Spec' a -> (a -> Spec' b) -> Spec' b
$c>> :: forall a b. Spec' a -> Spec' b -> Spec' b
>> :: forall a b. Spec' a -> Spec' b -> Spec' b
$creturn :: forall a. a -> Spec' a
return :: forall a. a -> Spec' a
Monad)

getSpecTrees :: Spec -> [SpecTree]
getSpecTrees :: Spec -> [SpecTree]
getSpecTrees (Spec Writer [SpecTree] ()
spec) = Writer [SpecTree] () -> [SpecTree]
forall w a. Writer w a -> w
execWriter Writer [SpecTree] ()
spec

withSpecTrees :: (Monad m) => ([SpecTree] -> m [SpecTree]) -> Spec -> m Spec
withSpecTrees :: forall (m :: * -> *).
Monad m =>
([SpecTree] -> m [SpecTree]) -> Spec -> m Spec
withSpecTrees [SpecTree] -> m [SpecTree]
f = ([SpecTree] -> Spec) -> m [SpecTree] -> m Spec
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Writer [SpecTree] () -> Spec
forall a. Writer [SpecTree] a -> Spec' a
Spec (Writer [SpecTree] () -> Spec)
-> ([SpecTree] -> Writer [SpecTree] ()) -> [SpecTree] -> Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SpecTree] -> Writer [SpecTree] ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell) (m [SpecTree] -> m Spec)
-> (Spec -> m [SpecTree]) -> Spec -> m Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SpecTree] -> m [SpecTree]
f ([SpecTree] -> m [SpecTree])
-> (Spec -> [SpecTree]) -> Spec -> m [SpecTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Spec -> [SpecTree]
getSpecTrees

data SpecTree
  = SpecGroup
      { SpecTree -> Text
groupLabel :: Text
      , SpecTree -> [SpecTree]
groupTrees :: [SpecTree]
      }
  | SpecTest
      { SpecTree -> Text
testName :: Text
      , SpecTree -> [SomeMarker]
testMarkers :: [SomeMarker]
      -- ^ Markers, in order from least to most recently applied.
      --
      -- >>> withMarker MarkerA . withMarker MarkerB $ test ...
      --
      -- will contain
      --
      -- >>> SpecTest { testMarkers = [MarkerA, MarkerB] }
      , SpecTree -> IO TestResult
testAction :: IO TestResult
      }

-- | Traverse the tree with the given processing function.
--
-- To preprocess trees with @pre@ and postprocess with @post@:
--
-- >>> traverseSpecTrees (\go -> post <=< mapM go <=< pre) spec
traverseSpecTrees ::
  forall m.
  (Monad m) =>
  ( (SpecTree -> m SpecTree)
    -> [SpecTree]
    -> m [SpecTree]
  )
  -> Spec
  -> m Spec
traverseSpecTrees :: forall (m :: * -> *).
Monad m =>
((SpecTree -> m SpecTree) -> [SpecTree] -> m [SpecTree])
-> Spec -> m Spec
traverseSpecTrees (SpecTree -> m SpecTree) -> [SpecTree] -> m [SpecTree]
f = ([SpecTree] -> m [SpecTree]) -> Spec -> m Spec
forall (m :: * -> *).
Monad m =>
([SpecTree] -> m [SpecTree]) -> Spec -> m Spec
withSpecTrees [SpecTree] -> m [SpecTree]
go
  where
    go :: [SpecTree] -> m [SpecTree]
    go :: [SpecTree] -> m [SpecTree]
go = (SpecTree -> m SpecTree) -> [SpecTree] -> m [SpecTree]
f SpecTree -> m SpecTree
recurseGroups

    recurseGroups :: SpecTree -> m SpecTree
recurseGroups = \case
      group :: SpecTree
group@SpecGroup{} -> do
        trees' <- [SpecTree] -> m [SpecTree]
go ([SpecTree] -> m [SpecTree]) -> [SpecTree] -> m [SpecTree]
forall a b. (a -> b) -> a -> b
$ SpecTree -> [SpecTree]
groupTrees SpecTree
group
        pure group{groupTrees = trees'}
      stest :: SpecTree
stest@SpecTest{} -> SpecTree -> m SpecTree
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpecTree
stest

-- | Map the tree with the given processing function.
--
-- To preprocess trees with @pre@ and postprocess with @post@:
--
-- >>> mapSpecTrees (\go -> post . map go . pre) spec
mapSpecTrees ::
  ( (SpecTree -> SpecTree)
    -> [SpecTree]
    -> [SpecTree]
  )
  -> Spec
  -> Spec
mapSpecTrees :: ((SpecTree -> SpecTree) -> [SpecTree] -> [SpecTree])
-> Spec -> Spec
mapSpecTrees (SpecTree -> SpecTree) -> [SpecTree] -> [SpecTree]
f = Identity Spec -> Spec
forall a. Identity a -> a
runIdentity (Identity Spec -> Spec) -> (Spec -> Identity Spec) -> Spec -> Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SpecTree -> Identity SpecTree)
 -> [SpecTree] -> Identity [SpecTree])
-> Spec -> Identity Spec
forall (m :: * -> *).
Monad m =>
((SpecTree -> m SpecTree) -> [SpecTree] -> m [SpecTree])
-> Spec -> m Spec
traverseSpecTrees (\SpecTree -> Identity SpecTree
go -> [SpecTree] -> Identity [SpecTree]
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SpecTree] -> Identity [SpecTree])
-> ([SpecTree] -> [SpecTree]) -> [SpecTree] -> Identity [SpecTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpecTree -> SpecTree) -> [SpecTree] -> [SpecTree]
f (Identity SpecTree -> SpecTree
forall a. Identity a -> a
runIdentity (Identity SpecTree -> SpecTree)
-> (SpecTree -> Identity SpecTree) -> SpecTree -> SpecTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecTree -> Identity SpecTree
go))

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

-- | Run the given Specs and return whether all of the tests passed.
runSpecs :: Hooks -> SpecRegistry -> IO Bool
runSpecs :: Hooks -> SpecRegistry -> IO Bool
runSpecs Hooks
hooks0 SpecRegistry
specs =
  (IO Bool -> IO () -> IO Bool
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` FixtureScopeKey -> IO ()
cleanupFixtures FixtureScopeKey
PerSessionFixtureKey) (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
    ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (IO [Bool] -> IO Bool)
-> ((SpecInfo -> IO Bool) -> IO [Bool])
-> (SpecInfo -> IO Bool)
-> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecRegistry -> (SpecInfo -> IO Bool) -> IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM SpecRegistry
specs ((SpecInfo -> IO Bool) -> IO Bool)
-> (SpecInfo -> IO Bool) -> IO Bool
forall a b. (a -> b) -> a -> b
$ \SpecInfo{FilePath
Text
Spec
specPath :: FilePath
specName :: Text
specSpec :: Spec
specSpec :: SpecInfo -> Spec
specName :: SpecInfo -> Text
specPath :: SpecInfo -> FilePath
..} ->
      (IO Bool -> IO () -> IO Bool
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` FixtureScopeKey -> IO ()
cleanupFixtures (FilePath -> FixtureScopeKey
PerFileFixtureKey FilePath
specPath)) (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
        let emptyTestInfo :: TestInfo
emptyTestInfo =
              TestInfo
                { testModule :: Text
testModule = Text
specName
                , testContexts :: [Text]
testContexts = []
                , testName :: Text
testName = Text
""
                , testMarkers :: [SomeMarker]
testMarkers = []
                , testFile :: FilePath
testFile = FilePath
specPath
                }
        Text -> IO ()
Text.putStrLn Text
specName
        TestInfo -> [SpecTree] -> IO Bool
runTrees TestInfo
emptyTestInfo ([SpecTree] -> IO Bool) -> [SpecTree] -> IO Bool
forall a b. (a -> b) -> a -> b
$ Spec -> [SpecTree]
getSpecTrees Spec
specSpec
  where
    Hooks{TestInfo -> IO TestResult -> IO TestResult
hookRunTest :: TestInfo -> IO TestResult -> IO TestResult
hookRunTest :: Hooks -> TestInfo -> IO TestResult -> IO TestResult
..} = Hooks
builtinHooks Hooks -> Hooks -> Hooks
forall a. Semigroup a => a -> a -> a
<> Hooks
hooks0
    builtinHooks :: Hooks
builtinHooks = Hooks
xfailHook Hooks -> Hooks -> Hooks
forall a. Semigroup a => a -> a -> a
<> Hooks
skipHook

    runTrees :: TestInfo -> [SpecTree] -> IO Bool
runTrees TestInfo
baseTestInfo = ([Bool] -> Bool) -> IO [Bool] -> IO Bool
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and (IO [Bool] -> IO Bool)
-> ([SpecTree] -> IO [Bool]) -> [SpecTree] -> IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpecTree -> IO Bool) -> [SpecTree] -> IO [Bool]
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 (TestInfo -> SpecTree -> IO Bool
runTree TestInfo
baseTestInfo)
    runTree :: TestInfo -> SpecTree -> IO Bool
runTree TestInfo
baseTestInfo = \case
      SpecGroup{[SpecTree]
Text
groupLabel :: SpecTree -> Text
groupTrees :: SpecTree -> [SpecTree]
groupLabel :: Text
groupTrees :: [SpecTree]
..} -> do
        let lvl :: Int
lvl = TestInfo -> Int
getIndentLevel TestInfo
baseTestInfo
        Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
indent Int
lvl Text
groupLabel
        TestInfo -> [SpecTree] -> IO Bool
runTrees TestInfo
baseTestInfo{TestInfo.testContexts = TestInfo.testContexts baseTestInfo <> [groupLabel]} [SpecTree]
groupTrees
      SpecTest{[SomeMarker]
IO TestResult
Text
testName :: SpecTree -> Text
testMarkers :: SpecTree -> [SomeMarker]
testAction :: SpecTree -> IO TestResult
testName :: Text
testMarkers :: [SomeMarker]
testAction :: IO TestResult
..} -> do
        let lvl :: Int
lvl = TestInfo -> Int
getIndentLevel TestInfo
baseTestInfo
        Text -> IO ()
Text.putStr (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
indent Int
lvl (Text
testName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": ")

        let testInfo :: TestInfo
testInfo =
              TestInfo
baseTestInfo
                { TestInfo.testName = testName
                , TestInfo.testMarkers = testMarkers
                }
        TestResult{..} <-
          TestInfo -> IO TestResult -> IO TestResult
forall (m :: * -> *) a. MonadUnliftIO m => TestInfo -> m a -> m a
withTestInfo TestInfo
testInfo (IO TestResult -> IO TestResult) -> IO TestResult -> IO TestResult
forall a b. (a -> b) -> a -> b
$ do
            tid <- IO ThreadId
myThreadId
            runTest testInfo testAction `finally` cleanupFixtures (PerTestFixtureKey tid)

        Text.putStrLn testResultLabel
        case testResultMessage of
          TestResultMessage
TestResultMessageNone -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          TestResultMessageInline Text
msg -> Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
indent (Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Text
msg
          TestResultMessageSection Text
msg -> Text -> IO ()
Text.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> Text
withBorder Text
msg
        pure testResultSuccess

    runTest :: TestInfo -> IO TestResult -> IO TestResult
runTest TestInfo
info IO TestResult
action =
      TestInfo -> IO TestResult -> IO TestResult
hookRunTest TestInfo
info (IO TestResult -> IO TestResult) -> IO TestResult -> IO TestResult
forall a b. (a -> b) -> a -> b
$ do
        IO TestResult -> IO (Either SomeException TestResult)
forall (m :: * -> *) e a.
(MonadUnliftIO m, Exception e) =>
m a -> m (Either e a)
try IO TestResult
action IO (Either SomeException TestResult)
-> (Either SomeException TestResult -> IO TestResult)
-> IO TestResult
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Right TestResult
result -> TestResult -> IO TestResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestResult
result
          Left SomeException
e
            | Just AssertionFail
e' <- SomeException -> Maybe AssertionFail
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e -> AssertionFail -> IO TestResult
testResultFromAssertionFail AssertionFail
e'
            | Bool
otherwise -> 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
$ SomeException -> TestResult
testResultFromError SomeException
e

    getIndentLevel :: TestInfo -> Int
getIndentLevel TestInfo
testInfo = [Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (TestInfo -> [Text]
TestInfo.testContexts TestInfo
testInfo) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 -- +1 to include the module name
    indent :: Int -> Text -> Text
indent Int
lvl = Text -> [Text] -> Text
Text.intercalate Text
"\n" ([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 (Int -> Text -> Text
Text.replicate (Int
lvl Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
4) Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
Text.splitOn Text
"\n"

    border :: Text
border = Int -> Text -> Text
Text.replicate Int
80 Text
"-"
    withBorder :: Text -> Text
withBorder Text
msg = Text -> [Text] -> Text
Text.intercalate Text
"\n" [Text
border, Text
msg, Text
border]

{----- Entrypoint -----}

type SpecRegistry = [SpecInfo]

data SpecInfo = SpecInfo
  { SpecInfo -> FilePath
specPath :: FilePath
  , SpecInfo -> Text
specName :: Text
  , SpecInfo -> Spec
specSpec :: Spec
  }

pruneSpec :: SpecRegistry -> SpecRegistry
pruneSpec :: SpecRegistry -> SpecRegistry
pruneSpec = (SpecInfo -> Maybe SpecInfo) -> SpecRegistry -> SpecRegistry
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((SpecInfo -> Maybe SpecInfo) -> SpecRegistry -> SpecRegistry)
-> (SpecInfo -> Maybe SpecInfo) -> SpecRegistry -> SpecRegistry
forall a b. (a -> b) -> a -> b
$ \SpecInfo
info -> do
  let spec :: Spec
spec = ((SpecTree -> SpecTree) -> [SpecTree] -> [SpecTree])
-> Spec -> Spec
mapSpecTrees (\SpecTree -> SpecTree
go -> (SpecTree -> Bool) -> [SpecTree] -> [SpecTree]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (SpecTree -> Bool) -> SpecTree -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecTree -> Bool
isEmptySpec) ([SpecTree] -> [SpecTree])
-> ([SpecTree] -> [SpecTree]) -> [SpecTree] -> [SpecTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpecTree -> SpecTree) -> [SpecTree] -> [SpecTree]
forall a b. (a -> b) -> [a] -> [b]
map SpecTree -> SpecTree
go) (SpecInfo -> Spec
specSpec SpecInfo
info)
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ (Bool -> Bool
not (Bool -> Bool) -> (Spec -> Bool) -> Spec -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SpecTree] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([SpecTree] -> Bool) -> (Spec -> [SpecTree]) -> Spec -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Spec -> [SpecTree]
getSpecTrees) Spec
spec
  SpecInfo -> Maybe SpecInfo
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpecInfo
info{specSpec = spec}
  where
    isEmptySpec :: SpecTree -> Bool
isEmptySpec = \case
      SpecGroup Text
_ [] -> Bool
True
      SpecTree
_ -> Bool
False

-- TODO: make hookable? implement manual tests with hook?
applyTestSelections :: TestTargets -> SpecRegistry -> SpecRegistry
applyTestSelections :: TestTargets -> SpecRegistry -> SpecRegistry
applyTestSelections = \case
  Just TestTarget
selections -> (SpecInfo -> SpecInfo) -> SpecRegistry -> SpecRegistry
forall a b. (a -> b) -> [a] -> [b]
map (TestTarget -> SpecInfo -> SpecInfo
applyTestSelections' TestTarget
selections)
  -- if no selections are specified, hide manual tests
  TestTargets
Nothing -> (SpecInfo -> SpecInfo) -> SpecRegistry -> SpecRegistry
forall a b. (a -> b) -> [a] -> [b]
map (\SpecInfo
info -> SpecInfo
info{specSpec = hideManualTests $ specSpec info})
  where
    hideManualTests :: Spec -> Spec
hideManualTests = ((SpecTree -> SpecTree) -> [SpecTree] -> [SpecTree])
-> Spec -> Spec
mapSpecTrees (\SpecTree -> SpecTree
go -> (SpecTree -> Bool) -> [SpecTree] -> [SpecTree]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (SpecTree -> Bool) -> SpecTree -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecTree -> Bool
isManualTest) ([SpecTree] -> [SpecTree])
-> ([SpecTree] -> [SpecTree]) -> [SpecTree] -> [SpecTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpecTree -> SpecTree) -> [SpecTree] -> [SpecTree]
forall a b. (a -> b) -> [a] -> [b]
map SpecTree -> SpecTree
go)
    isManualTest :: SpecTree -> Bool
isManualTest = \case
      SpecGroup{} -> Bool
False
      SpecTest{[SomeMarker]
testMarkers :: SpecTree -> [SomeMarker]
testMarkers :: [SomeMarker]
testMarkers} -> Maybe MarkerManual -> Bool
forall a. Maybe a -> Bool
isJust (Maybe MarkerManual -> Bool) -> Maybe MarkerManual -> Bool
forall a b. (a -> b) -> a -> b
$ forall a. IsMarker a => [SomeMarker] -> Maybe a
findMarker @MarkerManual [SomeMarker]
testMarkers

applyTestSelections' :: TestTarget -> SpecInfo -> SpecInfo
applyTestSelections' :: TestTarget -> SpecInfo -> SpecInfo
applyTestSelections' TestTarget
selections SpecInfo
info = SpecInfo
info{specSpec = applySelections $ specSpec info}
  where
    applySelections :: Spec -> Spec
applySelections = (Reader [Text] Spec -> [Text] -> Spec
forall r a. Reader r a -> r -> a
`Trans.runReader` []) (Reader [Text] Spec -> Spec)
-> (Spec -> Reader [Text] Spec) -> Spec -> Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SpecTree -> ReaderT [Text] Identity SpecTree)
 -> [SpecTree] -> ReaderT [Text] Identity [SpecTree])
-> Spec -> Reader [Text] Spec
forall (m :: * -> *).
Monad m =>
((SpecTree -> m SpecTree) -> [SpecTree] -> m [SpecTree])
-> Spec -> m Spec
traverseSpecTrees (SpecTree -> ReaderT [Text] Identity SpecTree)
-> [SpecTree] -> ReaderT [Text] Identity [SpecTree]
forall {m :: * -> *}.
Monad m =>
(SpecTree -> ReaderT [Text] m SpecTree)
-> [SpecTree] -> ReaderT [Text] m [SpecTree]
apply

    apply :: (SpecTree -> ReaderT [Text] m SpecTree)
-> [SpecTree] -> ReaderT [Text] m [SpecTree]
apply SpecTree -> ReaderT [Text] m SpecTree
go = (SpecTree -> ReaderT [Text] m (Maybe SpecTree))
-> [SpecTree] -> ReaderT [Text] m [SpecTree]
forall {f :: * -> *} {a} {a}.
Monad f =>
(a -> f (Maybe a)) -> [a] -> f [a]
mapMaybeM ((SpecTree -> ReaderT [Text] m (Maybe SpecTree))
 -> [SpecTree] -> ReaderT [Text] m [SpecTree])
-> (SpecTree -> ReaderT [Text] m (Maybe SpecTree))
-> [SpecTree]
-> ReaderT [Text] m [SpecTree]
forall a b. (a -> b) -> a -> b
$ \case
      group :: SpecTree
group@SpecGroup{Text
groupLabel :: SpecTree -> Text
groupLabel :: Text
groupLabel} -> SpecTree -> Maybe SpecTree
forall a. a -> Maybe a
Just (SpecTree -> Maybe SpecTree)
-> ReaderT [Text] m SpecTree -> ReaderT [Text] m (Maybe SpecTree)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Text] -> [Text])
-> ReaderT [Text] m SpecTree -> ReaderT [Text] m SpecTree
forall r (m :: * -> *) a.
(r -> r) -> ReaderT r m a -> ReaderT r m a
Trans.local ([Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
groupLabel]) (SpecTree -> ReaderT [Text] m SpecTree
go SpecTree
group)
      stest :: SpecTree
stest@SpecTest{Text
testName :: SpecTree -> Text
testName :: Text
testName, [SomeMarker]
testMarkers :: SpecTree -> [SomeMarker]
testMarkers :: [SomeMarker]
testMarkers} -> do
        groups <- ReaderT [Text] m [Text]
forall (m :: * -> *) r. Monad m => ReaderT r m r
Trans.ask
        let attrs =
              TestTargets.TestAttrs
                { testPath :: FilePath
testPath = SpecInfo -> FilePath
specPath SpecInfo
info
                , testIdentifier :: [Text]
testIdentifier = [Text]
groups [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
testName]
                , testMarkers :: [Text]
testMarkers = [FilePath -> Text
Text.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ a -> FilePath
forall a. IsMarker a => a -> FilePath
getMarkerName a
m | SomeMarker a
m <- [SomeMarker]
testMarkers]
                }
        pure $
          if matchesTest selections attrs
            then Just stest
            else Nothing

    mapMaybeM :: (a -> f (Maybe a)) -> [a] -> f [a]
mapMaybeM a -> f (Maybe a)
f = ([Maybe a] -> [a]) -> f [Maybe a] -> f [a]
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes (f [Maybe a] -> f [a]) -> ([a] -> f [Maybe a]) -> [a] -> f [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> f (Maybe a)) -> [a] -> f [Maybe a]
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 a -> f (Maybe a)
f

{----- Defining a Spec -----}

-- | The entity or concept being tested.
describe :: String -> Spec -> Spec
describe :: FilePath -> Spec -> Spec
describe FilePath
name = Identity Spec -> Spec
forall a. Identity a -> a
runIdentity (Identity Spec -> Spec) -> (Spec -> Identity Spec) -> Spec -> Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([SpecTree] -> Identity [SpecTree]) -> Spec -> Identity Spec
forall (m :: * -> *).
Monad m =>
([SpecTree] -> m [SpecTree]) -> Spec -> m Spec
withSpecTrees ([SpecTree] -> Identity [SpecTree]
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([SpecTree] -> Identity [SpecTree])
-> ([SpecTree] -> [SpecTree]) -> [SpecTree] -> Identity [SpecTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpecTree -> [SpecTree] -> [SpecTree]
forall a. a -> [a] -> [a]
: []) (SpecTree -> [SpecTree])
-> ([SpecTree] -> SpecTree) -> [SpecTree] -> [SpecTree]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SpecTree] -> SpecTree
mkGroup)
  where
    mkGroup :: [SpecTree] -> SpecTree
mkGroup [SpecTree]
trees =
      SpecGroup
        { groupLabel :: Text
groupLabel = FilePath -> Text
Text.pack FilePath
name
        , groupTrees :: [SpecTree]
groupTrees = [SpecTree]
trees
        }

test :: (Testable m) => String -> m () -> Spec
test :: forall (m :: * -> *). Testable m => FilePath -> m () -> Spec
test FilePath
name m ()
t = Writer [SpecTree] () -> Spec
forall a. Writer [SpecTree] a -> Spec' a
Spec (Writer [SpecTree] () -> Spec) -> Writer [SpecTree] () -> Spec
forall a b. (a -> b) -> a -> b
$ [SpecTree] -> Writer [SpecTree] ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell [SpecTree
mkTest]
  where
    mkTest :: SpecTree
mkTest =
      SpecTest
        { testName :: Text
testName = FilePath -> Text
Text.pack FilePath
name
        , testMarkers :: [SomeMarker]
testMarkers = []
        , testAction :: IO TestResult
testAction = m () -> IO TestResult
forall (m :: * -> *). Testable m => m () -> IO TestResult
runTestable m ()
t
        }

-- | Define an IO-based test.
--
-- Should typically be written to be read as full sentences in traditional BDD style:
-- https://en.wikipedia.org/wiki/Behavior-driven_development.
--
-- @
-- describe \"User\" $ do
--   it "can be checked for equality" $ do
--     user1 `shouldBe` user1
-- @
it :: String -> IO () -> Spec
it :: FilePath -> IO () -> Spec
it = FilePath -> IO () -> Spec
forall (m :: * -> *). Testable m => FilePath -> m () -> Spec
test

-- | Define a property test.
--
-- @
-- describe \"User\" $ do
--   prop "decode . encode === Just" $ do
--     let genUser = ...
--     (decode . encode) P.=== Just \`shouldSatisfy\` P.isoWith genUser
-- @
prop :: String -> Property -> Spec
prop :: FilePath -> Property -> Spec
prop = FilePath -> Property -> Spec
forall (m :: * -> *). Testable m => FilePath -> m () -> Spec
test

{----- Modifiers -----}

-- | Mark the given spec as expected to fail.
-- Fails tests if they unexpectedly pass.
--
-- Can be selected with the marker @@xfail@
xfail :: String -> Spec -> Spec
xfail :: FilePath -> Spec -> Spec
xfail = MarkerXFail -> Spec -> Spec
forall a. IsMarker a => a -> Spec -> Spec
withMarker (MarkerXFail -> Spec -> Spec)
-> (FilePath -> MarkerXFail) -> FilePath -> Spec -> Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MarkerXFail
MarkerXFail (Text -> MarkerXFail)
-> (FilePath -> Text) -> FilePath -> MarkerXFail
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack

xfailHook :: Hooks
xfailHook :: Hooks
xfailHook =
  Hooks
defaultHooks
    { hookRunTest = \TestInfo
testInfo IO TestResult
runTest ->
        case [SomeMarker] -> Maybe MarkerXFail
forall a. IsMarker a => [SomeMarker] -> Maybe a
findMarker (TestInfo -> [SomeMarker]
TestInfo.testMarkers TestInfo
testInfo) of
          Just (MarkerXFail Text
reason) -> Text -> TestResult -> TestResult
modify Text
reason (TestResult -> TestResult) -> IO TestResult -> IO TestResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO TestResult
runTest
          Maybe MarkerXFail
Nothing -> IO TestResult
runTest
    }
  where
    modify :: Text -> TestResult -> TestResult
modify Text
reason TestResult{Bool
Text
TestResultMessage
testResultMessage :: TestResult -> TestResultMessage
testResultLabel :: TestResult -> Text
testResultSuccess :: TestResult -> Bool
testResultSuccess :: Bool
testResultLabel :: Text
testResultMessage :: TestResultMessage
..} =
      if Bool
testResultSuccess
        then
          TestResult
            { testResultSuccess :: Bool
testResultSuccess = Bool
False
            , testResultLabel :: Text
testResultLabel = Text -> Text
Color.red Text
"XPASS"
            , testResultMessage :: TestResultMessage
testResultMessage = Text -> TestResultMessage
TestResultMessageInline Text
reason
            }
        else
          TestResult
            { testResultSuccess :: Bool
testResultSuccess = Bool
True
            , testResultLabel :: Text
testResultLabel = Text -> Text
Color.yellow Text
"XFAIL"
            , testResultMessage :: TestResultMessage
testResultMessage = Text -> TestResultMessage
TestResultMessageInline Text
reason
            }

-- | Skip all tests in the given spec.
--
-- Can be selected with the marker @@skip@
skip :: String -> Spec -> Spec
skip :: FilePath -> Spec -> Spec
skip = MarkerSkip -> Spec -> Spec
forall a. IsMarker a => a -> Spec -> Spec
withMarker (MarkerSkip -> Spec -> Spec)
-> (FilePath -> MarkerSkip) -> FilePath -> Spec -> Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> MarkerSkip
MarkerSkip (Text -> MarkerSkip)
-> (FilePath -> Text) -> FilePath -> MarkerSkip
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
Text.pack

skipHook :: Hooks
skipHook :: Hooks
skipHook =
  Hooks
defaultHooks
    { hookRunTest = \TestInfo
testInfo IO TestResult
runTest ->
        case [SomeMarker] -> Maybe MarkerSkip
forall a. IsMarker a => [SomeMarker] -> Maybe a
findMarker (TestInfo -> [SomeMarker]
TestInfo.testMarkers TestInfo
testInfo) of
          Just (MarkerSkip Text
reason) ->
            TestResult -> IO TestResult
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
              TestResult
                { testResultSuccess :: Bool
testResultSuccess = Bool
True
                , testResultLabel :: Text
testResultLabel = Text -> Text
Color.yellow Text
"SKIP"
                , testResultMessage :: TestResultMessage
testResultMessage = Text -> TestResultMessage
TestResultMessageInline Text
reason
                }
          Maybe MarkerSkip
Nothing -> IO TestResult
runTest
    }

-- | Mark tests as tests that should only be run when explicitly specified on the command line.
markManual :: Spec -> Spec
markManual :: Spec -> Spec
markManual = MarkerManual -> Spec -> Spec
forall a. IsMarker a => a -> Spec -> Spec
withMarker MarkerManual
MarkerManual

{----- Markers -----}

newtype MarkerXFail = MarkerXFail Text
  deriving (Int -> MarkerXFail -> ShowS
[MarkerXFail] -> ShowS
MarkerXFail -> FilePath
(Int -> MarkerXFail -> ShowS)
-> (MarkerXFail -> FilePath)
-> ([MarkerXFail] -> ShowS)
-> Show MarkerXFail
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MarkerXFail -> ShowS
showsPrec :: Int -> MarkerXFail -> ShowS
$cshow :: MarkerXFail -> FilePath
show :: MarkerXFail -> FilePath
$cshowList :: [MarkerXFail] -> ShowS
showList :: [MarkerXFail] -> ShowS
Show)

instance IsMarker MarkerXFail where
  getMarkerName :: MarkerXFail -> FilePath
getMarkerName MarkerXFail
_ = FilePath
"xfail"

newtype MarkerSkip = MarkerSkip Text
  deriving (Int -> MarkerSkip -> ShowS
[MarkerSkip] -> ShowS
MarkerSkip -> FilePath
(Int -> MarkerSkip -> ShowS)
-> (MarkerSkip -> FilePath)
-> ([MarkerSkip] -> ShowS)
-> Show MarkerSkip
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MarkerSkip -> ShowS
showsPrec :: Int -> MarkerSkip -> ShowS
$cshow :: MarkerSkip -> FilePath
show :: MarkerSkip -> FilePath
$cshowList :: [MarkerSkip] -> ShowS
showList :: [MarkerSkip] -> ShowS
Show)

instance IsMarker MarkerSkip where
  getMarkerName :: MarkerSkip -> FilePath
getMarkerName MarkerSkip
_ = FilePath
"skip"

data MarkerManual = MarkerManual
  deriving (Int -> MarkerManual -> ShowS
[MarkerManual] -> ShowS
MarkerManual -> FilePath
(Int -> MarkerManual -> ShowS)
-> (MarkerManual -> FilePath)
-> ([MarkerManual] -> ShowS)
-> Show MarkerManual
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MarkerManual -> ShowS
showsPrec :: Int -> MarkerManual -> ShowS
$cshow :: MarkerManual -> FilePath
show :: MarkerManual -> FilePath
$cshowList :: [MarkerManual] -> ShowS
showList :: [MarkerManual] -> ShowS
Show)

instance IsMarker MarkerManual where
  getMarkerName :: MarkerManual -> FilePath
getMarkerName MarkerManual
_ = FilePath
"manual"

-- | Adds the given marker to all the tests in the given spec.
--
-- Useful for selecting tests from the command line or identifying tests in hooks
withMarker :: (IsMarker a) => a -> Spec -> Spec
withMarker :: forall a. IsMarker a => a -> Spec -> Spec
withMarker a
m = ((SpecTree -> SpecTree) -> [SpecTree] -> [SpecTree])
-> Spec -> Spec
mapSpecTrees (\SpecTree -> SpecTree
go -> (SpecTree -> SpecTree) -> [SpecTree] -> [SpecTree]
forall a b. (a -> b) -> [a] -> [b]
map (SpecTree -> SpecTree
addMarker (SpecTree -> SpecTree)
-> (SpecTree -> SpecTree) -> SpecTree -> SpecTree
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecTree -> SpecTree
go))
  where
    marker :: SomeMarker
marker = a -> SomeMarker
forall a. IsMarker a => a -> SomeMarker
SomeMarker a
m
    addMarker :: SpecTree -> SpecTree
addMarker = \case
      group :: SpecTree
group@SpecGroup{} -> SpecTree
group
      tree :: SpecTree
tree@SpecTest{} -> SpecTree
tree{testMarkers = marker : testMarkers tree}

-- | Adds the given names as plain markers to all tests in the given spec.
--
-- See 'getMarkerName'.
withMarkers :: [String] -> Spec -> Spec
withMarkers :: [FilePath] -> Spec -> Spec
withMarkers = (FilePath -> (Spec -> Spec) -> Spec -> Spec)
-> (Spec -> Spec) -> [FilePath] -> Spec -> Spec
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\FilePath
name Spec -> Spec
acc -> AnonMarker -> Spec -> Spec
forall a. IsMarker a => a -> Spec -> Spec
withMarker (FilePath -> AnonMarker
AnonMarker FilePath
name) (Spec -> Spec) -> (Spec -> Spec) -> Spec -> Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Spec -> Spec
acc) Spec -> Spec
forall a. a -> a
id