{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

module Test.Sandwich (
  -- | Sandwich is a test framework for Haskell. See the <https://codedownio.github.io/sandwich/docs/ documentation> for details and usage examples.

  -- * Running tests with command line args
  --
  -- | These functions will read command line arguments when setting up your tests.
  -- These flags allow you filter the test tree, configure formatters, and pass your own custom options.
  --
  -- @
  -- # Run using the terminal UI formatter, webdriver headless mode, filtering to nodes matching \"Login\"
  -- stack run my-tests -- --tui --headless -f Login
  -- @
  --
  runSandwichWithCommandLineArgs
  , runSandwichWithCommandLineArgs'
  , parseCommandLineArgs

  -- * Running tests
  , runSandwich
  , runSandwich'

  -- * Basic nodes
  --
  -- | The basic building blocks of tests.
  , it
  , describe
  , parallel

  -- * Context manager nodes
  --
  -- | For introducing new contexts into tests and doing setup/teardown.
  , introduce
  , introduceWith
  , before
  , beforeEach
  , after
  , afterEach
  , around
  , aroundEach

  -- * Parallel nodes
  , module Test.Sandwich.ParallelN

  -- * Timing
  --
  -- | For timing actions within your tests. Test tree nodes are timed by default.
  , timeActionByProfile
  , timeAction
  , withTimingProfile
  , withTimingProfile'

  -- * Exports
  , module Test.Sandwich.Contexts
  , module Test.Sandwich.Expectations
  , module Test.Sandwich.Logging
  , module Test.Sandwich.Misc
  , module Test.Sandwich.Nodes
  , module Test.Sandwich.Options
  , module Test.Sandwich.TH
  ) where

import Control.Concurrent.Async
import Control.Concurrent.STM
import qualified Control.Exception as E
import Control.Monad
import Control.Monad.Free
import Control.Monad.IO.Class
import Control.Monad.Logger
import Control.Monad.Reader
import Data.Either
import Data.Function
import Data.IORef
import qualified Data.List as L
import Data.Maybe
import Data.String.Interpolate
import qualified Data.Text as T
import GHC.IO.Encoding
import Options.Applicative
import qualified Options.Applicative as OA
import System.Environment
import System.FilePath
import Test.Sandwich.ArgParsing
import Test.Sandwich.Contexts
import Test.Sandwich.Expectations
import Test.Sandwich.Formatters.Common.Count
import Test.Sandwich.Golden.Update
import Test.Sandwich.Internal.Running
import Test.Sandwich.Interpreters.FilterTreeModule
import Test.Sandwich.Interpreters.RunTree
import Test.Sandwich.Interpreters.RunTree.Util
import Test.Sandwich.Logging
import Test.Sandwich.Misc
import Test.Sandwich.Nodes
import Test.Sandwich.Options
import Test.Sandwich.ParallelN
import Test.Sandwich.RunTree
import Test.Sandwich.Shutdown
import Test.Sandwich.Signals
import Test.Sandwich.TH
import Test.Sandwich.TestTimer
import Test.Sandwich.Types.ArgParsing
import Test.Sandwich.Types.RunTree
import Test.Sandwich.Types.Spec
import Test.Sandwich.Types.TestTimer
import UnliftIO.Exception

#ifdef mingw32_HOST_OS
import System.Win32.Console (setConsoleOutputCP)
#endif


-- | Run the spec with the given 'Options'.
runSandwich :: Options -> CoreSpec -> IO ()
runSandwich :: Options -> CoreSpec -> IO ()
runSandwich Options
options CoreSpec
spec = IO (ExitReason, Int) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (ExitReason, Int) -> IO ()) -> IO (ExitReason, Int) -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe (CommandLineOptions ())
-> Options -> CoreSpec -> IO (ExitReason, Int)
runSandwich' Maybe (CommandLineOptions ())
forall a. Maybe a
Nothing Options
options CoreSpec
spec

-- | Run the spec, configuring the options from the command line.
runSandwichWithCommandLineArgs :: Options -> TopSpecWithOptions -> IO ()
runSandwichWithCommandLineArgs :: Options -> TopSpecWithOptions -> IO ()
runSandwichWithCommandLineArgs Options
baseOptions = Options -> Parser () -> TopSpecWithOptions -> IO ()
forall a.
Typeable a =>
Options -> Parser a -> TopSpecWithOptions' a -> IO ()
runSandwichWithCommandLineArgs' Options
baseOptions (() -> Parser ()
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

-- | Run the spec, configuring the options from the command line and adding user-configured command line options.
-- The options will become available as a test context, which you can access by calling 'getCommandLineOptions'.
runSandwichWithCommandLineArgs' :: forall a. (Typeable a) => Options -> Parser a -> TopSpecWithOptions' a -> IO ()
runSandwichWithCommandLineArgs' :: forall a.
Typeable a =>
Options -> Parser a -> TopSpecWithOptions' a -> IO ()
runSandwichWithCommandLineArgs' Options
baseOptions Parser a
userOptionsParser TopSpecWithOptions' a
spec = do
  (CommandLineOptions a
clo, Mod FlagFields (Maybe IndividualTestModule)
-> Parser (Maybe IndividualTestModule)
individualTestParser, [(NodeModuleInfo, Text)]
modulesAndShorthands) <- Parser a
-> TopSpecWithOptions' a
-> IO
     (CommandLineOptions a,
      Mod FlagFields (Maybe IndividualTestModule)
      -> Parser (Maybe IndividualTestModule),
      [(NodeModuleInfo, Text)])
forall a.
Typeable a =>
Parser a
-> TopSpecWithOptions' a
-> IO
     (CommandLineOptions a,
      Mod FlagFields (Maybe IndividualTestModule)
      -> Parser (Maybe IndividualTestModule),
      [(NodeModuleInfo, Text)])
parseCommandLineArgs' Parser a
userOptionsParser SpecFree context IO ()
TopSpecWithOptions' a
spec
  (Options
options, Int
repeatCount) <- IO (Options, Int) -> IO (Options, Int)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Options, Int) -> IO (Options, Int))
-> IO (Options, Int) -> IO (Options, Int)
forall a b. (a -> b) -> a -> b
$ Options -> CommandLineOptions a -> IO (Options, Int)
forall a. Options -> CommandLineOptions a -> IO (Options, Int)
addOptionsFromArgs Options
baseOptions CommandLineOptions a
clo

  if | CommandLineOptions a -> Maybe Bool
forall a. CommandLineOptions a -> Maybe Bool
optPrintGoldenFlags CommandLineOptions a
clo Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True -> do
         IO CommandLineGoldenOptions -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CommandLineGoldenOptions -> IO ())
-> IO CommandLineGoldenOptions -> IO ()
forall a b. (a -> b) -> a -> b
$ [String]
-> IO CommandLineGoldenOptions -> IO CommandLineGoldenOptions
forall a. [String] -> IO a -> IO a
withArgs [String
"--help"] (IO CommandLineGoldenOptions -> IO CommandLineGoldenOptions)
-> IO CommandLineGoldenOptions -> IO CommandLineGoldenOptions
forall a b. (a -> b) -> a -> b
$
           ParserInfo CommandLineGoldenOptions -> IO CommandLineGoldenOptions
forall a. ParserInfo a -> IO a
OA.execParser ParserInfo CommandLineGoldenOptions
goldenOptionsWithInfo
     | CommandLineOptions a -> Maybe Bool
forall a. CommandLineOptions a -> Maybe Bool
optPrintHedgehogFlags CommandLineOptions a
clo Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True -> do
         IO CommandLineHedgehogOptions -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CommandLineHedgehogOptions -> IO ())
-> IO CommandLineHedgehogOptions -> IO ()
forall a b. (a -> b) -> a -> b
$ [String]
-> IO CommandLineHedgehogOptions -> IO CommandLineHedgehogOptions
forall a. [String] -> IO a -> IO a
withArgs [String
"--help"] (IO CommandLineHedgehogOptions -> IO CommandLineHedgehogOptions)
-> IO CommandLineHedgehogOptions -> IO CommandLineHedgehogOptions
forall a b. (a -> b) -> a -> b
$
           ParserInfo CommandLineHedgehogOptions
-> IO CommandLineHedgehogOptions
forall a. ParserInfo a -> IO a
OA.execParser ParserInfo CommandLineHedgehogOptions
hedgehogOptionsWithInfo
     | CommandLineOptions a -> Maybe Bool
forall a. CommandLineOptions a -> Maybe Bool
optPrintQuickCheckFlags CommandLineOptions a
clo Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True -> do
         IO CommandLineQuickCheckOptions -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CommandLineQuickCheckOptions -> IO ())
-> IO CommandLineQuickCheckOptions -> IO ()
forall a b. (a -> b) -> a -> b
$ [String]
-> IO CommandLineQuickCheckOptions
-> IO CommandLineQuickCheckOptions
forall a. [String] -> IO a -> IO a
withArgs [String
"--help"] (IO CommandLineQuickCheckOptions
 -> IO CommandLineQuickCheckOptions)
-> IO CommandLineQuickCheckOptions
-> IO CommandLineQuickCheckOptions
forall a b. (a -> b) -> a -> b
$
           ParserInfo CommandLineQuickCheckOptions
-> IO CommandLineQuickCheckOptions
forall a. ParserInfo a -> IO a
OA.execParser ParserInfo CommandLineQuickCheckOptions
quickCheckOptionsWithInfo
     | CommandLineOptions a -> Maybe Bool
forall a. CommandLineOptions a -> Maybe Bool
optPrintSlackFlags CommandLineOptions a
clo Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True -> do
         IO CommandLineSlackOptions -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CommandLineSlackOptions -> IO ())
-> IO CommandLineSlackOptions -> IO ()
forall a b. (a -> b) -> a -> b
$ [String]
-> IO CommandLineSlackOptions -> IO CommandLineSlackOptions
forall a. [String] -> IO a -> IO a
withArgs [String
"--help"] (IO CommandLineSlackOptions -> IO CommandLineSlackOptions)
-> IO CommandLineSlackOptions -> IO CommandLineSlackOptions
forall a b. (a -> b) -> a -> b
$
           ParserInfo CommandLineSlackOptions -> IO CommandLineSlackOptions
forall a. ParserInfo a -> IO a
OA.execParser ParserInfo CommandLineSlackOptions
slackOptionsWithInfo
     | CommandLineOptions a -> Maybe Bool
forall a. CommandLineOptions a -> Maybe Bool
optPrintWebDriverFlags CommandLineOptions a
clo Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True -> do
         IO CommandLineWebdriverOptions -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO CommandLineWebdriverOptions -> IO ())
-> IO CommandLineWebdriverOptions -> IO ()
forall a b. (a -> b) -> a -> b
$ [String]
-> IO CommandLineWebdriverOptions -> IO CommandLineWebdriverOptions
forall a. [String] -> IO a -> IO a
withArgs [String
"--help"] (IO CommandLineWebdriverOptions -> IO CommandLineWebdriverOptions)
-> IO CommandLineWebdriverOptions -> IO CommandLineWebdriverOptions
forall a b. (a -> b) -> a -> b
$
           ParserInfo CommandLineWebdriverOptions
-> IO CommandLineWebdriverOptions
forall a. ParserInfo a -> IO a
OA.execParser ParserInfo CommandLineWebdriverOptions
webDriverOptionsWithInfo
     | CommandLineOptions a -> Maybe Bool
forall a. CommandLineOptions a -> Maybe Bool
optListAvailableTests CommandLineOptions a
clo Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True -> do
         IO (Maybe IndividualTestModule) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe IndividualTestModule) -> IO ())
-> IO (Maybe IndividualTestModule) -> IO ()
forall a b. (a -> b) -> a -> b
$ [String]
-> IO (Maybe IndividualTestModule)
-> IO (Maybe IndividualTestModule)
forall a. [String] -> IO a -> IO a
withArgs [String
"--help"] (IO (Maybe IndividualTestModule)
 -> IO (Maybe IndividualTestModule))
-> IO (Maybe IndividualTestModule)
-> IO (Maybe IndividualTestModule)
forall a b. (a -> b) -> a -> b
$
           ParserInfo (Maybe IndividualTestModule)
-> IO (Maybe IndividualTestModule)
forall a. ParserInfo a -> IO a
OA.execParser (ParserInfo (Maybe IndividualTestModule)
 -> IO (Maybe IndividualTestModule))
-> ParserInfo (Maybe IndividualTestModule)
-> IO (Maybe IndividualTestModule)
forall a b. (a -> b) -> a -> b
$ Parser (Maybe IndividualTestModule)
-> InfoMod (Maybe IndividualTestModule)
-> ParserInfo (Maybe IndividualTestModule)
forall a. Parser a -> InfoMod a -> ParserInfo a
OA.info (Mod FlagFields (Maybe IndividualTestModule)
-> Parser (Maybe IndividualTestModule)
individualTestParser Mod FlagFields (Maybe IndividualTestModule)
forall a. Monoid a => a
mempty Parser (Maybe IndividualTestModule)
-> Parser
     (Maybe IndividualTestModule -> Maybe IndividualTestModule)
-> Parser (Maybe IndividualTestModule)
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (Maybe IndividualTestModule -> Maybe IndividualTestModule)
forall a. Parser (a -> a)
helper) (InfoMod (Maybe IndividualTestModule)
 -> ParserInfo (Maybe IndividualTestModule))
-> InfoMod (Maybe IndividualTestModule)
-> ParserInfo (Maybe IndividualTestModule)
forall a b. (a -> b) -> a -> b
$
             InfoMod (Maybe IndividualTestModule)
forall a. InfoMod a
fullDesc InfoMod (Maybe IndividualTestModule)
-> InfoMod (Maybe IndividualTestModule)
-> InfoMod (Maybe IndividualTestModule)
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod (Maybe IndividualTestModule)
forall a. String -> InfoMod a
header String
"Pass one of these flags to run an individual test module."
                      InfoMod (Maybe IndividualTestModule)
-> InfoMod (Maybe IndividualTestModule)
-> InfoMod (Maybe IndividualTestModule)
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod (Maybe IndividualTestModule)
forall a. String -> InfoMod a
progDesc String
"If a module has a \"*\" next to its name, then we detected that it has its own main function. If you pass the option name suffixed by -main then we'll just directly invoke the main function."
     | CommandLineGoldenOptions -> Maybe Bool
optUpdateGolden (CommandLineOptions a -> CommandLineGoldenOptions
forall a. CommandLineOptions a -> CommandLineGoldenOptions
optGoldenOptions CommandLineOptions a
clo) Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True -> do
         Maybe String -> IO ()
updateGolden (CommandLineGoldenOptions -> Maybe String
optGoldenDir (CommandLineOptions a -> CommandLineGoldenOptions
forall a. CommandLineOptions a -> CommandLineGoldenOptions
optGoldenOptions CommandLineOptions a
clo))
     | Bool
otherwise -> do
         -- Awkward, but we need a specific context type to call countItNodes
         let totalTests :: Int
totalTests = Free
  (SpecCommand
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> (LabelValue "commandLineOptions" (CommandLineOptions a)
          :> BaseContext))
     IO)
  ()
-> Int
forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> Int
countItNodes (Free
  (SpecCommand
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> (LabelValue "commandLineOptions" (CommandLineOptions a)
          :> BaseContext))
     IO)
  ()
TopSpecWithOptions' a
spec :: SpecFree (LabelValue "someCommandLineOptions" SomeCommandLineOptions :> LabelValue "commandLineOptions" (CommandLineOptions a) :> BaseContext) IO ())

         let cliNodeOptions :: NodeOptions
cliNodeOptions = NodeOptions
defaultNodeOptions { nodeOptionsVisibilityThreshold = systemVisibilityThreshold
                                                 , nodeOptionsCreateFolder = False }

         Int -> Int -> IO (ExitReason, Int) -> IO ()
runWithRepeat Int
repeatCount Int
totalTests (IO (ExitReason, Int) -> IO ()) -> IO (ExitReason, Int) -> IO ()
forall a b. (a -> b) -> a -> b
$
           case CommandLineOptions a -> Maybe IndividualTestModule
forall a. CommandLineOptions a -> Maybe IndividualTestModule
optIndividualTestModule CommandLineOptions a
clo of
             Maybe IndividualTestModule
Nothing -> Maybe (CommandLineOptions ())
-> Options -> CoreSpec -> IO (ExitReason, Int)
runSandwich' (CommandLineOptions () -> Maybe (CommandLineOptions ())
forall a. a -> Maybe a
Just (CommandLineOptions () -> Maybe (CommandLineOptions ()))
-> CommandLineOptions () -> Maybe (CommandLineOptions ())
forall a b. (a -> b) -> a -> b
$ CommandLineOptions a
clo { optUserOptions = () }) Options
options (CoreSpec -> IO (ExitReason, Int))
-> CoreSpec -> IO (ExitReason, Int)
forall a b. (a -> b) -> a -> b
$
               NodeOptions
-> String
-> Label "someCommandLineOptions" SomeCommandLineOptions
-> ExampleT BaseContext IO SomeCommandLineOptions
-> (HasCallStack =>
    SomeCommandLineOptions -> ExampleT BaseContext IO ())
-> SpecFree
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     ()
-> CoreSpec
forall intro (l :: Symbol) context (m :: * -> *).
(HasCallStack, Typeable intro) =>
NodeOptions
-> String
-> Label l intro
-> ExampleT context m intro
-> (HasCallStack => intro -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduce' NodeOptions
cliNodeOptions String
"some command line options" Label "someCommandLineOptions" SomeCommandLineOptions
someCommandLineOptions (SomeCommandLineOptions
-> ExampleT BaseContext IO SomeCommandLineOptions
forall a. a -> ExampleT BaseContext IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommandLineOptions a -> SomeCommandLineOptions
forall a. CommandLineOptions a -> SomeCommandLineOptions
SomeCommandLineOptions CommandLineOptions a
clo)) (ExampleT BaseContext IO ()
-> SomeCommandLineOptions -> ExampleT BaseContext IO ()
forall a b. a -> b -> a
const (ExampleT BaseContext IO ()
 -> SomeCommandLineOptions -> ExampleT BaseContext IO ())
-> ExampleT BaseContext IO ()
-> SomeCommandLineOptions
-> ExampleT BaseContext IO ()
forall a b. (a -> b) -> a -> b
$ () -> ExampleT BaseContext IO ()
forall a. a -> ExampleT BaseContext IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                 (SpecFree
   (LabelValue "someCommandLineOptions" SomeCommandLineOptions
    :> BaseContext)
   IO
   ()
 -> CoreSpec)
-> SpecFree
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     ()
-> CoreSpec
forall a b. (a -> b) -> a -> b
$ NodeOptions
-> String
-> Label "commandLineOptions" (CommandLineOptions a)
-> ExampleT
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     (CommandLineOptions a)
-> (HasCallStack =>
    CommandLineOptions a
    -> ExampleT
         (LabelValue "someCommandLineOptions" SomeCommandLineOptions
          :> BaseContext)
         IO
         ())
-> SpecFree
     (LabelValue "commandLineOptions" (CommandLineOptions a)
      :> (LabelValue "someCommandLineOptions" SomeCommandLineOptions
          :> BaseContext))
     IO
     ()
-> SpecFree
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     ()
forall intro (l :: Symbol) context (m :: * -> *).
(HasCallStack, Typeable intro) =>
NodeOptions
-> String
-> Label l intro
-> ExampleT context m intro
-> (HasCallStack => intro -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduce' NodeOptions
cliNodeOptions String
"command line options" Label "commandLineOptions" (CommandLineOptions a)
forall a. Label "commandLineOptions" (CommandLineOptions a)
commandLineOptions (CommandLineOptions a
-> ExampleT
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     (CommandLineOptions a)
forall a.
a
-> ExampleT
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommandLineOptions a
clo) (ExampleT
  (LabelValue "someCommandLineOptions" SomeCommandLineOptions
   :> BaseContext)
  IO
  ()
-> CommandLineOptions a
-> ExampleT
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     ()
forall a b. a -> b -> a
const (ExampleT
   (LabelValue "someCommandLineOptions" SomeCommandLineOptions
    :> BaseContext)
   IO
   ()
 -> CommandLineOptions a
 -> ExampleT
      (LabelValue "someCommandLineOptions" SomeCommandLineOptions
       :> BaseContext)
      IO
      ())
-> ExampleT
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     ()
-> CommandLineOptions a
-> ExampleT
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     ()
forall a b. (a -> b) -> a -> b
$ ()
-> ExampleT
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     ()
forall a.
a
-> ExampleT
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                 (SpecFree
   (LabelValue "commandLineOptions" (CommandLineOptions a)
    :> (LabelValue "someCommandLineOptions" SomeCommandLineOptions
        :> BaseContext))
   IO
   ()
 -> SpecFree
      (LabelValue "someCommandLineOptions" SomeCommandLineOptions
       :> BaseContext)
      IO
      ())
-> SpecFree
     (LabelValue "commandLineOptions" (CommandLineOptions a)
      :> (LabelValue "someCommandLineOptions" SomeCommandLineOptions
          :> BaseContext))
     IO
     ()
-> SpecFree
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     ()
forall a b. (a -> b) -> a -> b
$ SpecFree
  (LabelValue "commandLineOptions" (CommandLineOptions a)
   :> (LabelValue "someCommandLineOptions" SomeCommandLineOptions
       :> BaseContext))
  IO
  ()
TopSpecWithOptions' a
spec
             Just (IndividualTestModuleName String
x) -> Maybe (CommandLineOptions ())
-> Options -> CoreSpec -> IO (ExitReason, Int)
runSandwich' (CommandLineOptions () -> Maybe (CommandLineOptions ())
forall a. a -> Maybe a
Just (CommandLineOptions () -> Maybe (CommandLineOptions ()))
-> CommandLineOptions () -> Maybe (CommandLineOptions ())
forall a b. (a -> b) -> a -> b
$ CommandLineOptions a
clo { optUserOptions = () }) Options
options (CoreSpec -> IO (ExitReason, Int))
-> CoreSpec -> IO (ExitReason, Int)
forall a b. (a -> b) -> a -> b
$ String -> CoreSpec -> CoreSpec
forall context (m :: * -> *).
String
-> Free (SpecCommand context m) ()
-> Free (SpecCommand context m) ()
filterTreeToModule String
x (CoreSpec -> CoreSpec) -> CoreSpec -> CoreSpec
forall a b. (a -> b) -> a -> b
$
               NodeOptions
-> String
-> Label "someCommandLineOptions" SomeCommandLineOptions
-> ExampleT BaseContext IO SomeCommandLineOptions
-> (HasCallStack =>
    SomeCommandLineOptions -> ExampleT BaseContext IO ())
-> SpecFree
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     ()
-> CoreSpec
forall intro (l :: Symbol) context (m :: * -> *).
(HasCallStack, Typeable intro) =>
NodeOptions
-> String
-> Label l intro
-> ExampleT context m intro
-> (HasCallStack => intro -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduce' NodeOptions
cliNodeOptions String
"some command line options" Label "someCommandLineOptions" SomeCommandLineOptions
someCommandLineOptions (SomeCommandLineOptions
-> ExampleT BaseContext IO SomeCommandLineOptions
forall a. a -> ExampleT BaseContext IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommandLineOptions a -> SomeCommandLineOptions
forall a. CommandLineOptions a -> SomeCommandLineOptions
SomeCommandLineOptions CommandLineOptions a
clo)) (ExampleT BaseContext IO ()
-> SomeCommandLineOptions -> ExampleT BaseContext IO ()
forall a b. a -> b -> a
const (ExampleT BaseContext IO ()
 -> SomeCommandLineOptions -> ExampleT BaseContext IO ())
-> ExampleT BaseContext IO ()
-> SomeCommandLineOptions
-> ExampleT BaseContext IO ()
forall a b. (a -> b) -> a -> b
$ () -> ExampleT BaseContext IO ()
forall a. a -> ExampleT BaseContext IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                 (SpecFree
   (LabelValue "someCommandLineOptions" SomeCommandLineOptions
    :> BaseContext)
   IO
   ()
 -> CoreSpec)
-> SpecFree
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     ()
-> CoreSpec
forall a b. (a -> b) -> a -> b
$ NodeOptions
-> String
-> Label "commandLineOptions" (CommandLineOptions a)
-> ExampleT
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     (CommandLineOptions a)
-> (HasCallStack =>
    CommandLineOptions a
    -> ExampleT
         (LabelValue "someCommandLineOptions" SomeCommandLineOptions
          :> BaseContext)
         IO
         ())
-> SpecFree
     (LabelValue "commandLineOptions" (CommandLineOptions a)
      :> (LabelValue "someCommandLineOptions" SomeCommandLineOptions
          :> BaseContext))
     IO
     ()
-> SpecFree
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     ()
forall intro (l :: Symbol) context (m :: * -> *).
(HasCallStack, Typeable intro) =>
NodeOptions
-> String
-> Label l intro
-> ExampleT context m intro
-> (HasCallStack => intro -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduce' NodeOptions
cliNodeOptions String
"command line options" Label "commandLineOptions" (CommandLineOptions a)
forall a. Label "commandLineOptions" (CommandLineOptions a)
commandLineOptions (CommandLineOptions a
-> ExampleT
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     (CommandLineOptions a)
forall a.
a
-> ExampleT
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommandLineOptions a
clo) (ExampleT
  (LabelValue "someCommandLineOptions" SomeCommandLineOptions
   :> BaseContext)
  IO
  ()
-> CommandLineOptions a
-> ExampleT
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     ()
forall a b. a -> b -> a
const (ExampleT
   (LabelValue "someCommandLineOptions" SomeCommandLineOptions
    :> BaseContext)
   IO
   ()
 -> CommandLineOptions a
 -> ExampleT
      (LabelValue "someCommandLineOptions" SomeCommandLineOptions
       :> BaseContext)
      IO
      ())
-> ExampleT
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     ()
-> CommandLineOptions a
-> ExampleT
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     ()
forall a b. (a -> b) -> a -> b
$ ()
-> ExampleT
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     ()
forall a.
a
-> ExampleT
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                 (SpecFree
   (LabelValue "commandLineOptions" (CommandLineOptions a)
    :> (LabelValue "someCommandLineOptions" SomeCommandLineOptions
        :> BaseContext))
   IO
   ()
 -> SpecFree
      (LabelValue "someCommandLineOptions" SomeCommandLineOptions
       :> BaseContext)
      IO
      ())
-> SpecFree
     (LabelValue "commandLineOptions" (CommandLineOptions a)
      :> (LabelValue "someCommandLineOptions" SomeCommandLineOptions
          :> BaseContext))
     IO
     ()
-> SpecFree
     (LabelValue "someCommandLineOptions" SomeCommandLineOptions
      :> BaseContext)
     IO
     ()
forall a b. (a -> b) -> a -> b
$ SpecFree
  (LabelValue "commandLineOptions" (CommandLineOptions a)
   :> (LabelValue "someCommandLineOptions" SomeCommandLineOptions
       :> BaseContext))
  IO
  ()
TopSpecWithOptions' a
spec
             Just (IndividualTestMainFn IO ()
x) -> do
               let individualTestFlagStrings :: [Text]
individualTestFlagStrings = [[ Text -> Maybe Text
forall a. a -> Maybe a
Just (Text
"--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
shorthand), Text -> IO () -> Text
forall a b. a -> b -> a
const (Text
"--" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
shorthand Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"-main") (IO () -> Text) -> Maybe (IO ()) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (IO ())
nodeModuleInfoFn ]
                                               | (NodeModuleInfo {String
Maybe (IO ())
nodeModuleInfoFn :: Maybe (IO ())
nodeModuleInfoModuleName :: String
nodeModuleInfoModuleName :: NodeModuleInfo -> String
nodeModuleInfoFn :: NodeModuleInfo -> Maybe (IO ())
..}, Text
shorthand) <- [(NodeModuleInfo, Text)]
modulesAndShorthands]
                                             [[Maybe Text]] -> ([[Maybe Text]] -> [Maybe Text]) -> [Maybe Text]
forall a b. a -> (a -> b) -> b
& [[Maybe Text]] -> [Maybe Text]
forall a. Monoid a => [a] -> a
mconcat
                                             [Maybe Text] -> ([Maybe Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
& [Maybe Text] -> [Text]
forall a. [Maybe a] -> [a]
catMaybes
               [String]
baseArgs <- IO [String]
getArgs
               [String] -> IO (ExitReason, Int) -> IO (ExitReason, Int)
forall a. [String] -> IO a -> IO a
withArgs ([String]
baseArgs [String] -> [String] -> [String]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ ((Text -> String) -> [Text] -> [String]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
T.unpack [Text]
individualTestFlagStrings)) (IO (ExitReason, Int) -> IO (ExitReason, Int))
-> IO (ExitReason, Int) -> IO (ExitReason, Int)
forall a b. (a -> b) -> a -> b
$
                 IO () -> IO (Either SomeException ())
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
tryAny IO ()
x IO (Either SomeException ())
-> (Either SomeException () -> IO (ExitReason, Int))
-> IO (ExitReason, Int)
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                   Left SomeException
_ -> (ExitReason, Int) -> IO (ExitReason, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitReason
NormalExit, Int
1)
                   Right ()
_ -> (ExitReason, Int) -> IO (ExitReason, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitReason
NormalExit, Int
0)

-- | Run the spec with optional custom 'CommandLineOptions'. When finished, return the exit reason and number of failures.
runSandwich' :: Maybe (CommandLineOptions ()) -> Options -> CoreSpec -> IO (ExitReason, Int)
runSandwich' :: Maybe (CommandLineOptions ())
-> Options -> CoreSpec -> IO (ExitReason, Int)
runSandwich' Maybe (CommandLineOptions ())
maybeCommandLineOptions Options
options CoreSpec
spec' = do
  BaseContext
baseContext <- Options -> IO BaseContext
baseContextFromOptions Options
options

  -- To prevent weird errors saving files like "commitAndReleaseBuffer: invalid argument (invalid character)",
  -- especially on Windows
  -- See https://gitlab.haskell.org/ghc/ghc/issues/8118
  TextEncoding -> IO ()
setLocaleEncoding TextEncoding
utf8
#ifdef mingw32_HOST_OS
  -- Fix Windows console output. Makes sandwich-hedgehog unicode print properly
  setConsoleOutputCP 65001
#endif

  -- Wrap the spec in a finalizer for the test timer, when one is present
  let spec :: CoreSpec
spec = case BaseContext -> TestTimer
baseContextTestTimer BaseContext
baseContext of
        TestTimer
NullTestTimer -> CoreSpec
spec'
        TestTimer
_ -> NodeOptions
-> String -> ExampleT BaseContext IO () -> CoreSpec -> CoreSpec
forall context (m :: * -> *).
HasCallStack =>
NodeOptions
-> String
-> ExampleT context m ()
-> SpecFree context m ()
-> SpecFree context m ()
after' (NodeOptions
defaultNodeOptions { nodeOptionsRecordTime = False
                                        , nodeOptionsVisibilityThreshold = systemVisibilityThreshold
                                        , nodeOptionsCreateFolder = False }) String
"Finalize test timer" ((BaseContext -> TestTimer) -> ExampleT BaseContext IO TestTimer
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks BaseContext -> TestTimer
forall context. HasTestTimer context => context -> TestTimer
getTestTimer ExampleT BaseContext IO TestTimer
-> (TestTimer -> ExampleT BaseContext IO ())
-> ExampleT BaseContext IO ()
forall a b.
ExampleT BaseContext IO a
-> (a -> ExampleT BaseContext IO b) -> ExampleT BaseContext IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> ExampleT BaseContext IO ()
forall a. IO a -> ExampleT BaseContext IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExampleT BaseContext IO ())
-> (TestTimer -> IO ()) -> TestTimer -> ExampleT BaseContext IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TestTimer -> IO ()
finalizeSpeedScopeTestTimer) CoreSpec
spec'

  [RunNode BaseContext]
rts <- BaseContext -> Options -> CoreSpec -> IO [RunNode BaseContext]
startSandwichTree' BaseContext
baseContext Options
options CoreSpec
spec

  [Async ()]
formatterAsyncs <- [SomeFormatter]
-> (SomeFormatter -> IO (Async ())) -> IO [Async ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (Options -> [SomeFormatter]
optionsFormatters Options
options) ((SomeFormatter -> IO (Async ())) -> IO [Async ()])
-> (SomeFormatter -> IO (Async ())) -> IO [Async ()]
forall a b. (a -> b) -> a -> b
$ \(SomeFormatter f
f) -> IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ do
    let loggingFn :: LoggingT IO a -> IO a
loggingFn = case BaseContext -> Maybe String
baseContextRunRoot BaseContext
baseContext of
          Maybe String
Nothing -> (LoggingT IO a
 -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO a)
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> LoggingT IO a
-> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO a
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO a
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT (\Loc
_ Text
_ LogLevel
_ LogStr
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
          Just String
rootPath -> String -> LoggingT IO a -> IO a
forall (m :: * -> *) a.
MonadBaseControl IO m =>
String -> LoggingT m a -> m a
runFileLoggingT (String
rootPath String -> String -> String
</> (f -> String
forall f. Formatter f => f -> String
formatterName f
f) String -> String -> String
<.> String
"log")

    LoggingT IO () -> IO ()
forall {a}. LoggingT IO a -> IO a
loggingFn (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      f
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> LoggingT IO ()
forall f (m :: * -> *).
(Formatter f, MonadLoggerIO m, MonadUnliftIO m, MonadCatch m) =>
f
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
forall (m :: * -> *).
(MonadLoggerIO m, MonadUnliftIO m, MonadCatch m) =>
f
-> [RunNode BaseContext]
-> Maybe (CommandLineOptions ())
-> BaseContext
-> m ()
runFormatter f
f [RunNode BaseContext]
rts Maybe (CommandLineOptions ())
maybeCommandLineOptions BaseContext
baseContext

  IORef ExitReason
exitReasonRef <- ExitReason -> IO (IORef ExitReason)
forall a. a -> IO (IORef a)
newIORef ExitReason
NormalExit

  let shutdown :: Signal -> IO ()
shutdown Signal
sig = do
        let Text
signalName :: T.Text =
              if | Signal
sig Signal -> Signal -> Bool
forall a. Eq a => a -> a -> Bool
== Signal
sigINT -> Text
"sigINT"
                 | Signal
sig Signal -> Signal -> Bool
forall a. Eq a => a -> a -> Bool
== Signal
sigTERM -> Text
"sigTERM"
                 | Bool
otherwise -> [i|signal #{sig}|]
        String -> IO ()
putStrLn [i|Shutting down due to #{signalName}...|]
        IORef ExitReason -> ExitReason -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ExitReason
exitReasonRef ExitReason
SignalExit
        [RunNode BaseContext] -> (RunNode BaseContext -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [RunNode BaseContext]
rts RunNode BaseContext -> IO ()
forall context. RunNode context -> IO ()
cancelNode

  ()
_ <- Signal -> (Signal -> IO ()) -> IO ()
installHandler Signal
sigINT Signal -> IO ()
shutdown
  ()
_ <- Signal -> (Signal -> IO ()) -> IO ()
installHandler Signal
sigTERM Signal -> IO ()
shutdown

  -- Wait for the tree to finish
  (RunNode BaseContext -> IO Result)
-> [RunNode BaseContext] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ RunNode BaseContext -> IO Result
forall context. RunNode context -> IO Result
waitForTree [RunNode BaseContext]
rts

  -- Wait for all formatters to finish
  [Either SomeException ()]
finalResults :: [Either E.SomeException ()] <- [Async ()]
-> (Async () -> IO (Either SomeException ()))
-> IO [Either SomeException ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Async ()]
formatterAsyncs ((Async () -> IO (Either SomeException ()))
 -> IO [Either SomeException ()])
-> (Async () -> IO (Either SomeException ()))
-> IO [Either SomeException ()]
forall a b. (a -> b) -> a -> b
$ IO () -> IO (Either SomeException ())
forall e a. Exception e => IO a -> IO (Either e a)
E.try (IO () -> IO (Either SomeException ()))
-> (Async () -> IO ()) -> Async () -> IO (Either SomeException ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Async () -> IO ()
forall a. Async a -> IO a
wait
  let failures :: [SomeException]
failures = [Either SomeException ()] -> [SomeException]
forall a b. [Either a b] -> [a]
lefts [Either SomeException ()]
finalResults
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([SomeException] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SomeException]
failures) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> IO ()
putStrLn [i|Some formatters failed: '#{failures}'|]

  -- Run finalizeFormatter method on formatters
  [SomeFormatter] -> (SomeFormatter -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Options -> [SomeFormatter]
optionsFormatters Options
options) ((SomeFormatter -> IO ()) -> IO ())
-> (SomeFormatter -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(SomeFormatter f
f) -> do
    let loggingFn :: LoggingT IO a -> IO a
loggingFn = case BaseContext -> Maybe String
baseContextRunRoot BaseContext
baseContext of
          Maybe String
Nothing -> (LoggingT IO a
 -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO a)
-> (Loc -> Text -> LogLevel -> LogStr -> IO ())
-> LoggingT IO a
-> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip LoggingT IO a
-> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> IO a
forall (m :: * -> *) a.
LoggingT m a -> (Loc -> Text -> LogLevel -> LogStr -> IO ()) -> m a
runLoggingT (\Loc
_ Text
_ LogLevel
_ LogStr
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
          Just String
rootPath -> String -> LoggingT IO a -> IO a
forall (m :: * -> *) a.
MonadBaseControl IO m =>
String -> LoggingT m a -> m a
runFileLoggingT (String
rootPath String -> String -> String
</> (f -> String
forall f. Formatter f => f -> String
formatterName f
f) String -> String -> String
<.> String
"log")

    LoggingT IO () -> IO ()
forall {a}. LoggingT IO a -> IO a
loggingFn (LoggingT IO () -> IO ()) -> LoggingT IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ f -> [RunNode BaseContext] -> BaseContext -> LoggingT IO ()
forall f (m :: * -> *).
(Formatter f, MonadIO m, MonadLogger m, MonadCatch m) =>
f -> [RunNode BaseContext] -> BaseContext -> m ()
forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadCatch m) =>
f -> [RunNode BaseContext] -> BaseContext -> m ()
finalizeFormatter f
f [RunNode BaseContext]
rts BaseContext
baseContext

  [RunNodeFixed BaseContext]
fixedTree <- STM [RunNodeFixed BaseContext] -> IO [RunNodeFixed BaseContext]
forall a. STM a -> IO a
atomically (STM [RunNodeFixed BaseContext] -> IO [RunNodeFixed BaseContext])
-> STM [RunNodeFixed BaseContext] -> IO [RunNodeFixed BaseContext]
forall a b. (a -> b) -> a -> b
$ (RunNode BaseContext -> STM (RunNodeFixed BaseContext))
-> [RunNode BaseContext] -> STM [RunNodeFixed BaseContext]
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 RunNode BaseContext -> STM (RunNodeFixed BaseContext)
forall context. RunNode context -> STM (RunNodeFixed context)
fixRunTree [RunNode BaseContext]
rts
  let failed :: Int
failed = (forall ctx.
 RunNodeWithStatus ctx Status (Seq LogEntry) Bool -> Bool)
-> [RunNodeFixed BaseContext] -> Int
forall s l t context.
(forall ctx. RunNodeWithStatus ctx s l t -> Bool)
-> [RunNodeWithStatus context s l t] -> Int
countWhere RunNodeWithStatus ctx Status (Seq LogEntry) Bool -> Bool
forall ctx.
RunNodeWithStatus ctx Status (Seq LogEntry) Bool -> Bool
forall {context} {l} {t}.
RunNodeWithStatus context Status l t -> Bool
isFailedItBlock [RunNodeFixed BaseContext]
fixedTree
  ExitReason
exitReason <- IORef ExitReason -> IO ExitReason
forall a. IORef a -> IO a
readIORef IORef ExitReason
exitReasonRef
  (ExitReason, Int) -> IO (ExitReason, Int)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitReason
exitReason, Int
failed)


-- | Count the it nodes
countItNodes :: Free (SpecCommand context m) r -> Int
countItNodes :: forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> Int
countItNodes (Free x :: SpecCommand context m (Free (SpecCommand context m) r)
x@(It'' {})) = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Free (SpecCommand context m) r -> Int
forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> Int
countItNodes (SpecCommand context m (Free (SpecCommand context m) r)
-> Free (SpecCommand context m) r
forall context (m :: * -> *) next.
SpecCommand context m next -> next
next SpecCommand context m (Free (SpecCommand context m) r)
x)
countItNodes (Free (IntroduceWith'' {String
Maybe SrcLoc
Free (SpecCommand context m) r
SpecFree (LabelValue l intro :> context) m ()
NodeOptions
Label l intro
(intro -> ExampleT context m [Result]) -> ExampleT context m ()
next :: forall context (m :: * -> *) next.
SpecCommand context m next -> next
location :: Maybe SrcLoc
nodeOptions :: NodeOptions
label :: String
contextLabel :: Label l intro
introduceAction :: (intro -> ExampleT context m [Result]) -> ExampleT context m ()
subspecAugmented :: SpecFree (LabelValue l intro :> context) m ()
next :: Free (SpecCommand context m) r
location :: forall context (m :: * -> *) next.
SpecCommand context m next -> Maybe SrcLoc
nodeOptions :: forall context (m :: * -> *) next.
SpecCommand context m next -> NodeOptions
label :: forall context (m :: * -> *) next.
SpecCommand context m next -> String
contextLabel :: ()
subspecAugmented :: ()
introduceAction :: ()
..})) = Free (SpecCommand context m) r -> Int
forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> Int
countItNodes Free (SpecCommand context m) r
next Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SpecFree (LabelValue l intro :> context) m () -> Int
forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> Int
countItNodes SpecFree (LabelValue l intro :> context) m ()
subspecAugmented
countItNodes (Free (Introduce'' {String
Maybe SrcLoc
Free (SpecCommand context m) r
SpecFree (LabelValue l intro :> context) m ()
NodeOptions
Label l intro
ExampleT context m intro
intro -> ExampleT context m ()
next :: forall context (m :: * -> *) next.
SpecCommand context m next -> next
location :: forall context (m :: * -> *) next.
SpecCommand context m next -> Maybe SrcLoc
nodeOptions :: forall context (m :: * -> *) next.
SpecCommand context m next -> NodeOptions
label :: forall context (m :: * -> *) next.
SpecCommand context m next -> String
contextLabel :: ()
subspecAugmented :: ()
location :: Maybe SrcLoc
nodeOptions :: NodeOptions
label :: String
contextLabel :: Label l intro
allocate :: ExampleT context m intro
cleanup :: intro -> ExampleT context m ()
subspecAugmented :: SpecFree (LabelValue l intro :> context) m ()
next :: Free (SpecCommand context m) r
allocate :: ()
cleanup :: ()
..})) = Free (SpecCommand context m) r -> Int
forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> Int
countItNodes Free (SpecCommand context m) r
next Int -> Int -> Int
forall a. Num a => a -> a -> a
+ SpecFree (LabelValue l intro :> context) m () -> Int
forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> Int
countItNodes SpecFree (LabelValue l intro :> context) m ()
subspecAugmented
countItNodes (Free SpecCommand context m (Free (SpecCommand context m) r)
x) = Free (SpecCommand context m) r -> Int
forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> Int
countItNodes (SpecCommand context m (Free (SpecCommand context m) r)
-> Free (SpecCommand context m) r
forall context (m :: * -> *) next.
SpecCommand context m next -> next
next SpecCommand context m (Free (SpecCommand context m) r)
x) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Free (SpecCommand context m) () -> Int
forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> Int
countItNodes (SpecCommand context m (Free (SpecCommand context m) r)
-> Free (SpecCommand context m) ()
forall context (m :: * -> *) next.
SpecCommand context m next -> SpecFree context m ()
subspec SpecCommand context m (Free (SpecCommand context m) r)
x)
countItNodes (Pure r
_) = Int
0