Support for filtering the test tree

integration-tests/cases/01-all-passing/output.txt

@@ -1,12 +1,12 @@
- [32m✓︎ [0m[2mone[0m
- two
-  [32m✓︎ [0m[2mfirst[0m
-  [32m✓︎ [0m[2msecond[0m
-  [32m✓︎ [0m[2mthird[0m
- three
-  1
-   [32m✓︎ [0m[2muno[0m
-   [32m✓︎ [0m[2mdos[0m
-  2
-   [32m✓︎ [0m[2mein[0m
+[32m✓︎ [0m[2mone[0m
+two
+ [32m✓︎ [0m[2mfirst[0m
+ [32m✓︎ [0m[2msecond[0m
+ [32m✓︎ [0m[2mthird[0m
+three
+ 1
+  [32m✓︎ [0m[2muno[0m
+  [32m✓︎ [0m[2mdos[0m
+ 2
+  [32m✓︎ [0m[2mein[0m
 [32m7 passing[0m

integration-tests/cases/02-all-failing/output.txt

@@ -1,13 +1,13 @@
- [31m1) one[0m
- two
-  [31m2) first[0m
-  [31m3) second[0m
- three
-  1
-   [31m4) uno[0m
-   [31m5) dos[0m
-  2
-   [31m6) ein[0m
+[31m1) one[0m
+two
+ [31m2) first[0m
+ [31m3) second[0m
+three
+ 1
+  [31m4) uno[0m
+  [31m5) dos[0m
+ 2
+  [31m6) ein[0m
 [31m6 failed[0m
 
 1) one

integration-tests/cases/03-some-passing/output.txt

@@ -1,13 +1,13 @@
- [31m1) one[0m
- two
-  [32m✓︎ [0m[2mfirst[0m
-  [31m2) second[0m
- three
-  1
-   [31m3) uno[0m
-   [32m✓︎ [0m[2mdos[0m
-  2
-   [32m✓︎ [0m[2mein[0m
+[31m1) one[0m
+two
+ [32m✓︎ [0m[2mfirst[0m
+ [31m2) second[0m
+three
+ 1
+  [31m3) uno[0m
+  [32m✓︎ [0m[2mdos[0m
+ 2
+  [32m✓︎ [0m[2mein[0m
 [32m3 passing[0m
 [31m3 failed[0m
 

integration-tests/cases/04-fail-fast-with-timeout/output.txt

@@ -1,5 +1,5 @@
- [32m✓︎ [0m[2mpasses quickly[0m
- [31m1) times out[0m
+[32m✓︎ [0m[2mpasses quickly[0m
+[31m1) times out[0m
 [31m1 failed[0m
 
 1) times out

integration-tests/cases/05-fail-fast-due-to-test-failure/output.txt

@@ -1,5 +1,5 @@
- [32m✓︎ [0m[2mpasses[0m
- [31m1) fails[0m
+[32m✓︎ [0m[2mpasses[0m
+[31m1) fails[0m
 [31m1 failed[0m
 
 1) fails

src/Test/Spec.purs

@@ -71,7 +71,7 @@ import Effect.Class (class MonadEffect, liftEffect)
 import Effect.Exception (Error)
 import Prim.TypeError (class Warn, Text)
 import Test.Spec.Tree (ActionWith, Item(..), Tree(..)) as Reexport
-import Test.Spec.Tree (ActionWith, Item(..), Tree(..), bimapTree, discardUnfocused, modifyAroundAction)
+import Test.Spec.Tree (ActionWith, Item(..), Tree(..), bimapTreeWithPaths, discardUnfocused, modifyAroundAction)
 
 
 type Spec a = SpecT Aff Unit Identity a
@@ -98,7 +98,10 @@ derive newtype instance monadAskSpecT :: MonadAsk r m => MonadAsk r (SpecT g i m
 derive newtype instance monadReaderSpecT :: MonadReader r m => MonadReader r (SpecT g i m)
 derive newtype instance monadStateSpecT :: MonadState s m => MonadState s (SpecT g i m)
 
-type SpecTree m a = Tree (ActionWith m a) (Item m a)
+-- | A specialization of `Tree` for the tree of actual tests. While `Tree` is a
+-- | tree of abstract things, `SpecTree` is a tree of tests, each represented by
+-- | `Item`.
+type SpecTree m a = Tree String (ActionWith m a) (Item m a)
 
 mapSpecTree
   :: forall m m' g g' i a i'
@@ -112,7 +115,7 @@ mapSpecTree g f = over SpecT $ mapWriterT $ g >>> map (map $ map f)
 data ComputationType = CleanUpWithContext (Array String) | TestWithName (NonEmptyArray String)
 
 hoistSpec :: forall m' m i a b. Monad m' => (m ~> m') -> (ComputationType -> a ~> b) -> SpecT a i m ~> SpecT b i m'
-hoistSpec onM f = mapSpecTree onM $ bimapTree onCleanUp onTest
+hoistSpec onM f = mapSpecTree onM $ bimapTreeWithPaths onCleanUp onTest
   where
     onCleanUp :: Array String -> (ActionWith a i) -> ActionWith b i
     onCleanUp name around' = \i -> f (CleanUpWithContext name) (around' i)

src/Test/Spec/Config.purs

@@ -1,5 +1,6 @@
 module Test.Spec.Config
   ( Config
+  , TreeFilter(..)
   , defaultConfig
   )
   where
@@ -8,6 +9,7 @@ import Prelude
 
 import Data.Maybe (Maybe(..))
 import Data.Time.Duration (Milliseconds(..))
+import Test.Spec (SpecTree)
 
 type Config =
   { slow :: Milliseconds
@@ -23,12 +25,19 @@ type Config =
 
   , failFast :: Boolean
   -- ^ When `true`, first failed test stops the whole run.
+
+  , filterTree :: TreeFilter
+  -- ^ The spec tree goes through this function before execution. Can be used to
+  -- filter out test cases, rearrange, annotate, etc.
   }
 
+newtype TreeFilter = TreeFilter (∀ g i. Array (SpecTree g i) -> Array (SpecTree g i))
+
 defaultConfig :: Config
 defaultConfig =
   { slow: Milliseconds 75.0
   , timeout: Just $ Milliseconds 2000.0
   , exit: true
   , failFast: false
+  , filterTree: TreeFilter identity
   }

src/Test/Spec/Reporter/Base.purs

@@ -14,12 +14,12 @@ import Control.Monad.Writer (class MonadWriter, Writer, runWriter)
 import Data.Either (Either(..))
 import Data.Foldable (all, for_, intercalate, traverse_)
 import Data.Generic.Rep (class Generic)
-import Data.List (List(..), (:), reverse)
 import Data.Map (Map)
 import Data.Map as Map
 import Data.Maybe (Maybe(..), isJust)
 import Data.Show.Generic (genericShow)
 import Data.Tuple (Tuple(..), uncurry)
+import Data.Tuple.Nested (type (/\), (/\))
 import Effect.Class (liftEffect)
 import Effect.Exception as Error
 import Pipes (await, yield)
@@ -36,12 +36,12 @@ import Test.Spec.Style (styled)
 import Test.Spec.Style as Style
 import Test.Spec.Summary (Summary(..))
 import Test.Spec.Summary as Summary
-import Test.Spec.Tree (Path)
+import Test.Spec.Tree (Path, annotateWithPaths, parentSuiteName)
 
 
 defaultSummary :: forall m
    . MonadWriter String m
-  => Array (Tree Void Result)
+  => Array (Tree String Void Result)
   -> m Unit
 defaultSummary xs = do
   case Summary.summarize xs of
@@ -55,21 +55,17 @@ defaultSummary xs = do
 printFailures
   :: forall m
    . MonadWriter String m
-  => Array (Tree Void Result)
+  => Array (Tree String Void Result)
   -> m Unit
-printFailures xs' = evalStateT (go xs') {i: 0, crumbs: Nil}
+printFailures xs' = evalStateT (go $ annotateWithPaths xs') 0
   where
-    go :: Array (Tree Void Result) -> StateT { i :: Int, crumbs :: List String } m Unit
+    go :: Array (Tree (String /\ Path) Void Result) -> StateT Int m Unit
     go = traverse_ case _ of
-      S.Node (Left n) xs -> do
-        {crumbs} <- State.get
-        State.modify_ _{crumbs = n : crumbs}
-        go xs
-        State.modify_ _{crumbs = crumbs}
+      S.Node (Left _) xs -> go xs
       S.Node (Right v) _ -> absurd v
-      S.Leaf n (Just (Failure err)) -> do
-        {i, crumbs} <- State.modify \s -> s{i = s.i +1}
-        let label = intercalate " " (reverse $ n:crumbs)
+      S.Leaf (n /\ path) (Just (Failure err)) -> do
+        i <- State.modify $ add 1
+        let label = intercalate " " (parentSuiteName path <> [n])
         tellLn $ show i <> ") " <> label
         tellLn $ styled Style.red $ Style.indent 2 <> Error.message err
       S.Leaf _ _ -> pure unit

src/Test/Spec/Reporter/Console.purs

@@ -48,7 +48,7 @@ consoleReporter = defaultReporter initialState $ defaultUpdate
       _ -> pure unit
   }
 
-printSummary :: forall m. MonadWriter String m => Array (Tree Void Result) -> m Unit
+printSummary :: ∀ n m. MonadWriter String m => Array (Tree n Void Result) -> m Unit
 printSummary = Summary.summarize >>> \(Count {passed, failed, pending}) -> do
   tellLn ""
   tellLn $ styled Style.bold "Summary"

src/Test/Spec/Runner.purs

@@ -1,19 +1,20 @@
 module Test.Spec.Runner
-  ( run
-  , runSpecT
-  , runSpec
-  , runSpec'
+  ( Reporter
   , TestEvents
-  , Reporter
   , module Test.Spec.Config
-  ) where
+  , run
+  , runSpec
+  , runSpec'
+  , runSpecT
+  )
+  where
 
 import Prelude
 
 import Control.Alternative ((<|>))
 import Control.Monad.Trans.Class (lift)
 import Control.Parallel (parTraverse, parallel, sequential)
-import Data.Array (groupBy, mapWithIndex)
+import Data.Array (concat, groupBy)
 import Data.Array.NonEmpty as NEA
 import Data.DateTime.Instant (diff)
 import Data.Either (Either(..), either)
@@ -25,6 +26,7 @@ import Data.Newtype (un)
 import Data.String (joinWith)
 import Data.Time.Duration (Milliseconds(..))
 import Data.Traversable (class Traversable, for)
+import Data.Tuple.Nested ((/\))
 import Effect (Effect)
 import Effect.Aff (Aff, attempt, delay, forkAff, joinFiber, makeAff, throwError, try)
 import Effect.Aff.AVar as AV
@@ -36,7 +38,7 @@ import Pipes.Core (Producer, Pipe, (//>))
 import Pipes.Core (runEffect, runEffectRec) as P
 import Prim.TypeError (class Warn, Text)
 import Test.Spec (Item(..), Spec, SpecT, SpecTree, Tree(..), collect)
-import Test.Spec.Config (Config, defaultConfig)
+import Test.Spec.Config (Config, TreeFilter(..), defaultConfig)
 import Test.Spec.Console as Console
 import Test.Spec.Result (Result(..))
 import Test.Spec.Runner.Event (Event, Execution(..))
@@ -45,7 +47,7 @@ import Test.Spec.Speed (speedOf)
 import Test.Spec.Style (styled)
 import Test.Spec.Style as Style
 import Test.Spec.Summary (successful)
-import Test.Spec.Tree (Path, PathItem(..), countTests, isAllParallelizable, parentSuite, parentSuiteName)
+import Test.Spec.Tree (Path, annotateWithPaths, countTests, isAllParallelizable, parentSuite, parentSuiteName)
 
 foreign import exit :: Int -> Effect Unit
 
@@ -82,24 +84,29 @@ _run
   -> m TestEvents
 _run config = collect >>> map \tests -> do
   yield (Event.Start (countTests tests))
-  let indexer index test = {test, path: [PathItem {name: Nothing, index}]}
-  r <- loop $ mapWithIndex indexer tests
+  r <- loop $ annotateWithPaths $ filteredTests tests
   yield (Event.End r)
   pure r
   where
-    loop :: Array (TestWithPath ()) -> TestEvents
-    loop tests =
-      let
-        noteWithIsAllParallelizable = map \{test,path} -> { isParallelizable: isAllParallelizable test, test, path}
-        groupByIsParallelizable = groupBy (\a b -> a.isParallelizable && b.isParallelizable)
-      in join <$> for (groupByIsParallelizable $ noteWithIsAllParallelizable tests) \g ->
-        join <$> if (NEA.head g).isParallelizable
-          then mergeProducers (runGroup <$> (NEA.toArray g))
-          else for (NEA.toArray g) runGroup
-
-    runGroup :: TestWithPath (isParallelizable :: Boolean) -> TestEvents
-    runGroup {test, path, isParallelizable} = case test of
-      (Leaf name (Just (Item item))) -> do
+    filteredTests tests = case config.filterTree of
+      TreeFilter f -> f tests
+
+    loop :: Array _ -> TestEvents
+    loop tests = do
+      let groups =
+            tests
+            <#> (\test -> { isParallelizable: isAllParallelizable test, test })
+            # groupBy \a b -> a.isParallelizable == b.isParallelizable
+
+      concat <$>
+        for groups \g ->
+          if (NEA.head g).isParallelizable
+            then concat <$> mergeProducers (runGroup <$> NEA.toArray g)
+            else concat <$> for (NEA.toArray g) runGroup
+
+    runGroup :: { isParallelizable :: Boolean, test :: _ } -> TestEvents
+    runGroup { test, isParallelizable } = case test of
+      Leaf (name /\ path) (Just (Item item)) -> do
         yield $ Event.Test (if isParallelizable then Parallel else Sequential) path name
         let example = item.example \a -> a unit
         start <- lift $ liftEffect now
@@ -111,16 +118,14 @@ _run config = collect >>> map \tests -> do
         let res = either Failure (const $ Success (speedOf config.slow duration) duration) e
         yield $ Event.TestEnd path name res
         pure [ Leaf name $ Just res ]
-      (Leaf name Nothing) -> do
+      (Leaf (name /\ path) Nothing) -> do
         yield $ Event.Pending path name
         pure [ Leaf name Nothing ]
       (Node (Right cleanup) xs) -> do
-        let indexer index x = {test:x, path: path <> [PathItem {name: Nothing, index}]}
-        loop (mapWithIndex indexer xs) <* lift (cleanup unit)
-      (Node (Left name) xs) -> do
+        loop xs <* lift (cleanup unit)
+      (Node (Left (name /\ path)) xs) -> do
         yield $ Event.Suite (if isParallelizable then Parallel else Sequential) path name
-        let indexer index x = {test:x, path: path <> [PathItem {name: Just name, index}]}
-        res <- loop (mapWithIndex indexer xs)
+        res <- loop xs
         yield $ Event.SuiteEnd path
         pure [ Node (Left name) res ]
 
@@ -145,9 +150,9 @@ mergeProducers ps = do
           loop
   loop
 
-type TestEvents = Producer Event Aff (Array (Tree Void Result))
+type TestEvents = Producer Event Aff (Array (Tree String Void Result))
 
-type Reporter = Pipe Event Event Aff (Array (Tree Void Result))
+type Reporter = Pipe Event Event Aff (Array (Tree String Void Result))
 
 -- | Run the spec with `config`, returning the results, which
 -- | are also reported using specified Reporters, if any.
@@ -159,7 +164,7 @@ runSpecT
   => Config
   -> Array Reporter
   -> SpecT Aff Unit m Unit
-  -> m (Aff (Array (Tree Void Result)))
+  -> m (Aff (Array (Tree String Void Result)))
 runSpecT config reporters spec = _run config spec <#> \runner -> do
   let
     events = foldl (>->) runner $ [failFast] <> reporters

src/Test/Spec/Runner/Event.purs

@@ -22,7 +22,7 @@ data Event
   | Test Execution Path Name
   | TestEnd Path Name Result
   | Pending Path Name
-  | End (Array (Tree Void Result))
+  | End (Array (Tree String Void Result))
 
 instance showEvent :: Show Event where
   show = case _ of

src/Test/Spec/Summary.purs

@@ -21,12 +21,12 @@ instance semigroupCount :: Semigroup Summary where
 instance monoidCount :: Monoid Summary where
   mempty = Count zero
 
-summarize :: forall a. Array (Tree a Result) -> Summary
+summarize :: ∀ n a. Array (Tree n a Result) -> Summary
 summarize = foldMap case _ of
   (Leaf _ (Just (Success _ _))) -> Count { passed: 1, failed: 0, pending: 0 }
   (Leaf _ (Just (Failure _))) -> Count { passed: 0, failed: 1, pending: 0 }
   (Leaf _ Nothing) -> Count { passed: 0, failed: 0, pending: 1 }
   (Node _ dgs) -> summarize dgs
 
-successful :: forall a. Array (Tree a Result) -> Boolean
+successful :: ∀ n a. Array (Tree n a Result) -> Boolean
 successful groups = (un Count $ summarize groups).failed == 0