{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}

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

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

  -- * 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.Exception.Safe
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 Options.Applicative
import qualified Options.Applicative as OA
import System.Environment
import System.FilePath
import System.Posix.Signals
import Test.Sandwich.ArgParsing
import Test.Sandwich.Contexts
import Test.Sandwich.Expectations
import Test.Sandwich.Formatters.Common.Count
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.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


-- | 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 (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' :: 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 TopSpecWithOptions' a
spec
  (Options
options, Int
repeatCount) <- IO (Options, Int) -> IO (Options, Int)
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
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."
     | Bool
otherwise -> do
         -- Awkward, but we need a specific context type to call countItNodes
         let totalTests :: Int
totalTests = Free
  (SpecCommand
     (LabelValue "commandLineOptions" (CommandLineOptions a)
      :> BaseContext)
     IO)
  ()
-> Int
forall context (m :: * -> *) r.
Free (SpecCommand context m) r -> Int
countItNodes (Free
  (SpecCommand
     (LabelValue "commandLineOptions" (CommandLineOptions a)
      :> BaseContext)
     IO)
  ()
TopSpecWithOptions' a
spec :: SpecFree (LabelValue "commandLineOptions" (CommandLineOptions a) :> BaseContext) IO ())

         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 :: ()
optUserOptions = () }) Options
options (CoreSpec -> IO (ExitReason, Int))
-> CoreSpec -> IO (ExitReason, Int)
forall a b. (a -> b) -> a -> b
$
               NodeOptions
-> String
-> Label "commandLineOptions" (CommandLineOptions a)
-> ExampleT BaseContext IO (CommandLineOptions a)
-> (CommandLineOptions a -> ExampleT BaseContext IO ())
-> Free
     (SpecCommand
        (LabelValue "commandLineOptions" (CommandLineOptions a)
         :> BaseContext)
        IO)
     ()
-> CoreSpec
forall intro (l :: Symbol) context (m :: * -> *).
(HasCallStack, Typeable intro) =>
NodeOptions
-> String
-> Label l intro
-> ExampleT context m intro
-> (intro -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduce' (NodeOptions
defaultNodeOptions { nodeOptionsVisibilityThreshold :: Int
nodeOptionsVisibilityThreshold = Int
systemVisibilityThreshold }) String
"command line options" Label "commandLineOptions" (CommandLineOptions a)
forall a. Label "commandLineOptions" (CommandLineOptions a)
commandLineOptions (CommandLineOptions a
-> ExampleT BaseContext IO (CommandLineOptions a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommandLineOptions a
clo) (ExampleT BaseContext IO ()
-> CommandLineOptions a -> ExampleT BaseContext IO ()
forall a b. a -> b -> a
const (ExampleT BaseContext IO ()
 -> CommandLineOptions a -> ExampleT BaseContext IO ())
-> ExampleT BaseContext IO ()
-> CommandLineOptions a
-> ExampleT BaseContext IO ()
forall a b. (a -> b) -> a -> b
$ () -> ExampleT BaseContext IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Free
  (SpecCommand
     (LabelValue "commandLineOptions" (CommandLineOptions a)
      :> 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 :: ()
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 "commandLineOptions" (CommandLineOptions a)
-> ExampleT BaseContext IO (CommandLineOptions a)
-> (CommandLineOptions a -> ExampleT BaseContext IO ())
-> Free
     (SpecCommand
        (LabelValue "commandLineOptions" (CommandLineOptions a)
         :> BaseContext)
        IO)
     ()
-> CoreSpec
forall intro (l :: Symbol) context (m :: * -> *).
(HasCallStack, Typeable intro) =>
NodeOptions
-> String
-> Label l intro
-> ExampleT context m intro
-> (intro -> ExampleT context m ())
-> SpecFree (LabelValue l intro :> context) m ()
-> SpecFree context m ()
introduce' (NodeOptions
defaultNodeOptions { nodeOptionsVisibilityThreshold :: Int
nodeOptionsVisibilityThreshold = Int
systemVisibilityThreshold }) String
"command line options" Label "commandLineOptions" (CommandLineOptions a)
forall a. Label "commandLineOptions" (CommandLineOptions a)
commandLineOptions (CommandLineOptions a
-> ExampleT BaseContext IO (CommandLineOptions a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure CommandLineOptions a
clo) (ExampleT BaseContext IO ()
-> CommandLineOptions a -> ExampleT BaseContext IO ()
forall a b. a -> b -> a
const (ExampleT BaseContext IO ()
 -> CommandLineOptions a -> ExampleT BaseContext IO ())
-> ExampleT BaseContext IO ()
-> CommandLineOptions a
-> ExampleT BaseContext IO ()
forall a b. (a -> b) -> a -> b
$ () -> ExampleT BaseContext IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) Free
  (SpecCommand
     (LabelValue "commandLineOptions" (CommandLineOptions a)
      :> 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 :: NodeModuleInfo -> Maybe (IO ())
nodeModuleInfoModuleName :: NodeModuleInfo -> String
nodeModuleInfoModuleName :: String
nodeModuleInfoFn :: 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 (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.
MonadCatch m =>
m a -> m (Either SomeException a)
tryAny IO ()
x IO (Either SomeException ())
-> (Either SomeException () -> IO (ExitReason, Int))
-> IO (ExitReason, Int)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                   Left SomeException
_ -> (ExitReason, Int) -> IO (ExitReason, Int)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitReason
NormalExit, Int
1)
                   Right ()
_ -> (ExitReason, Int) -> IO (ExitReason, Int)
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

  -- 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 :: Bool
nodeOptionsRecordTime = Bool
False
                                        , nodeOptionsVisibilityThreshold :: Int
nodeOptionsVisibilityThreshold = Int
systemVisibilityThreshold
                                        , nodeOptionsCreateFolder :: Bool
nodeOptionsCreateFolder = Bool
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO () -> ExampleT BaseContext IO ()
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 (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 ()
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 :: IO ()
shutdown = do
        String -> IO ()
putStrLn String
"Shutting down..."
        IORef ExitReason -> ExitReason -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef ExitReason
exitReasonRef ExitReason
InterruptExit
        [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

  Handler
_ <- Signal -> Handler -> Maybe SignalSet -> IO Handler
installHandler Signal
sigINT (IO () -> Handler
Catch IO ()
shutdown) Maybe SignalSet
forall a. Maybe a
Nothing

  -- 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 (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 (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 ()
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)
mapM RunNode BaseContext -> STM (RunNodeFixed BaseContext)
forall context. RunNode context -> STM (RunNodeFixed context)
fixRunTree [RunNode BaseContext]
rts
  let failed :: Int
failed = (forall context1.
 RunNodeWithStatus context1 Status (Seq LogEntry) Bool -> Bool)
-> [RunNodeFixed BaseContext] -> Int
forall s l t context.
(forall context1. RunNodeWithStatus context1 s l t -> Bool)
-> [RunNodeWithStatus context s l t] -> Int
countWhere forall context1.
RunNodeWithStatus context1 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 (m :: * -> *) a. Monad m => a -> m a
return (ExitReason
exitReason, Int
failed)


-- | Count the it nodes
countItNodes :: Free (SpecCommand context m) r -> Int
countItNodes :: 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 ()
introduceAction :: ()
subspecAugmented :: ()
contextLabel :: ()
label :: forall context (m :: * -> *) next.
SpecCommand context m next -> String
nodeOptions :: forall context (m :: * -> *) next.
SpecCommand context m next -> NodeOptions
location :: forall context (m :: * -> *) next.
SpecCommand context m next -> Maybe SrcLoc
next :: Free (SpecCommand context m) r
subspecAugmented :: SpecFree (LabelValue l intro :> context) m ()
introduceAction :: (intro -> ExampleT context m [Result]) -> ExampleT context m ()
contextLabel :: Label l intro
label :: String
nodeOptions :: NodeOptions
location :: Maybe SrcLoc
next :: forall context (m :: * -> *) next.
SpecCommand context m next -> next
..})) = 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 ()
cleanup :: ()
allocate :: ()
next :: Free (SpecCommand context m) r
subspecAugmented :: SpecFree (LabelValue l intro :> context) m ()
cleanup :: intro -> ExampleT context m ()
allocate :: ExampleT context m intro
contextLabel :: Label l intro
label :: String
nodeOptions :: NodeOptions
location :: Maybe SrcLoc
subspecAugmented :: ()
contextLabel :: ()
label :: forall context (m :: * -> *) next.
SpecCommand context m next -> String
nodeOptions :: forall context (m :: * -> *) next.
SpecCommand context m next -> NodeOptions
location :: forall context (m :: * -> *) next.
SpecCommand context m next -> Maybe SrcLoc
next :: forall context (m :: * -> *) next.
SpecCommand context m next -> next
..})) = 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