module Convex.Tasty.Streaming (
  streamingJsonReporter,
  listTestsJsonIngredient,
  streamingIngredients,
  defaultMainStreaming,
  defaultMainStreamingWithIngredients,
) where

import Control.Concurrent.Async (forConcurrently_)
import Control.Concurrent.MVar (MVar, newMVar, withMVar)
import Control.Concurrent.STM
import Control.Monad (unless, when)
import Convex.Tasty.Streaming.QCStats (
  QCStatsRecorder,
  QCStatsStoreOption (..),
  lookupQCStatsByTestInfo,
  newQCStatsStore,
  storeQCStatsRecorder,
 )
import Convex.Tasty.Streaming.SrcLoc (PackageRootOpt (..), callerPackageRoot)
import Convex.Tasty.Streaming.TMSummary (
  CoverageIndexStorage (..),
  TMRecorder,
  TMStoreOption (..),
  TraceRecorder (..),
  lookupThreatModelSummary,
  newTMStore,
  storeRecorder,
 )
import Convex.Tasty.Streaming.TreeMap (buildTestMap)
import Convex.Tasty.Streaming.Types
import Data.Aeson (encode)
import Data.ByteString.Lazy.Char8 qualified as BL8
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.IntMap.Strict (IntMap)
import Data.IntMap.Strict qualified as IntMap
import Data.IntSet qualified as IntSet
import Data.Map.Strict qualified as Map
import Data.Maybe (mapMaybe)
import Data.Proxy (Proxy (..))
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Tagged (Tagged (..))
import Data.Text qualified as Text
import Data.Typeable (Typeable)
import GHC.Stack (HasCallStack, withFrozenCallStack)
import System.Exit (exitFailure)
import System.IO (BufferMode (..), hFlush, hPutStrLn, hSetBuffering, stderr, stdout)
import Test.Tasty (defaultMainWithIngredients, localOption)
import Test.Tasty.Ingredients (Ingredient (..))
import Test.Tasty.Ingredients.ConsoleReporter (consoleTestReporter)
import Test.Tasty.Options (IsOption (..), OptionDescription (..), lookupOption, mkFlagCLParser, safeRead)
import Test.Tasty.Runners (
  FailureReason (..),
  Outcome (..),
  Progress (..),
  Result (..),
  Status (..),
  TestTree (..),
  listingTests,
  parseOptions,
 )

-- | Command-line option to enable streaming JSON output
newtype StreamingJson = StreamingJson Bool
  deriving (StreamingJson -> StreamingJson -> Bool
(StreamingJson -> StreamingJson -> Bool)
-> (StreamingJson -> StreamingJson -> Bool) -> Eq StreamingJson
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: StreamingJson -> StreamingJson -> Bool
== :: StreamingJson -> StreamingJson -> Bool
$c/= :: StreamingJson -> StreamingJson -> Bool
/= :: StreamingJson -> StreamingJson -> Bool
Eq, Eq StreamingJson
Eq StreamingJson =>
(StreamingJson -> StreamingJson -> Ordering)
-> (StreamingJson -> StreamingJson -> Bool)
-> (StreamingJson -> StreamingJson -> Bool)
-> (StreamingJson -> StreamingJson -> Bool)
-> (StreamingJson -> StreamingJson -> Bool)
-> (StreamingJson -> StreamingJson -> StreamingJson)
-> (StreamingJson -> StreamingJson -> StreamingJson)
-> Ord StreamingJson
StreamingJson -> StreamingJson -> Bool
StreamingJson -> StreamingJson -> Ordering
StreamingJson -> StreamingJson -> StreamingJson
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: StreamingJson -> StreamingJson -> Ordering
compare :: StreamingJson -> StreamingJson -> Ordering
$c< :: StreamingJson -> StreamingJson -> Bool
< :: StreamingJson -> StreamingJson -> Bool
$c<= :: StreamingJson -> StreamingJson -> Bool
<= :: StreamingJson -> StreamingJson -> Bool
$c> :: StreamingJson -> StreamingJson -> Bool
> :: StreamingJson -> StreamingJson -> Bool
$c>= :: StreamingJson -> StreamingJson -> Bool
>= :: StreamingJson -> StreamingJson -> Bool
$cmax :: StreamingJson -> StreamingJson -> StreamingJson
max :: StreamingJson -> StreamingJson -> StreamingJson
$cmin :: StreamingJson -> StreamingJson -> StreamingJson
min :: StreamingJson -> StreamingJson -> StreamingJson
Ord, Typeable)

instance IsOption StreamingJson where
  defaultValue :: StreamingJson
defaultValue = Bool -> StreamingJson
StreamingJson Bool
False
  parseValue :: [Char] -> Maybe StreamingJson
parseValue = (Bool -> StreamingJson) -> Maybe Bool -> Maybe StreamingJson
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> StreamingJson
StreamingJson (Maybe Bool -> Maybe StreamingJson)
-> ([Char] -> Maybe Bool) -> [Char] -> Maybe StreamingJson
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe Bool
forall a. Read a => [Char] -> Maybe a
safeRead
  optionName :: Tagged StreamingJson [Char]
optionName = [Char] -> Tagged StreamingJson [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"streaming-json"
  optionHelp :: Tagged StreamingJson [Char]
optionHelp = [Char] -> Tagged StreamingJson [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Enable streaming NDJSON test output to stdout"
  optionCLParser :: Parser StreamingJson
optionCLParser = Mod FlagFields StreamingJson
-> StreamingJson -> Parser StreamingJson
forall v. IsOption v => Mod FlagFields v -> v -> Parser v
mkFlagCLParser Mod FlagFields StreamingJson
forall a. Monoid a => a
mempty (Bool -> StreamingJson
StreamingJson Bool
True)

-- | Command-line option to disable iteration trace collection
newtype NoTrace = NoTrace Bool
  deriving (NoTrace -> NoTrace -> Bool
(NoTrace -> NoTrace -> Bool)
-> (NoTrace -> NoTrace -> Bool) -> Eq NoTrace
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NoTrace -> NoTrace -> Bool
== :: NoTrace -> NoTrace -> Bool
$c/= :: NoTrace -> NoTrace -> Bool
/= :: NoTrace -> NoTrace -> Bool
Eq, Eq NoTrace
Eq NoTrace =>
(NoTrace -> NoTrace -> Ordering)
-> (NoTrace -> NoTrace -> Bool)
-> (NoTrace -> NoTrace -> Bool)
-> (NoTrace -> NoTrace -> Bool)
-> (NoTrace -> NoTrace -> Bool)
-> (NoTrace -> NoTrace -> NoTrace)
-> (NoTrace -> NoTrace -> NoTrace)
-> Ord NoTrace
NoTrace -> NoTrace -> Bool
NoTrace -> NoTrace -> Ordering
NoTrace -> NoTrace -> NoTrace
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: NoTrace -> NoTrace -> Ordering
compare :: NoTrace -> NoTrace -> Ordering
$c< :: NoTrace -> NoTrace -> Bool
< :: NoTrace -> NoTrace -> Bool
$c<= :: NoTrace -> NoTrace -> Bool
<= :: NoTrace -> NoTrace -> Bool
$c> :: NoTrace -> NoTrace -> Bool
> :: NoTrace -> NoTrace -> Bool
$c>= :: NoTrace -> NoTrace -> Bool
>= :: NoTrace -> NoTrace -> Bool
$cmax :: NoTrace -> NoTrace -> NoTrace
max :: NoTrace -> NoTrace -> NoTrace
$cmin :: NoTrace -> NoTrace -> NoTrace
min :: NoTrace -> NoTrace -> NoTrace
Ord, Typeable)

instance IsOption NoTrace where
  defaultValue :: NoTrace
defaultValue = Bool -> NoTrace
NoTrace Bool
False
  parseValue :: [Char] -> Maybe NoTrace
parseValue = (Bool -> NoTrace) -> Maybe Bool -> Maybe NoTrace
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> NoTrace
NoTrace (Maybe Bool -> Maybe NoTrace)
-> ([Char] -> Maybe Bool) -> [Char] -> Maybe NoTrace
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe Bool
forall a. Read a => [Char] -> Maybe a
safeRead
  optionName :: Tagged NoTrace [Char]
optionName = [Char] -> Tagged NoTrace [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"no-trace"
  optionHelp :: Tagged NoTrace [Char]
optionHelp = [Char] -> Tagged NoTrace [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Disable iteration trace collection (only effective with --streaming-json)"
  optionCLParser :: Parser NoTrace
optionCLParser = Mod FlagFields NoTrace -> NoTrace -> Parser NoTrace
forall v. IsOption v => Mod FlagFields v -> v -> Parser v
mkFlagCLParser Mod FlagFields NoTrace
forall a. Monoid a => a
mempty (Bool -> NoTrace
NoTrace Bool
True)

-- | Command-line option to list tests as JSON without running them
newtype ListTestsJson = ListTestsJson Bool
  deriving (ListTestsJson -> ListTestsJson -> Bool
(ListTestsJson -> ListTestsJson -> Bool)
-> (ListTestsJson -> ListTestsJson -> Bool) -> Eq ListTestsJson
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ListTestsJson -> ListTestsJson -> Bool
== :: ListTestsJson -> ListTestsJson -> Bool
$c/= :: ListTestsJson -> ListTestsJson -> Bool
/= :: ListTestsJson -> ListTestsJson -> Bool
Eq, Eq ListTestsJson
Eq ListTestsJson =>
(ListTestsJson -> ListTestsJson -> Ordering)
-> (ListTestsJson -> ListTestsJson -> Bool)
-> (ListTestsJson -> ListTestsJson -> Bool)
-> (ListTestsJson -> ListTestsJson -> Bool)
-> (ListTestsJson -> ListTestsJson -> Bool)
-> (ListTestsJson -> ListTestsJson -> ListTestsJson)
-> (ListTestsJson -> ListTestsJson -> ListTestsJson)
-> Ord ListTestsJson
ListTestsJson -> ListTestsJson -> Bool
ListTestsJson -> ListTestsJson -> Ordering
ListTestsJson -> ListTestsJson -> ListTestsJson
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: ListTestsJson -> ListTestsJson -> Ordering
compare :: ListTestsJson -> ListTestsJson -> Ordering
$c< :: ListTestsJson -> ListTestsJson -> Bool
< :: ListTestsJson -> ListTestsJson -> Bool
$c<= :: ListTestsJson -> ListTestsJson -> Bool
<= :: ListTestsJson -> ListTestsJson -> Bool
$c> :: ListTestsJson -> ListTestsJson -> Bool
> :: ListTestsJson -> ListTestsJson -> Bool
$c>= :: ListTestsJson -> ListTestsJson -> Bool
>= :: ListTestsJson -> ListTestsJson -> Bool
$cmax :: ListTestsJson -> ListTestsJson -> ListTestsJson
max :: ListTestsJson -> ListTestsJson -> ListTestsJson
$cmin :: ListTestsJson -> ListTestsJson -> ListTestsJson
min :: ListTestsJson -> ListTestsJson -> ListTestsJson
Ord, Typeable)

instance IsOption ListTestsJson where
  defaultValue :: ListTestsJson
defaultValue = Bool -> ListTestsJson
ListTestsJson Bool
False
  parseValue :: [Char] -> Maybe ListTestsJson
parseValue = (Bool -> ListTestsJson) -> Maybe Bool -> Maybe ListTestsJson
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Bool -> ListTestsJson
ListTestsJson (Maybe Bool -> Maybe ListTestsJson)
-> ([Char] -> Maybe Bool) -> [Char] -> Maybe ListTestsJson
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe Bool
forall a. Read a => [Char] -> Maybe a
safeRead
  optionName :: Tagged ListTestsJson [Char]
optionName = [Char] -> Tagged ListTestsJson [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"list-tests-json"
  optionHelp :: Tagged ListTestsJson [Char]
optionHelp = [Char] -> Tagged ListTestsJson [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"List all tests as a JSON object and exit without running"
  optionCLParser :: Parser ListTestsJson
optionCLParser = Mod FlagFields ListTestsJson
-> ListTestsJson -> Parser ListTestsJson
forall v. IsOption v => Mod FlagFields v -> v -> Parser v
mkFlagCLParser Mod FlagFields ListTestsJson
forall a. Monoid a => a
mempty (Bool -> ListTestsJson
ListTestsJson Bool
True)

-- | Command-line option to run only tests whose Tasty IDs are selected.
newtype TestIdFilter = TestIdFilter [Int]
  deriving (TestIdFilter -> TestIdFilter -> Bool
(TestIdFilter -> TestIdFilter -> Bool)
-> (TestIdFilter -> TestIdFilter -> Bool) -> Eq TestIdFilter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: TestIdFilter -> TestIdFilter -> Bool
== :: TestIdFilter -> TestIdFilter -> Bool
$c/= :: TestIdFilter -> TestIdFilter -> Bool
/= :: TestIdFilter -> TestIdFilter -> Bool
Eq, Eq TestIdFilter
Eq TestIdFilter =>
(TestIdFilter -> TestIdFilter -> Ordering)
-> (TestIdFilter -> TestIdFilter -> Bool)
-> (TestIdFilter -> TestIdFilter -> Bool)
-> (TestIdFilter -> TestIdFilter -> Bool)
-> (TestIdFilter -> TestIdFilter -> Bool)
-> (TestIdFilter -> TestIdFilter -> TestIdFilter)
-> (TestIdFilter -> TestIdFilter -> TestIdFilter)
-> Ord TestIdFilter
TestIdFilter -> TestIdFilter -> Bool
TestIdFilter -> TestIdFilter -> Ordering
TestIdFilter -> TestIdFilter -> TestIdFilter
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: TestIdFilter -> TestIdFilter -> Ordering
compare :: TestIdFilter -> TestIdFilter -> Ordering
$c< :: TestIdFilter -> TestIdFilter -> Bool
< :: TestIdFilter -> TestIdFilter -> Bool
$c<= :: TestIdFilter -> TestIdFilter -> Bool
<= :: TestIdFilter -> TestIdFilter -> Bool
$c> :: TestIdFilter -> TestIdFilter -> Bool
> :: TestIdFilter -> TestIdFilter -> Bool
$c>= :: TestIdFilter -> TestIdFilter -> Bool
>= :: TestIdFilter -> TestIdFilter -> Bool
$cmax :: TestIdFilter -> TestIdFilter -> TestIdFilter
max :: TestIdFilter -> TestIdFilter -> TestIdFilter
$cmin :: TestIdFilter -> TestIdFilter -> TestIdFilter
min :: TestIdFilter -> TestIdFilter -> TestIdFilter
Ord, Typeable)

instance Monoid TestIdFilter where
  mempty :: TestIdFilter
mempty = [Int] -> TestIdFilter
TestIdFilter []

instance Semigroup TestIdFilter where
  TestIdFilter [Int]
a <> :: TestIdFilter -> TestIdFilter -> TestIdFilter
<> TestIdFilter [Int]
b = [Int] -> TestIdFilter
TestIdFilter ([Int]
a [Int] -> [Int] -> [Int]
forall a. Semigroup a => a -> a -> a
<> [Int]
b)

instance IsOption TestIdFilter where
  defaultValue :: TestIdFilter
defaultValue = [Int] -> TestIdFilter
TestIdFilter []
  parseValue :: [Char] -> Maybe TestIdFilter
parseValue [Char]
raw = [Int] -> TestIdFilter
TestIdFilter ([Int] -> TestIdFilter) -> Maybe [Int] -> Maybe TestIdFilter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Maybe [Int]
parseTestIds [Char]
raw
   where
    parseTestIds :: [Char] -> Maybe [Int]
parseTestIds [Char]
s =
      let tokens :: [[Char]]
tokens = ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
trim (Char -> [Char] -> [[Char]]
forall {t}. Eq t => t -> [t] -> [[t]]
splitOn Char
',' [Char]
s)
          nonEmpty :: [[Char]]
nonEmpty = ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) [[Char]]
tokens
       in ([Char] -> Maybe Int) -> [[Char]] -> Maybe [Int]
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 [Char] -> Maybe Int
parseOne [[Char]]
nonEmpty
    parseOne :: [Char] -> Maybe Int
parseOne [Char]
token =
      case [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
safeRead [Char]
token :: Maybe Int of
        Just Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
n
        Maybe Int
_ -> Maybe Int
forall a. Maybe a
Nothing
    splitOn :: t -> [t] -> [[t]]
splitOn t
_ [] = []
    splitOn t
delim [t]
s = case (t -> Bool) -> [t] -> ([t], [t])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
delim) [t]
s of
      ([t]
a, []) -> [[t]
a]
      ([t]
a, t
_ : [t]
rest) -> [t]
a [t] -> [[t]] -> [[t]]
forall a. a -> [a] -> [a]
: t -> [t] -> [[t]]
splitOn t
delim [t]
rest
    trim :: [Char] -> [Char]
trim = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
forall a. [a] -> [a]
reverse ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ') ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
forall a. [a] -> [a]
reverse
  optionName :: Tagged TestIdFilter [Char]
optionName = [Char] -> Tagged TestIdFilter [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"test-id"
  optionHelp :: Tagged TestIdFilter [Char]
optionHelp = [Char] -> Tagged TestIdFilter [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"Run only tests whose Tasty IDs match these values (comma-separated); discover IDs with --list-tests-json"

-- | Internal option carrying filtered->original test ID remapping.
newtype TestIdRemap = TestIdRemap (Maybe (IntMap Int))

instance IsOption TestIdRemap where
  defaultValue :: TestIdRemap
defaultValue = Maybe (IntMap Int) -> TestIdRemap
TestIdRemap Maybe (IntMap Int)
forall a. Maybe a
Nothing
  parseValue :: [Char] -> Maybe TestIdRemap
parseValue = Maybe TestIdRemap -> [Char] -> Maybe TestIdRemap
forall a b. a -> b -> a
const Maybe TestIdRemap
forall a. Maybe a
Nothing
  optionName :: Tagged TestIdRemap [Char]
optionName = [Char] -> Tagged TestIdRemap [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"test-id-remap"
  optionHelp :: Tagged TestIdRemap [Char]
optionHelp = [Char] -> Tagged TestIdRemap [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"internal: filtered-to-original test id remapping"

{- | Internal option carrying a shared 'IORef Bool' that is set to 'True' by
the streaming reporter when @--streaming-json@ is active.  The
'TraceRecorder' callback checks this before emitting any events.
-}
newtype StreamingEnabledRef = StreamingEnabledRef (Maybe (IORef Bool))

instance IsOption StreamingEnabledRef where
  defaultValue :: StreamingEnabledRef
defaultValue = Maybe (IORef Bool) -> StreamingEnabledRef
StreamingEnabledRef Maybe (IORef Bool)
forall a. Maybe a
Nothing
  parseValue :: [Char] -> Maybe StreamingEnabledRef
parseValue = Maybe StreamingEnabledRef -> [Char] -> Maybe StreamingEnabledRef
forall a b. a -> b -> a
const Maybe StreamingEnabledRef
forall a. Maybe a
Nothing
  optionName :: Tagged StreamingEnabledRef [Char]
optionName = [Char] -> Tagged StreamingEnabledRef [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"streaming-enabled-ref"
  optionHelp :: Tagged StreamingEnabledRef [Char]
optionHelp = [Char] -> Tagged StreamingEnabledRef [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"internal: streaming enabled flag"

{- | Internal option carrying a shared 'MVar ()' so the reporter and the
'TraceRecorder' use the same output lock, preventing interleaved NDJSON lines.
-}
newtype OutputLockRef = OutputLockRef (Maybe (MVar ()))

instance IsOption OutputLockRef where
  defaultValue :: OutputLockRef
defaultValue = Maybe (MVar ()) -> OutputLockRef
OutputLockRef Maybe (MVar ())
forall a. Maybe a
Nothing
  parseValue :: [Char] -> Maybe OutputLockRef
parseValue = Maybe OutputLockRef -> [Char] -> Maybe OutputLockRef
forall a b. a -> b -> a
const Maybe OutputLockRef
forall a. Maybe a
Nothing
  optionName :: Tagged OutputLockRef [Char]
optionName = [Char] -> Tagged OutputLockRef [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"output-lock-ref"
  optionHelp :: Tagged OutputLockRef [Char]
optionHelp = [Char] -> Tagged OutputLockRef [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"internal: shared output lock"

{- | Internal option carrying a shared 'IORef' so the reporter can publish the
test map and the 'TraceRecorder' can read it back to resolve test IDs.
-}
newtype TestMapRef = TestMapRef (Maybe (IORef (IntMap TestInfo)))

instance IsOption TestMapRef where
  defaultValue :: TestMapRef
defaultValue = Maybe (IORef (IntMap TestInfo)) -> TestMapRef
TestMapRef Maybe (IORef (IntMap TestInfo))
forall a. Maybe a
Nothing
  parseValue :: [Char] -> Maybe TestMapRef
parseValue = Maybe TestMapRef -> [Char] -> Maybe TestMapRef
forall a b. a -> b -> a
const Maybe TestMapRef
forall a. Maybe a
Nothing
  optionName :: Tagged TestMapRef [Char]
optionName = [Char] -> Tagged TestMapRef [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"test-map-ref"
  optionHelp :: Tagged TestMapRef [Char]
optionHelp = [Char] -> Tagged TestMapRef [Char]
forall {k} (s :: k) b. b -> Tagged s b
Tagged [Char]
"internal: shared test map reference"

{- | The streaming JSON reporter ingredient.

When activated via @--streaming-json@, replaces console output with
newline-delimited JSON events streamed to stdout.
-}
streamingJsonReporter :: Ingredient
streamingJsonReporter :: Ingredient
streamingJsonReporter = [OptionDescription]
-> (OptionSet
    -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool)))
-> Ingredient
TestReporter
  [ Proxy StreamingJson -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy StreamingJson
forall {k} (t :: k). Proxy t
Proxy :: Proxy StreamingJson)
  , Proxy NoTrace -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy NoTrace
forall {k} (t :: k). Proxy t
Proxy :: Proxy NoTrace)
  , Proxy QCStatsStoreOption -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy QCStatsStoreOption
forall {k} (t :: k). Proxy t
Proxy :: Proxy QCStatsStoreOption)
  , Proxy QCStatsRecorder -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy QCStatsRecorder
forall {k} (t :: k). Proxy t
Proxy :: Proxy QCStatsRecorder)
  , Proxy TestIdRemap -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy TestIdRemap
forall {k} (t :: k). Proxy t
Proxy :: Proxy TestIdRemap)
  , Proxy TMStoreOption -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy TMStoreOption
forall {k} (t :: k). Proxy t
Proxy :: Proxy TMStoreOption)
  , Proxy TMRecorder -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy TMRecorder
forall {k} (t :: k). Proxy t
Proxy :: Proxy TMRecorder)
  , Proxy TraceRecorder -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy TraceRecorder
forall {k} (t :: k). Proxy t
Proxy :: Proxy TraceRecorder)
  , Proxy CoverageIndexStorage -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy CoverageIndexStorage
forall {k} (t :: k). Proxy t
Proxy :: Proxy CoverageIndexStorage)
  , Proxy TestMapRef -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy TestMapRef
forall {k} (t :: k). Proxy t
Proxy :: Proxy TestMapRef)
  , Proxy StreamingEnabledRef -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy StreamingEnabledRef
forall {k} (t :: k). Proxy t
Proxy :: Proxy StreamingEnabledRef)
  , Proxy OutputLockRef -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy OutputLockRef
forall {k} (t :: k). Proxy t
Proxy :: Proxy OutputLockRef)
  , Proxy PackageRootOpt -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy PackageRootOpt
forall {k} (t :: k). Proxy t
Proxy :: Proxy PackageRootOpt)
  ]
  ((OptionSet
  -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool)))
 -> Ingredient)
-> (OptionSet
    -> TestTree -> Maybe (StatusMap -> IO (Time -> IO Bool)))
-> Ingredient
forall a b. (a -> b) -> a -> b
$ \OptionSet
opts TestTree
tree -> do
    let StreamingJson Bool
enabled = OptionSet -> StreamingJson
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
    if Bool -> Bool
not Bool
enabled
      then Maybe (StatusMap -> IO (Time -> IO Bool))
forall a. Maybe a
Nothing
      else (StatusMap -> IO (Time -> IO Bool))
-> Maybe (StatusMap -> IO (Time -> IO Bool))
forall a. a -> Maybe a
Just ((StatusMap -> IO (Time -> IO Bool))
 -> Maybe (StatusMap -> IO (Time -> IO Bool)))
-> (StatusMap -> IO (Time -> IO Bool))
-> Maybe (StatusMap -> IO (Time -> IO Bool))
forall a b. (a -> b) -> a -> b
$ \StatusMap
statusMap -> do
        let TMStoreOption Maybe TMStore
mStore = OptionSet -> TMStoreOption
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
            QCStatsStoreOption Maybe QCStatsStore
mQCStatsStore = OptionSet -> QCStatsStoreOption
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
            TestMapRef Maybe (IORef (IntMap TestInfo))
mTestMapRef = OptionSet -> TestMapRef
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
            StreamingEnabledRef Maybe (IORef Bool)
mEnabledRef = OptionSet -> StreamingEnabledRef
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
            CoverageIndexStorage [SrcLocRange]
coverageIndex = OptionSet -> CoverageIndexStorage
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts

        -- Signal that streaming is active so the TraceRecorder callback
        -- (which checks the same IORef) actually emits events.
        -- When --no-trace is passed, leave the ref as False so that both
        -- trEnabled and recordIteration remain no-ops.
        let NoTrace Bool
noTrace = OptionSet -> NoTrace
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
        case Maybe (IORef Bool)
mEnabledRef of
          Just IORef Bool
ref -> IORef Bool -> Bool -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Bool
ref (Bool -> Bool
not Bool
noTrace)
          Maybe (IORef Bool)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

        -- Set line buffering for streaming
        Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
LineBuffering

        -- Use the shared output lock if provided, otherwise create a new one
        -- (backward compatibility when the reporter is used without
        -- defaultMainStreaming).
        let OutputLockRef Maybe (MVar ())
mSharedLock = OptionSet -> OutputLockRef
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
        MVar ()
outputLock <- IO (MVar ())
-> (MVar () -> IO (MVar ())) -> Maybe (MVar ()) -> IO (MVar ())
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()) MVar () -> IO (MVar ())
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (MVar ())
mSharedLock
        let emit :: Event -> IO ()
emit Event
evt = MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
outputLock ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \()
_ -> Event -> IO ()
emitEvent Event
evt

        -- Build the test index -> metadata map
        IntMap TestInfo
testMap <- OptionSet -> TestTree -> IO (IntMap TestInfo)
buildTestMap OptionSet
opts TestTree
tree

        -- Populate the shared test map ref so TraceRecorder can resolve IDs
        case Maybe (IORef (IntMap TestInfo))
mTestMapRef of
          Just IORef (IntMap TestInfo)
ref -> IORef (IntMap TestInfo) -> IntMap TestInfo -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (IntMap TestInfo)
ref IntMap TestInfo
testMap
          Maybe (IORef (IntMap TestInfo))
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

        -- Read the package root from the option set (populated by
        -- 'defaultMainStreaming' from the caller's 'HasCallStack'). Emitted
        -- once on SuiteStarted so consumers can resolve package-relative
        -- 'srcLoc.file' paths to absolute filesystem locations.
        let PackageRootOpt Maybe Text
mPkgRoot = OptionSet -> PackageRootOpt
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts

        -- Emit suite_started with full test list
        let TestIdRemap Maybe (IntMap Int)
mRemap = OptionSet -> TestIdRemap
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
            remapId :: Int -> Int
remapId Int
i = Int -> (IntMap Int -> Int) -> Maybe (IntMap Int) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
i (Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault Int
i Int
i) Maybe (IntMap Int)
mRemap
            remapInfo :: TestInfo -> TestInfo
remapInfo TestInfo
ti = TestInfo
ti{tiId = remapId (tiId ti)}
            testInfos :: [TestInfo]
testInfos = ((Int, TestInfo) -> TestInfo) -> [(Int, TestInfo)] -> [TestInfo]
forall a b. (a -> b) -> [a] -> [b]
map (TestInfo -> TestInfo
remapInfo (TestInfo -> TestInfo)
-> ((Int, TestInfo) -> TestInfo) -> (Int, TestInfo) -> TestInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, TestInfo) -> TestInfo
forall a b. (a, b) -> b
snd) ([(Int, TestInfo)] -> [TestInfo])
-> [(Int, TestInfo)] -> [TestInfo]
forall a b. (a -> b) -> a -> b
$ IntMap TestInfo -> [(Int, TestInfo)]
forall a. IntMap a -> [(Int, a)]
IntMap.toAscList IntMap TestInfo
testMap
        Event -> IO ()
emit (Event -> IO ()) -> Event -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe Text -> [TestInfo] -> [SrcLocRange] -> Event
SuiteStarted Maybe Text
mPkgRoot [TestInfo]
testInfos [SrcLocRange]
coverageIndex

        -- Track results for final summary
        TVar [(Int, Result)]
resultsVar <- [(Int, Result)] -> IO (TVar [(Int, Result)])
forall a. a -> IO (TVar a)
newTVarIO ([] :: [(Int, Result)])

        -- Watch each test concurrently
        [(Int, TVar Status)] -> ((Int, TVar Status) -> IO ()) -> IO ()
forall (f :: * -> *) a b. Foldable f => f a -> (a -> IO b) -> IO ()
forConcurrently_ (StatusMap -> [(Int, TVar Status)]
forall a. IntMap a -> [(Int, a)]
IntMap.toAscList StatusMap
statusMap) (((Int, TVar Status) -> IO ()) -> IO ())
-> ((Int, TVar Status) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
idx, TVar Status
statusTVar) -> do
          -- Wait until the test starts
          STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Status
status <- TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
statusTVar
            case Status
status of
              Status
NotStarted -> STM ()
forall a. STM a
retry
              Status
_ -> () -> STM ()
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

          -- Emit test_started
          Event -> IO ()
emit (Event -> IO ()) -> Event -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Event
TestStarted (Int -> Int
remapId Int
idx)

          -- Wait for completion, emitting progress events along the way
          let waitLoop :: Maybe ([Char], Float) -> IO Result
waitLoop Maybe ([Char], Float)
lastSeen = do
                Either Progress Result
next <- STM (Either Progress Result) -> IO (Either Progress Result)
forall a. STM a -> IO a
atomically (STM (Either Progress Result) -> IO (Either Progress Result))
-> STM (Either Progress Result) -> IO (Either Progress Result)
forall a b. (a -> b) -> a -> b
$ do
                  Status
status <- TVar Status -> STM Status
forall a. TVar a -> STM a
readTVar TVar Status
statusTVar
                  case Status
status of
                    Status
NotStarted -> STM (Either Progress Result)
forall a. STM a
retry
                    Executing Progress
p ->
                      let cur :: ([Char], Float)
cur = (Progress -> [Char]
progressText Progress
p, Progress -> Float
progressPercent Progress
p)
                       in if ([Char], Float) -> Maybe ([Char], Float)
forall a. a -> Maybe a
Just ([Char], Float)
cur Maybe ([Char], Float) -> Maybe ([Char], Float) -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ([Char], Float)
lastSeen
                            then STM (Either Progress Result)
forall a. STM a
retry
                            else Either Progress Result -> STM (Either Progress Result)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Progress -> Either Progress Result
forall a b. a -> Either a b
Left Progress
p)
                    Done Result
r -> Either Progress Result -> STM (Either Progress Result)
forall a. a -> STM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Result -> Either Progress Result
forall a b. b -> Either a b
Right Result
r)
                case Either Progress Result
next of
                  Left Progress
p -> do
                    Event -> IO ()
emit (Event -> IO ()) -> Event -> IO ()
forall a b. (a -> b) -> a -> b
$
                      TestProgress
                        { epId :: Int
epId = Int -> Int
remapId Int
idx
                        , epMessage :: Text
epMessage = [Char] -> Text
Text.pack (Progress -> [Char]
progressText Progress
p)
                        , epPercent :: Float
epPercent = Progress -> Float
progressPercent Progress
p
                        }
                    Maybe ([Char], Float) -> IO Result
waitLoop (([Char], Float) -> Maybe ([Char], Float)
forall a. a -> Maybe a
Just (Progress -> [Char]
progressText Progress
p, Progress -> Float
progressPercent Progress
p))
                  Right Result
r -> Result -> IO Result
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Result
r
          Result
result <- Maybe ([Char], Float) -> IO Result
waitLoop Maybe ([Char], Float)
forall a. Maybe a
Nothing

          -- Record result
          STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar [(Int, Result)]
-> ([(Int, Result)] -> [(Int, Result)]) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar [(Int, Result)]
resultsVar ((Int
idx, Result
result) (Int, Result) -> [(Int, Result)] -> [(Int, Result)]
forall a. a -> [a] -> [a]
:)

          -- Look up structured threat-model summary by "<group>/<name>" key
          let testInfo :: Maybe TestInfo
testInfo = Int -> IntMap TestInfo -> Maybe TestInfo
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
idx IntMap TestInfo
testMap
              key :: [Char]
key = case Maybe TestInfo
testInfo of
                Just TestInfo
ti
                  | (Text
parent : [Text]
_) <- [Text] -> [Text]
forall a. [a] -> [a]
reverse (TestInfo -> [Text]
tiPath TestInfo
ti) ->
                      Text -> [Char]
Text.unpack Text
parent [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"/" [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
Text.unpack (TestInfo -> Text
tiName TestInfo
ti)
                Just TestInfo
ti -> Text -> [Char]
Text.unpack (TestInfo -> Text
tiName TestInfo
ti)
                Maybe TestInfo
Nothing -> [Char]
""
          Maybe ThreatModelSummary
mSummary <- case Maybe TMStore
mStore of
            Just TMStore
store -> TMStore -> [Char] -> IO (Maybe ThreatModelSummary)
lookupThreatModelSummary TMStore
store [Char]
key
            Maybe TMStore
Nothing -> Maybe ThreatModelSummary -> IO (Maybe ThreatModelSummary)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ThreatModelSummary
forall a. Maybe a
Nothing
          Maybe MonitoringStats
mMonitoring <- case (Maybe QCStatsStore
mQCStatsStore, Maybe TestInfo
testInfo) of
            (Just QCStatsStore
store, Just TestInfo
ti) -> QCStatsStore -> TestInfo -> IO (Maybe MonitoringStats)
lookupQCStatsByTestInfo QCStatsStore
store TestInfo
ti
            (Maybe QCStatsStore, Maybe TestInfo)
_ -> Maybe MonitoringStats -> IO (Maybe MonitoringStats)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe MonitoringStats
forall a. Maybe a
Nothing

          -- Emit test_done
          let outcome :: TestOutcome
outcome = case Result -> Outcome
resultOutcome Result
result of
                Outcome
Success -> TestOutcome
TestSuccess
                Failure FailureReason
reason ->
                  FailureInfo -> TestOutcome
TestFailure (FailureInfo -> TestOutcome) -> FailureInfo -> TestOutcome
forall a b. (a -> b) -> a -> b
$
                    FailureInfo
                      { fiReason :: Text
fiReason = [Char] -> Text
Text.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ FailureReason -> [Char]
showFailureReason FailureReason
reason
                      , fiMessage :: Text
fiMessage = [Char] -> Text
Text.pack (Result -> [Char]
resultDescription Result
result)
                      }
          Event -> IO ()
emit (Event -> IO ()) -> Event -> IO ()
forall a b. (a -> b) -> a -> b
$
            TestDone
              { edId :: Int
edId = Int -> Int
remapId Int
idx
              , edOutcome :: TestOutcome
edOutcome = TestOutcome
outcome
              , edDuration :: Time
edDuration = Result -> Time
resultTime Result
result
              , edDescription :: Text
edDescription = [Char] -> Text
Text.pack (Result -> [Char]
resultDescription Result
result)
              , edThreatModel :: Maybe ThreatModelSummary
edThreatModel = Maybe ThreatModelSummary
mSummary
              , edMonitoringStats :: Maybe MonitoringStats
edMonitoringStats = Maybe MonitoringStats
mMonitoring
              }

        -- Emit suite_done summary
        [(Int, Result)]
allResults <- TVar [(Int, Result)] -> IO [(Int, Result)]
forall a. TVar a -> IO a
readTVarIO TVar [(Int, Result)]
resultsVar
        let passed :: Int
passed = [()] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [() | (Int
_, Result
r) <- [(Int, Result)]
allResults, Result -> Bool
isSuccess Result
r]
        let failed :: Int
failed = [(Int, Result)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Int, Result)]
allResults Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
passed

        -- Return the "finalize" callback
        (Time -> IO Bool) -> IO (Time -> IO Bool)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Time -> IO Bool) -> IO (Time -> IO Bool))
-> (Time -> IO Bool) -> IO (Time -> IO Bool)
forall a b. (a -> b) -> a -> b
$ \Time
totalTime -> do
          Event -> IO ()
emit (Event -> IO ()) -> Event -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Int -> Time -> Event
SuiteDone Int
passed Int
failed Time
totalTime
          Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
failed Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)

-- | Emit a single NDJSON event line to stdout
emitEvent :: Event -> IO ()
emitEvent :: Event -> IO ()
emitEvent Event
evt = do
  ByteString -> IO ()
BL8.putStrLn (Event -> ByteString
forall a. ToJSON a => a -> ByteString
encode Event
evt)
  Handle -> IO ()
hFlush Handle
stdout

-- | Check if a Result is a success
isSuccess :: Result -> Bool
isSuccess :: Result -> Bool
isSuccess Result
r = case Result -> Outcome
resultOutcome Result
r of
  Outcome
Success -> Bool
True
  Outcome
_ -> Bool
False

-- | Show a FailureReason as text
showFailureReason :: FailureReason -> String
showFailureReason :: FailureReason -> [Char]
showFailureReason FailureReason
TestFailed = [Char]
"TestFailed"
showFailureReason (TestThrewException SomeException
e) = [Char]
"TestThrewException: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
e
showFailureReason (TestTimedOut Integer
n) = [Char]
"TestTimedOut: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Integer -> [Char]
forall a. Show a => a -> [Char]
show Integer
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"μs"
showFailureReason FailureReason
TestDepFailed = [Char]
"TestDepFailed"

{- | Find the Tasty test ID for a test identified by group name and category.
Searches the test map for a 'TestInfo' whose path contains the group name
and whose name matches the category (e.g. \"Positive tests\", \"Negative tests\").
Returns @-1@ as a fallback when the test is not found.
-}
findTestId :: IntMap TestInfo -> String -> String -> Int
findTestId :: IntMap TestInfo -> [Char] -> [Char] -> Int
findTestId IntMap TestInfo
testMap [Char]
group [Char]
category =
  let categoryName :: [Char]
categoryName = case [Char]
category of
        [Char]
"positive" -> [Char]
"Positive tests"
        [Char]
"negative" -> [Char]
"Negative tests"
        [Char]
other -> [Char]
other
      matches :: [(Int, TestInfo)]
matches =
        IntMap TestInfo -> [(Int, TestInfo)]
forall a. IntMap a -> [(Int, a)]
IntMap.toList (IntMap TestInfo -> [(Int, TestInfo)])
-> IntMap TestInfo -> [(Int, TestInfo)]
forall a b. (a -> b) -> a -> b
$
          (TestInfo -> Bool) -> IntMap TestInfo -> IntMap TestInfo
forall a. (a -> Bool) -> IntMap a -> IntMap a
IntMap.filter
            ( \TestInfo
ti ->
                [Char] -> Text
Text.pack [Char]
group Text -> [Text] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` TestInfo -> [Text]
tiPath TestInfo
ti
                  Bool -> Bool -> Bool
&& TestInfo -> Text
tiName TestInfo
ti Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Text
Text.pack [Char]
categoryName
            )
            IntMap TestInfo
testMap
   in case [(Int, TestInfo)]
matches of
        ((Int
testId, TestInfo
_) : [(Int, TestInfo)]
_) -> Int
testId
        [] -> -Int
1 -- fallback: test not found

{- | Ingredient that lists the test tree as JSON and exits without running tests.

Activated via @--list-tests-json@.
-}
listTestsJsonIngredient :: Ingredient
listTestsJsonIngredient :: Ingredient
listTestsJsonIngredient = [OptionDescription]
-> (OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient
TestManager
  [ Proxy ListTestsJson -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy ListTestsJson
forall {k} (t :: k). Proxy t
Proxy :: Proxy ListTestsJson)
  , Proxy TestIdRemap -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy TestIdRemap
forall {k} (t :: k). Proxy t
Proxy :: Proxy TestIdRemap)
  , Proxy PackageRootOpt -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy PackageRootOpt
forall {k} (t :: k). Proxy t
Proxy :: Proxy PackageRootOpt)
  , Proxy CoverageIndexStorage -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy CoverageIndexStorage
forall {k} (t :: k). Proxy t
Proxy :: Proxy CoverageIndexStorage)
  ]
  ((OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient)
-> (OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient
forall a b. (a -> b) -> a -> b
$ \OptionSet
opts TestTree
tree -> do
    let ListTestsJson Bool
enabled = OptionSet -> ListTestsJson
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
        CoverageIndexStorage [SrcLocRange]
coverageIndex = OptionSet -> CoverageIndexStorage
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
    if Bool -> Bool
not Bool
enabled
      then Maybe (IO Bool)
forall a. Maybe a
Nothing
      else IO Bool -> Maybe (IO Bool)
forall a. a -> Maybe a
Just (IO Bool -> Maybe (IO Bool)) -> IO Bool -> Maybe (IO Bool)
forall a b. (a -> b) -> a -> b
$ do
        Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
LineBuffering
        let PackageRootOpt Maybe Text
mPkgRoot = OptionSet -> PackageRootOpt
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
            TestIdRemap Maybe (IntMap Int)
mRemap = OptionSet -> TestIdRemap
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
            remapId :: Int -> Int
remapId Int
i = Int -> (IntMap Int -> Int) -> Maybe (IntMap Int) -> Int
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int
i (Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault Int
i Int
i) Maybe (IntMap Int)
mRemap
            remapInfo :: TestInfo -> TestInfo
remapInfo TestInfo
ti = TestInfo
ti{tiId = remapId (tiId ti)}
        IntMap TestInfo
testMap <- OptionSet -> TestTree -> IO (IntMap TestInfo)
buildTestMap OptionSet
opts TestTree
tree
        let testInfos :: [TestInfo]
testInfos = ((Int, TestInfo) -> TestInfo) -> [(Int, TestInfo)] -> [TestInfo]
forall a b. (a -> b) -> [a] -> [b]
map (TestInfo -> TestInfo
remapInfo (TestInfo -> TestInfo)
-> ((Int, TestInfo) -> TestInfo) -> (Int, TestInfo) -> TestInfo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, TestInfo) -> TestInfo
forall a b. (a, b) -> b
snd) ([(Int, TestInfo)] -> [TestInfo])
-> [(Int, TestInfo)] -> [TestInfo]
forall a b. (a -> b) -> a -> b
$ IntMap TestInfo -> [(Int, TestInfo)]
forall a. IntMap a -> [(Int, a)]
IntMap.toAscList IntMap TestInfo
testMap
        Event -> IO ()
emitEvent (Event -> IO ()) -> Event -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe Text -> [TestInfo] -> [SrcLocRange] -> Event
SuiteStarted Maybe Text
mPkgRoot [TestInfo]
testInfos [SrcLocRange]
coverageIndex
        Bool -> IO Bool
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

-- | Option ingredient for selecting a subset of tests by Tasty ID.
testIdFilterIngredient :: Ingredient
testIdFilterIngredient :: Ingredient
testIdFilterIngredient =
  [OptionDescription]
-> (OptionSet -> TestTree -> Maybe (IO Bool)) -> Ingredient
TestManager
    [Proxy TestIdFilter -> OptionDescription
forall v. IsOption v => Proxy v -> OptionDescription
Option (Proxy TestIdFilter
forall {k} (t :: k). Proxy t
Proxy :: Proxy TestIdFilter)]
    (\OptionSet
_ TestTree
_ -> Maybe (IO Bool)
forall a. Maybe a
Nothing)

-- | Default ingredients with streaming reporter added
streamingIngredients :: [Ingredient]
streamingIngredients :: [Ingredient]
streamingIngredients = [Ingredient
listingTests, Ingredient
testIdFilterIngredient, Ingredient
listTestsJsonIngredient, Ingredient
streamingJsonReporter, Ingredient
consoleTestReporter]

filterTreeByPaths :: Set [String] -> TestTree -> Maybe TestTree
filterTreeByPaths :: Set [[Char]] -> TestTree -> Maybe TestTree
filterTreeByPaths Set [[Char]]
selected = [[Char]] -> TestTree -> Maybe TestTree
go []
 where
  go :: [[Char]] -> TestTree -> Maybe TestTree
go [[Char]]
path TestTree
tree = case TestTree
tree of
    SingleTest [Char]
name t
_t ->
      let fullPath :: [[Char]]
fullPath = [[Char]]
path [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]
name]
       in if [[Char]]
fullPath [[Char]] -> Set [[Char]] -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set [[Char]]
selected
            then TestTree -> Maybe TestTree
forall a. a -> Maybe a
Just TestTree
tree
            else Maybe TestTree
forall a. Maybe a
Nothing
    TestGroup [Char]
name [TestTree]
children ->
      let childPath :: [[Char]]
childPath = [[Char]]
path [[Char]] -> [[Char]] -> [[Char]]
forall a. Semigroup a => a -> a -> a
<> [[Char]
name]
          keptChildren :: [TestTree]
keptChildren = (TestTree -> Maybe TestTree) -> [TestTree] -> [TestTree]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([[Char]] -> TestTree -> Maybe TestTree
go [[Char]]
childPath) [TestTree]
children
       in if [TestTree] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TestTree]
keptChildren
            then Maybe TestTree
forall a. Maybe a
Nothing
            else TestTree -> Maybe TestTree
forall a. a -> Maybe a
Just ([Char] -> [TestTree] -> TestTree
TestGroup [Char]
name [TestTree]
keptChildren)
    PlusTestOptions OptionSet -> OptionSet
f TestTree
subtree ->
      (TestTree -> TestTree) -> Maybe TestTree -> Maybe TestTree
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((OptionSet -> OptionSet) -> TestTree -> TestTree
PlusTestOptions OptionSet -> OptionSet
f) ([[Char]] -> TestTree -> Maybe TestTree
go [[Char]]
path TestTree
subtree)
    WithResource ResourceSpec a
spec IO a -> TestTree
mkTree ->
      TestTree -> Maybe TestTree
forall a. a -> Maybe a
Just (ResourceSpec a -> (IO a -> TestTree) -> TestTree
forall a. ResourceSpec a -> (IO a -> TestTree) -> TestTree
WithResource ResourceSpec a
spec (\IO a
ioRes -> TestTree -> (TestTree -> TestTree) -> Maybe TestTree -> TestTree
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> [TestTree] -> TestTree
TestGroup [Char]
"filtered-out" []) TestTree -> TestTree
forall a. a -> a
id ([[Char]] -> TestTree -> Maybe TestTree
go [[Char]]
path (IO a -> TestTree
mkTree IO a
ioRes))))
    AskOptions OptionSet -> TestTree
k ->
      TestTree -> Maybe TestTree
forall a. a -> Maybe a
Just ((OptionSet -> TestTree) -> TestTree
AskOptions (\OptionSet
opts -> TestTree -> (TestTree -> TestTree) -> Maybe TestTree -> TestTree
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> [TestTree] -> TestTree
TestGroup [Char]
"filtered-out" []) TestTree -> TestTree
forall a. a -> a
id ([[Char]] -> TestTree -> Maybe TestTree
go [[Char]]
path (OptionSet -> TestTree
k OptionSet
opts))))
    After DependencyType
dep Expr
expr TestTree
subtree ->
      (TestTree -> TestTree) -> Maybe TestTree -> Maybe TestTree
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DependencyType -> Expr -> TestTree -> TestTree
After DependencyType
dep Expr
expr) ([[Char]] -> TestTree -> Maybe TestTree
go [[Char]]
path TestTree
subtree)

expandSelectedTestIds :: IntMap TestInfo -> IntSet.IntSet -> IntSet.IntSet
expandSelectedTestIds :: IntMap TestInfo -> IntSet -> IntSet
expandSelectedTestIds IntMap TestInfo
testMap IntSet
selectedIds =
  IntSet -> IntSet -> IntSet
IntSet.union IntSet
selectedIds IntSet
prerequisiteIds
 where
  pathToId :: Map [Text] Int
pathToId =
    [([Text], Int)] -> Map [Text] Int
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
      [ (TestInfo -> [Text]
tiPath TestInfo
ti [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [TestInfo -> Text
tiName TestInfo
ti], TestInfo -> Int
tiId TestInfo
ti)
      | TestInfo
ti <- IntMap TestInfo -> [TestInfo]
forall a. IntMap a -> [a]
IntMap.elems IntMap TestInfo
testMap
      ]
  prerequisiteIds :: IntSet
prerequisiteIds =
    [Int] -> IntSet
IntSet.fromList
      [ Int
positiveId
      | Int
selectedId <- IntSet -> [Int]
IntSet.toList IntSet
selectedIds
      , Just Int
positiveId <- [Int -> Maybe Int
positiveTestIdFor Int
selectedId]
      ]
  positiveTestIdFor :: Int -> Maybe Int
positiveTestIdFor Int
selectedId = do
    TestInfo
ti <- Int -> IntMap TestInfo -> Maybe TestInfo
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
selectedId IntMap TestInfo
testMap
    case TestInfo -> [Text]
tiPath TestInfo
ti of
      [] -> Maybe Int
forall a. Maybe a
Nothing
      [Text]
groupPath
        | [Text] -> Text
forall a. HasCallStack => [a] -> a
last [Text]
groupPath Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Text
Text.pack [Char]
"Threat models"
            Bool -> Bool -> Bool
|| [Text] -> Text
forall a. HasCallStack => [a] -> a
last [Text]
groupPath Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== [Char] -> Text
Text.pack [Char]
"Expected vulnerabilities" ->
            [Text] -> Map [Text] Int -> Maybe Int
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ([Text] -> [Text]
forall a. HasCallStack => [a] -> [a]
init [Text]
groupPath [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [[Char] -> Text
Text.pack [Char]
"Positive tests"]) Map [Text] Int
pathToId
        | Bool
otherwise -> Maybe Int
forall a. Maybe a
Nothing

{- | Drop-in replacement for 'defaultMain' that supports @--streaming-json@.

If you bypass this entry point and wire 'streamingIngredients' manually,
threat-model summaries will not appear in the JSON output unless you
also call
@'localOption' ('TMStoreOption' (Just store)) . 'localOption' ('storeRecorder' store)@
on your tree (with a freshly-allocated store from 'newTMStore').

== Package root capture

The @packageRoot@ field emitted on the @SuiteStarted@ event is captured
from the call site of 'defaultMainStreaming' (typically the user's
@Main.hs@) via 'HasCallStack'. The mechanism is implemented in
'Convex.Tasty.Streaming.SrcLoc.callerPackageRoot': read the top of
'callStack' to obtain both the GHC package identifier of the calling
module and the file path it was compiled from, then search the workspace
(starting at the process working directory) for a directory containing
both a matching @\<pkgname\>.cabal@ file and the relative source file.

This is correct in the common case where the @Main.hs@ entry point and
the tests it assembles live in the same cabal package. It is __not__
correct for cross-package test reuse — for example, if @Main.hs@ in
package /A/ pulls in test trees defined in package /B/'s library, those
tests will be attributed to package /A/, not /B/. We explicitly accept
this limitation; addressing it would require per-test source-location
metadata (e.g. via Template Haskell or CPP at every test definition
site), which is significantly more invasive.

If the resolution fails (e.g. the test is launched from a working
directory that does not contain the package, or the package name cannot
be extracted), @packageRoot@ is omitted from the JSON output (consistent
with the existing @Maybe@-as-absent-key convention).
-}
defaultMainStreaming :: (HasCallStack) => TestTree -> IO ()
defaultMainStreaming :: HasCallStack => TestTree -> IO ()
defaultMainStreaming = HasCallStack => [Ingredient] -> TestTree -> IO ()
[Ingredient] -> TestTree -> IO ()
defaultMainStreamingWithIngredients []

{- | Variant of 'defaultMainStreaming' that allows callers to prepend
additional ingredients (e.g. package-specific CLI option managers).

The same internal streaming wiring is always installed (threat-model
summary store, trace recorder, shared output lock, and package root
capture from call-site), then Tasty runs with:

@extraIngredients <> streamingIngredients@
-}
defaultMainStreamingWithIngredients :: (HasCallStack) => [Ingredient] -> TestTree -> IO ()
defaultMainStreamingWithIngredients :: HasCallStack => [Ingredient] -> TestTree -> IO ()
defaultMainStreamingWithIngredients [Ingredient]
extraIngredients TestTree
tree = do
  -- Capture the package root from the user's call site BEFORE doing any
  -- other work. 'withFrozenCallStack' freezes our caller's call stack so
  -- that inside 'callerPackageRoot' the top frame is the user's Main.hs
  -- (the call site of 'defaultMainStreaming') rather than this internal
  -- invocation of 'callerPackageRoot'.
  Maybe [Char]
mPkgRoot <- (HasCallStack => IO (Maybe [Char])) -> IO (Maybe [Char])
forall a. HasCallStack => (HasCallStack => a) -> a
withFrozenCallStack IO (Maybe [Char])
HasCallStack => IO (Maybe [Char])
callerPackageRoot
  let pkgRootOpt :: PackageRootOpt
pkgRootOpt = Maybe Text -> PackageRootOpt
PackageRootOpt (([Char] -> Text) -> Maybe [Char] -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Char] -> Text
Text.pack Maybe [Char]
mPkgRoot)
  TMStore
store <- IO TMStore
newTMStore
  QCStatsStore
qcStatsStore <- IO QCStatsStore
newQCStatsStore
  IORef (IntMap TestInfo)
testMapRef <- IntMap TestInfo -> IO (IORef (IntMap TestInfo))
forall a. a -> IO (IORef a)
newIORef IntMap TestInfo
forall a. IntMap a
IntMap.empty
  IORef (IntMap Int)
testIdRemapRef <- IntMap Int -> IO (IORef (IntMap Int))
forall a. a -> IO (IORef a)
newIORef IntMap Int
forall a. IntMap a
IntMap.empty
  IORef Bool
enabledRef <- Bool -> IO (IORef Bool)
forall a. a -> IO (IORef a)
newIORef Bool
False -- set to True by the reporter when --streaming-json is active
  -- Create a single shared output lock used by both the streaming reporter
  -- and the TraceRecorder so their NDJSON lines never interleave.
  MVar ()
outputLock <- () -> IO (MVar ())
forall a. a -> IO (MVar a)
newMVar ()
  -- Create a trace recorder that emits TestTrace events as NDJSON to stdout.
  -- The recorder reads the shared testMapRef (populated by the reporter at
  -- startup) to resolve the numeric Tasty test ID for each trace event.
  --
  -- Both 'trEnabled' and 'recordIteration' read the shared 'enabledRef',
  -- so when --streaming-json is NOT passed (or --no-trace is passed) the
  -- ref stays False: test bodies take the fast path and no NDJSON lines
  -- go to stdout.
  let traceRec :: TraceRecorder
traceRec =
        TraceRecorder
          { trEnabled :: IO Bool
trEnabled = IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
enabledRef
          , recordIteration :: [Char] -> [Char] -> [SrcLocRange] -> Value -> IO ()
recordIteration = \[Char]
group [Char]
category [SrcLocRange]
covered Value
iterationJson -> do
              Bool
enabled <- IORef Bool -> IO Bool
forall a. IORef a -> IO a
readIORef IORef Bool
enabledRef
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
enabled (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                IntMap TestInfo
testMap <- IORef (IntMap TestInfo) -> IO (IntMap TestInfo)
forall a. IORef a -> IO a
readIORef IORef (IntMap TestInfo)
testMapRef
                let testId :: Int
testId = IntMap TestInfo -> [Char] -> [Char] -> Int
findTestId IntMap TestInfo
testMap [Char]
group [Char]
category
                IntMap Int
remap <- IORef (IntMap Int) -> IO (IntMap Int)
forall a. IORef a -> IO a
readIORef IORef (IntMap Int)
testIdRemapRef
                let mappedId :: Int
mappedId = Int -> Int -> IntMap Int -> Int
forall a. a -> Int -> IntMap a -> a
IntMap.findWithDefault Int
testId Int
testId IntMap Int
remap
                MVar () -> (() -> IO ()) -> IO ()
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar ()
outputLock ((() -> IO ()) -> IO ()) -> (() -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \()
_ ->
                  Event -> IO ()
emitEvent (Event -> IO ()) -> Event -> IO ()
forall a b. (a -> b) -> a -> b
$
                    TestTrace
                      { ettTestId :: Int
ettTestId = Int
mappedId
                      , ettCategory :: Text
ettCategory = [Char] -> Text
Text.pack [Char]
category
                      , ettTrace :: Value
ettTrace = Value
iterationJson
                      , ettCovered :: [SrcLocRange]
ettCovered = [SrcLocRange]
covered
                      }
          }
  let baseTree :: TestTree
baseTree =
        PackageRootOpt -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption PackageRootOpt
pkgRootOpt (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
          QCStatsStoreOption -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Maybe QCStatsStore -> QCStatsStoreOption
QCStatsStoreOption (QCStatsStore -> Maybe QCStatsStore
forall a. a -> Maybe a
Just QCStatsStore
qcStatsStore)) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
            QCStatsRecorder -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (QCStatsStore -> QCStatsRecorder
storeQCStatsRecorder QCStatsStore
qcStatsStore) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
              TMStoreOption -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Maybe TMStore -> TMStoreOption
TMStoreOption (TMStore -> Maybe TMStore
forall a. a -> Maybe a
Just TMStore
store)) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
                TMRecorder -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (TMStore -> TMRecorder
storeRecorder TMStore
store) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
                  TestMapRef -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Maybe (IORef (IntMap TestInfo)) -> TestMapRef
TestMapRef (IORef (IntMap TestInfo) -> Maybe (IORef (IntMap TestInfo))
forall a. a -> Maybe a
Just IORef (IntMap TestInfo)
testMapRef)) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
                    StreamingEnabledRef -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Maybe (IORef Bool) -> StreamingEnabledRef
StreamingEnabledRef (IORef Bool -> Maybe (IORef Bool)
forall a. a -> Maybe a
Just IORef Bool
enabledRef)) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
                      OutputLockRef -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Maybe (MVar ()) -> OutputLockRef
OutputLockRef (MVar () -> Maybe (MVar ())
forall a. a -> Maybe a
Just MVar ()
outputLock)) (TestTree -> TestTree) -> TestTree -> TestTree
forall a b. (a -> b) -> a -> b
$
                        TraceRecorder -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption TraceRecorder
traceRec TestTree
tree

  OptionSet
opts <- [Ingredient] -> TestTree -> IO OptionSet
parseOptions ([Ingredient]
extraIngredients [Ingredient] -> [Ingredient] -> [Ingredient]
forall a. Semigroup a => a -> a -> a
<> [Ingredient]
streamingIngredients) TestTree
baseTree
  let TestIdFilter [Int]
requested = OptionSet -> TestIdFilter
forall v. IsOption v => OptionSet -> v
lookupOption OptionSet
opts
      requestedIdSet :: IntSet
requestedIdSet = [Int] -> IntSet
IntSet.fromList [Int]
requested

  TestTree
tree' <-
    if IntSet -> Bool
IntSet.null IntSet
requestedIdSet
      then TestTree -> IO TestTree
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TestTree
baseTree
      else do
        IntMap TestInfo
fullMap <- OptionSet -> TestTree -> IO (IntMap TestInfo)
buildTestMap OptionSet
opts TestTree
baseTree
        let unknown :: [Int]
unknown = IntSet -> [Int]
IntSet.toAscList (IntSet -> [Int]) -> IntSet -> [Int]
forall a b. (a -> b) -> a -> b
$ IntSet -> IntSet -> IntSet
IntSet.difference IntSet
requestedIdSet ([Int] -> IntSet
IntSet.fromList (IntMap TestInfo -> [Int]
forall a. IntMap a -> [Int]
IntMap.keys IntMap TestInfo
fullMap))
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Int] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Int]
unknown) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Unknown test id(s) for --test-id: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Int] -> [Char]
forall a. Show a => a -> [Char]
show [Int]
unknown
          Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
"Use --list-tests-json to discover valid test IDs for this suite."
          IO ()
forall a. IO a
exitFailure

        let selectedIdSet :: IntSet
selectedIdSet = IntMap TestInfo -> IntSet -> IntSet
expandSelectedTestIds IntMap TestInfo
fullMap IntSet
requestedIdSet
            selectedIds :: [Int]
selectedIds = IntSet -> [Int]
IntSet.toAscList IntSet
selectedIdSet
            selectedInfos :: [TestInfo]
selectedInfos = (Int -> TestInfo) -> [Int] -> [TestInfo]
forall a b. (a -> b) -> [a] -> [b]
map (IntMap TestInfo
fullMap IntMap TestInfo -> Int -> TestInfo
forall a. IntMap a -> Int -> a
IntMap.!) [Int]
selectedIds
            selectedPaths :: Set [[Char]]
selectedPaths =
              [[[Char]]] -> Set [[Char]]
forall a. Ord a => [a] -> Set a
Set.fromList
                [ (Text -> [Char]) -> [Text] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map Text -> [Char]
Text.unpack (TestInfo -> [Text]
tiPath TestInfo
ti [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [TestInfo -> Text
tiName TestInfo
ti])
                | TestInfo
ti <- [TestInfo]
selectedInfos
                ]
            remap :: IntMap Int
remap = [(Int, Int)] -> IntMap Int
forall a. [(Int, a)] -> IntMap a
IntMap.fromAscList ([Int] -> [Int] -> [(Int, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Int]
selectedIds)

        IORef (IntMap Int) -> IntMap Int -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (IntMap Int)
testIdRemapRef IntMap Int
remap

        case Set [[Char]] -> TestTree -> Maybe TestTree
filterTreeByPaths Set [[Char]]
selectedPaths TestTree
baseTree of
          Maybe TestTree
Nothing -> do
            Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr [Char]
"No tests remained after applying --test-id selection."
            IO TestTree
forall a. IO a
exitFailure
          Just TestTree
filteredTree ->
            TestTree -> IO TestTree
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TestTree -> IO TestTree) -> TestTree -> IO TestTree
forall a b. (a -> b) -> a -> b
$ TestIdRemap -> TestTree -> TestTree
forall v. IsOption v => v -> TestTree -> TestTree
localOption (Maybe (IntMap Int) -> TestIdRemap
TestIdRemap (IntMap Int -> Maybe (IntMap Int)
forall a. a -> Maybe a
Just IntMap Int
remap)) TestTree
filteredTree

  [Ingredient] -> TestTree -> IO ()
defaultMainWithIngredients ([Ingredient]
extraIngredients [Ingredient] -> [Ingredient] -> [Ingredient]
forall a. Semigroup a => a -> a -> a
<> [Ingredient]
streamingIngredients) TestTree
tree'