{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE NoFieldSelectors #-}

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

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

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

  -- ** Modifiers
  MarkerXFail (..),
  xfail,
  MarkerSkip (..),
  skip,
  MarkerFocus (..),
  focus,
  MarkerManual (..),
  markManual,

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

  -- ** Internal API
  getSpecTrees,
  withSpecTrees,
  mapSpecTrees,
  traverseSpecTrees,
  getSpecTests,
  mapSpecTests,
  filterSpecTests,
  traverseSpecTests,
  mapSpecs,
  traverseSpecs,
) where

import Control.Monad (guard, (>=>))
import Control.Monad.Trans.Reader qualified as Trans
import Control.Monad.Trans.Writer (Writer, execWriter, tell)
import Data.Foldable qualified as Seq
import Data.Functor.Identity (runIdentity)
import Data.Maybe (catMaybes, mapMaybe)
import Data.Sequence qualified as Seq
import Data.Text (Text)
import Data.Text qualified as Text
import Skeletest.Assertions (Testable, runTestable)
import Skeletest.Internal.Markers (
  AnonMarker (..),
  IsMarker (..),
  SomeMarker (..),
 )
import Skeletest.Internal.TestRunner (TestResult)
import Skeletest.Internal.TestTargets (TestTarget, matchesTest)
import Skeletest.Internal.TestTargets qualified as TestTargets

type Spec = SpecM ()

newtype SpecM a = Spec (Writer [SpecTree] a)
  deriving ((forall a b. (a -> b) -> SpecM a -> SpecM b)
-> (forall a b. a -> SpecM b -> SpecM a) -> Functor SpecM
forall a b. a -> SpecM b -> SpecM a
forall a b. (a -> b) -> SpecM a -> SpecM 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) -> SpecM a -> SpecM b
fmap :: forall a b. (a -> b) -> SpecM a -> SpecM b
$c<$ :: forall a b. a -> SpecM b -> SpecM a
<$ :: forall a b. a -> SpecM b -> SpecM a
Functor, Functor SpecM
Functor SpecM =>
(forall a. a -> SpecM a)
-> (forall a b. SpecM (a -> b) -> SpecM a -> SpecM b)
-> (forall a b c. (a -> b -> c) -> SpecM a -> SpecM b -> SpecM c)
-> (forall a b. SpecM a -> SpecM b -> SpecM b)
-> (forall a b. SpecM a -> SpecM b -> SpecM a)
-> Applicative SpecM
forall a. a -> SpecM a
forall a b. SpecM a -> SpecM b -> SpecM a
forall a b. SpecM a -> SpecM b -> SpecM b
forall a b. SpecM (a -> b) -> SpecM a -> SpecM b
forall a b c. (a -> b -> c) -> SpecM a -> SpecM b -> SpecM 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 -> SpecM a
pure :: forall a. a -> SpecM a
$c<*> :: forall a b. SpecM (a -> b) -> SpecM a -> SpecM b
<*> :: forall a b. SpecM (a -> b) -> SpecM a -> SpecM b
$cliftA2 :: forall a b c. (a -> b -> c) -> SpecM a -> SpecM b -> SpecM c
liftA2 :: forall a b c. (a -> b -> c) -> SpecM a -> SpecM b -> SpecM c
$c*> :: forall a b. SpecM a -> SpecM b -> SpecM b
*> :: forall a b. SpecM a -> SpecM b -> SpecM b
$c<* :: forall a b. SpecM a -> SpecM b -> SpecM a
<* :: forall a b. SpecM a -> SpecM b -> SpecM a
Applicative, Applicative SpecM
Applicative SpecM =>
(forall a b. SpecM a -> (a -> SpecM b) -> SpecM b)
-> (forall a b. SpecM a -> SpecM b -> SpecM b)
-> (forall a. a -> SpecM a)
-> Monad SpecM
forall a. a -> SpecM a
forall a b. SpecM a -> SpecM b -> SpecM b
forall a b. SpecM a -> (a -> SpecM b) -> SpecM 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. SpecM a -> (a -> SpecM b) -> SpecM b
>>= :: forall a b. SpecM a -> (a -> SpecM b) -> SpecM b
$c>> :: forall a b. SpecM a -> SpecM b -> SpecM b
>> :: forall a b. SpecM a -> SpecM b -> SpecM b
$creturn :: forall a. a -> SpecM a
return :: forall a. a -> SpecM a
Monad)

data SpecTree
  = SpecTree_Group
      { SpecTree -> Text
label :: Text
      , SpecTree -> [SpecTree]
trees :: [SpecTree]
      }
  | SpecTree_Test SpecTest

data SpecTest = SpecTest
  { SpecTest -> Text
name :: Text
  , SpecTest -> [SomeMarker]
markers :: [SomeMarker]
  -- ^ Markers, in order from least to most recently applied.
  --
  -- >>> withMarker MarkerA . withMarker MarkerB $ test ...
  --
  -- will contain
  --
  -- >>> SpecTree_Test { testMarkers = [MarkerA, MarkerB] }
  , SpecTest -> IO TestResult
action :: IO TestResult
  }

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 -> SpecM 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

-- | 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@SpecTree_Group{} -> do
      [SpecTree]
trees' <- [SpecTree] -> m [SpecTree]
go SpecTree
group.trees
      SpecTree -> m SpecTree
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpecTree
group{trees = trees'}
    stest :: SpecTree
stest@SpecTree_Test{} -> 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))

getSpecTests :: Spec -> [SpecTest]
getSpecTests :: Spec -> [SpecTest]
getSpecTests = Seq SpecTest -> [SpecTest]
forall a. Seq a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
Seq.toList (Seq SpecTest -> [SpecTest])
-> (Spec -> Seq SpecTest) -> Spec -> [SpecTest]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Writer (Seq SpecTest) Spec -> Seq SpecTest
forall w a. Writer w a -> w
execWriter (Writer (Seq SpecTest) Spec -> Seq SpecTest)
-> (Spec -> Writer (Seq SpecTest) Spec) -> Spec -> Seq SpecTest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpecTest -> WriterT (Seq SpecTest) Identity SpecTest)
-> Spec -> Writer (Seq SpecTest) Spec
forall (m :: * -> *).
Monad m =>
(SpecTest -> m SpecTest) -> Spec -> m Spec
traverseSpecTests SpecTest -> WriterT (Seq SpecTest) Identity SpecTest
forall {m :: * -> *} {b}. Monad m => b -> WriterT (Seq b) m b
go
 where
  go :: b -> WriterT (Seq b) m b
go b
stest = Seq b -> WriterT (Seq b) m ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell (b -> Seq b
forall a. a -> Seq a
Seq.singleton b
stest) WriterT (Seq b) m () -> WriterT (Seq b) m b -> WriterT (Seq b) m b
forall a b.
WriterT (Seq b) m a -> WriterT (Seq b) m b -> WriterT (Seq b) m b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> b -> WriterT (Seq b) m b
forall a. a -> WriterT (Seq b) m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure b
stest

traverseSpecTests :: (Monad m) => (SpecTest -> m SpecTest) -> Spec -> m Spec
traverseSpecTests :: forall (m :: * -> *).
Monad m =>
(SpecTest -> m SpecTest) -> Spec -> m Spec
traverseSpecTests SpecTest -> m SpecTest
f = ((SpecTree -> m SpecTree) -> [SpecTree] -> m [SpecTree])
-> Spec -> m Spec
forall (m :: * -> *).
Monad m =>
((SpecTree -> m SpecTree) -> [SpecTree] -> m [SpecTree])
-> Spec -> m Spec
traverseSpecTrees (((SpecTree -> m SpecTree) -> [SpecTree] -> m [SpecTree])
 -> Spec -> m Spec)
-> ((SpecTree -> m SpecTree) -> [SpecTree] -> m [SpecTree])
-> Spec
-> m Spec
forall a b. (a -> b) -> a -> b
$ \SpecTree -> m SpecTree
go ->
  (SpecTree -> m SpecTree) -> [SpecTree] -> m [SpecTree]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((SpecTree -> m SpecTree) -> [SpecTree] -> m [SpecTree])
-> (SpecTree -> m SpecTree) -> [SpecTree] -> m [SpecTree]
forall a b. (a -> b) -> a -> b
$
    SpecTree -> m SpecTree
go (SpecTree -> m SpecTree)
-> (SpecTree -> m SpecTree) -> SpecTree -> m SpecTree
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> \case
      group :: SpecTree
group@SpecTree_Group{} -> SpecTree -> m SpecTree
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SpecTree
group
      SpecTree_Test SpecTest
test_ -> SpecTest -> SpecTree
SpecTree_Test (SpecTest -> SpecTree) -> m SpecTest -> m SpecTree
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpecTest -> m SpecTest
f SpecTest
test_

mapSpecTests :: (SpecTest -> SpecTest) -> Spec -> Spec
mapSpecTests :: (SpecTest -> SpecTest) -> Spec -> Spec
mapSpecTests SpecTest -> SpecTest
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
. (SpecTest -> Identity SpecTest) -> Spec -> Identity Spec
forall (m :: * -> *).
Monad m =>
(SpecTest -> m SpecTest) -> Spec -> m Spec
traverseSpecTests (SpecTest -> Identity SpecTest
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SpecTest -> Identity SpecTest)
-> (SpecTest -> SpecTest) -> SpecTest -> Identity SpecTest
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpecTest -> SpecTest
f)

filterSpecTests :: (SpecTest -> Bool) -> Spec -> Spec
filterSpecTests :: (SpecTest -> Bool) -> Spec -> Spec
filterSpecTests SpecTest -> Bool
f = ((SpecTree -> SpecTree) -> [SpecTree] -> [SpecTree])
-> Spec -> Spec
mapSpecTrees (((SpecTree -> SpecTree) -> [SpecTree] -> [SpecTree])
 -> Spec -> Spec)
-> ((SpecTree -> SpecTree) -> [SpecTree] -> [SpecTree])
-> Spec
-> Spec
forall a b. (a -> b) -> a -> b
$ \SpecTree -> SpecTree
go -> (SpecTree -> Bool) -> [SpecTree] -> [SpecTree]
forall a. (a -> Bool) -> [a] -> [a]
filter SpecTree -> Bool
f' ([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
 where
  f' :: SpecTree -> Bool
f' = \case
    SpecTree_Group{} -> Bool
True
    SpecTree_Test SpecTest
test_ -> SpecTest -> Bool
f SpecTest
test_

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

type SpecRegistry = [SpecInfo]

data SpecInfo = SpecInfo
  { SpecInfo -> FilePath
specPath :: FilePath
  , SpecInfo -> Spec
spec :: Spec
  }

traverseSpecs :: (Applicative f) => (Spec -> f Spec) -> SpecRegistry -> f SpecRegistry
traverseSpecs :: forall (f :: * -> *).
Applicative f =>
(Spec -> f Spec) -> SpecRegistry -> f SpecRegistry
traverseSpecs Spec -> f Spec
f = (SpecInfo -> f SpecInfo) -> SpecRegistry -> f SpecRegistry
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ((SpecInfo -> f SpecInfo) -> SpecRegistry -> f SpecRegistry)
-> (SpecInfo -> f SpecInfo) -> SpecRegistry -> f SpecRegistry
forall a b. (a -> b) -> a -> b
$ \SpecInfo
info -> (\Spec
spec -> SpecInfo
info{spec = spec}) (Spec -> SpecInfo) -> f Spec -> f SpecInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Spec -> f Spec
f SpecInfo
info.spec

mapSpecs :: (Spec -> Spec) -> SpecRegistry -> SpecRegistry
mapSpecs :: (Spec -> Spec) -> SpecRegistry -> SpecRegistry
mapSpecs Spec -> Spec
f = Identity SpecRegistry -> SpecRegistry
forall a. Identity a -> a
runIdentity (Identity SpecRegistry -> SpecRegistry)
-> (SpecRegistry -> Identity SpecRegistry)
-> SpecRegistry
-> SpecRegistry
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Spec -> Identity Spec) -> SpecRegistry -> Identity SpecRegistry
forall (f :: * -> *).
Applicative f =>
(Spec -> f Spec) -> SpecRegistry -> f SpecRegistry
traverseSpecs (Spec -> Identity Spec
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Spec -> Identity Spec) -> (Spec -> Spec) -> Spec -> Identity Spec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Spec -> Spec
f)

-- | Remove specs with no tests.
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
info.spec
  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{spec = spec}
 where
  isEmptySpec :: SpecTree -> Bool
isEmptySpec = \case
    SpecTree_Group Text
_ [] -> Bool
True
    SpecTree
_ -> Bool
False

applyTestSelections :: TestTarget -> SpecInfo -> SpecInfo
applyTestSelections :: TestTarget -> SpecInfo -> SpecInfo
applyTestSelections TestTarget
selections SpecInfo
info = SpecInfo
info{spec = applySelections info.spec}
 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@SpecTree_Group{Text
label :: SpecTree -> Text
label :: Text
label} -> 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
label]) (SpecTree -> ReaderT [Text] m SpecTree
go SpecTree
group)
    stest :: SpecTree
stest@(SpecTree_Test SpecTest
test_) -> do
      [Text]
groups <- ReaderT [Text] m [Text]
forall (m :: * -> *) r. Monad m => ReaderT r m r
Trans.ask
      let attrs :: TestAttrs
attrs =
            TestTargets.TestAttrs
              { path :: FilePath
path = SpecInfo
info.specPath
              , identifier :: [Text]
identifier = [Text]
groups [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [SpecTest
test_.name]
              , markers :: [Text]
markers = [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 <- SpecTest
test_.markers]
              }
      Maybe SpecTree -> ReaderT [Text] m (Maybe SpecTree)
forall a. a -> ReaderT [Text] m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe SpecTree -> ReaderT [Text] m (Maybe SpecTree))
-> Maybe SpecTree -> ReaderT [Text] m (Maybe SpecTree)
forall a b. (a -> b) -> a -> b
$
        if TestTarget -> TestAttrs -> Bool
matchesTest TestTarget
selections TestAttrs
attrs
          then SpecTree -> Maybe SpecTree
forall a. a -> Maybe a
Just SpecTree
stest
          else Maybe SpecTree
forall a. Maybe a
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 =
    SpecTree_Group
      { label :: Text
label = FilePath -> Text
Text.pack FilePath
name
      , [SpecTree]
trees :: [SpecTree]
trees :: [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 -> SpecM 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 -> SpecTree
SpecTree_Test (SpecTest -> SpecTree) -> SpecTest -> SpecTree
forall a b. (a -> b) -> a -> b
$
      SpecTest
        { name :: Text
name = FilePath -> Text
Text.pack FilePath
name
        , markers :: [SomeMarker]
markers = []
        , action :: IO TestResult
action = 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

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

-- | Mark the given spec as expected to fail with the given description.
-- 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

-- | Skip all tests in the given spec with the given description.
--
-- 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

-- | If at least one test is focused, skip all unfocused tests.
--
-- This definition includes a WARNING so that CI errors if it's accidentally
-- committed (assuming CI runs with @-Wall -Werror@).
--
-- @since 0.3.4
focus :: Spec -> Spec
focus :: Spec -> Spec
focus = MarkerFocus -> Spec -> Spec
forall a. IsMarker a => a -> Spec -> Spec
withMarker MarkerFocus
MarkerFocus
{-# WARNING in "x-focused-tests" focus "focus should only be used in development" #-}

-- | 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 MarkerFocus = MarkerFocus
  deriving (Int -> MarkerFocus -> ShowS
[MarkerFocus] -> ShowS
MarkerFocus -> FilePath
(Int -> MarkerFocus -> ShowS)
-> (MarkerFocus -> FilePath)
-> ([MarkerFocus] -> ShowS)
-> Show MarkerFocus
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MarkerFocus -> ShowS
showsPrec :: Int -> MarkerFocus -> ShowS
$cshow :: MarkerFocus -> FilePath
show :: MarkerFocus -> FilePath
$cshowList :: [MarkerFocus] -> ShowS
showList :: [MarkerFocus] -> ShowS
Show)

instance IsMarker MarkerFocus where
  getMarkerName :: MarkerFocus -> FilePath
getMarkerName MarkerFocus
_ = FilePath
"focus"

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@SpecTree_Group{} -> SpecTree
group
    SpecTree_Test SpecTest
test_ -> SpecTest -> SpecTree
SpecTree_Test SpecTest
test_{markers = marker : test_.markers}

-- | 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