sandwich 0.1.0.8 → 0.1.0.9

raw patch · 22 files changed

+220/−80 lines, 22 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• sandwich.cabal +2/−2
• src/Test/Sandwich.hs +21/−24
• src/Test/Sandwich/ArgParsing.hs +84/−7
• src/Test/Sandwich/Formatters/FailureReport.hs +3/−0
• src/Test/Sandwich/Formatters/Print.hs +4/−0
• src/Test/Sandwich/Formatters/TerminalUI.hs +30/−18
• src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs +2/−0
• src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs +2/−0
• src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs +2/−0
• src/Test/Sandwich/Formatters/TerminalUI/Types.hs +1/−1
• src/Test/Sandwich/Internal/Running.hs +9/−8
• src/Test/Sandwich/Interpreters/StartTree.hs +6/−0
• src/Test/Sandwich/Logging.hs +6/−4
• src/Test/Sandwich/Misc.hs +1/−0
• src/Test/Sandwich/Options.hs +3/−0
• src/Test/Sandwich/ParallelN.hs +2/−2
• src/Test/Sandwich/Shutdown.hs +6/−2
• src/Test/Sandwich/TH.hs +1/−1
• src/Test/Sandwich/Types/ArgParsing.hs +15/−1
• src/Test/Sandwich/Types/RunTree.hs +8/−7
• src/Test/Sandwich/Types/Spec.hs +2/−3

@@ -2,6 +2,16 @@  ## Unreleased changes +## 0.1.0.9++* Expose `optionsDryRun` and the `--dry-run` option.+* Add command-line arguments for `sandwich-quickcheck`.+* Add `--visibility-threshold`/`-v` option.+* Fix an issue where TUI quit would hang in the presence of cleared results.+* Display number of tests run in output message.+* Catch and log exceptions in the TUI event loop.+* Change `runSandwichWithCommandLineArgs` to use the print formatter by default, since we can't figure out how to detect if we're running under `cabal test`, which redirects stdout.+ ## 0.1.0.8  * GHC 9 support

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 6924bc737e970dc68d85aa857491503c9accf2cee9d812255dadcad1c98ea77a+-- hash: d6ea486ba7ffe23a777baf26a52d55238719f87911caac302ebc2b64b70a4f32  name:           sandwich-version:        0.1.0.8+version:        0.1.0.9 synopsis:       Yet another test framework for Haskell description:    Please see the <https://codedownio.github.io/sandwich documentation>. category:       Testing

@@ -26,6 +26,7 @@   --   runSandwichWithCommandLineArgs   , runSandwichWithCommandLineArgs'+  , parseCommandLineArgs    -- * Running tests   , runSandwich@@ -74,6 +75,7 @@ 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@@ -124,31 +126,14 @@ -- 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' baseOptions userOptionsParser spec = do-  let modulesAndShorthands = gatherMainFunctions (spec :: SpecFree (LabelValue "commandLineOptions" (CommandLineOptions a) :> BaseContext) IO ())-                           & L.sortOn nodeModuleInfoModuleName-                           & gatherShorthands-  let individualTestFlags maybeInternal =-        [[ Just $ flag' (Just $ IndividualTestModuleName nodeModuleInfoModuleName)-                        (long (T.unpack shorthand)-                          <> help (nodeModuleInfoModuleName-                          <> (if isJust nodeModuleInfoFn then "*" else ""))-                          <> maybeInternal)-         , case nodeModuleInfoFn of-             Nothing -> Nothing-             Just fn -> Just $ flag' (Just $ IndividualTestMainFn fn)-                                     (long (T.unpack (shorthand <> "-main"))-                                       <> help nodeModuleInfoModuleName-                                       <> internal-                                     )-         ]-        | (NodeModuleInfo {..}, shorthand) <- modulesAndShorthands]-  let individualTestParser maybeInternal = foldr (<|>) (pure Nothing) (catMaybes $ mconcat $ individualTestFlags maybeInternal)--  clo <- OA.execParser (commandLineOptionsWithInfo userOptionsParser (individualTestParser internal))+  (clo, individualTestParser, modulesAndShorthands) <- parseCommandLineArgs' userOptionsParser spec   (options, repeatCount) <- liftIO $ addOptionsFromArgs baseOptions clo -  if | optPrintSlackFlags clo == Just True -> do+  if | optPrintQuickCheckFlags clo == Just True -> do          void $ withArgs ["--help"] $+           OA.execParser quickCheckOptionsWithInfo+     | optPrintSlackFlags clo == Just True -> do+         void $ withArgs ["--help"] $            OA.execParser slackOptionsWithInfo      | optPrintWebDriverFlags clo == Just True -> do          void $ withArgs ["--help"] $@@ -158,8 +143,11 @@            OA.execParser $ OA.info (individualTestParser mempty <**> helper) $              fullDesc <> header "Pass one of these flags to run an individual test module."                       <> progDesc "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."-     | otherwise ->-         runWithRepeat repeatCount $+     | otherwise -> do+         -- Awkward, but we need a specific context type to call countItNodes+         let totalTests = countItNodes (spec :: SpecFree (LabelValue "commandLineOptions" (CommandLineOptions a) :> BaseContext) IO ())++         runWithRepeat repeatCount totalTests $            case optIndividualTestModule clo of              Nothing -> runSandwich' (Just $ clo { optUserOptions = () }) options $                introduce' (defaultNodeOptions { nodeOptionsVisibilityThreshold = systemVisibilityThreshold }) "command line options" commandLineOptions (pure clo) (const $ return ()) spec@@ -228,3 +216,12 @@   let failed = countWhere isFailedItBlock fixedTree   exitReason <- readIORef exitReasonRef   return (exitReason, failed)+++-- | Count the it nodes+countItNodes :: Free (SpecCommand context m) r -> Int+countItNodes (Free x@(It'' {})) = 1 + countItNodes (next x)+countItNodes (Free (IntroduceWith'' {..})) = countItNodes next + countItNodes subspecAugmented+countItNodes (Free (Introduce'' {..})) = countItNodes next + countItNodes subspecAugmented+countItNodes (Free x) = countItNodes (next x) + countItNodes (subspec x)+countItNodes (Pure _) = 0

@@ -4,25 +4,31 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}  module Test.Sandwich.ArgParsing where  import Control.Monad.Logger import Data.Function+import qualified Data.List as L import Data.Maybe import qualified Data.Text as T import Data.Time.Clock.POSIX import Data.Typeable import Options.Applicative import qualified Options.Applicative as OA-import System.IO import Test.Sandwich.Formatters.FailureReport import Test.Sandwich.Formatters.Print.Types import Test.Sandwich.Formatters.Silent import Test.Sandwich.Formatters.TerminalUI import Test.Sandwich.Formatters.TerminalUI.Types+import Test.Sandwich.Internal.Running import Test.Sandwich.Options import Test.Sandwich.Types.ArgParsing+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec  #if MIN_VERSION_time(1,9,0) import Data.Time.Format.ISO8601@@ -40,6 +46,13 @@     <> header "Sandwich test runner"   ) +quickCheckOptionsWithInfo :: ParserInfo CommandLineQuickCheckOptions+quickCheckOptionsWithInfo = OA.info (commandLineQuickCheckOptions mempty <**> helper)+  (+    briefDesc+    <> header "Special options used by sandwich-quickcheck.\n\nIf a flag is passed, it will override the value in the QuickCheck option configured in the code."+  )+ slackOptionsWithInfo :: ParserInfo CommandLineSlackOptions slackOptionsWithInfo = OA.info (commandLineSlackOptions mempty <**> helper)   (@@ -59,18 +72,22 @@ mainCommandLineOptions userOptionsParser individualTestParser = CommandLineOptions   <$> formatter   <*> logLevel+  <*> optional (option auto (long "visibility-threshold" <> short 'v' <> showDefault <> help "Set the visibility threshold for formatters" <> metavar "INT"))   <*> optional (strOption (long "filter" <> short 'f' <> help "Filter test tree by string matching text example labels" <> metavar "STRING"))   <*> option auto (long "repeat" <> short 'r' <> showDefault <> help "Repeat the test N times and report how many failures occur" <> value 1 <> metavar "INT")   <*> optional (strOption (long "fixed-root" <> help "Store test artifacts at a fixed path" <> metavar "STRING"))+  <*> optional (flag False True (long "dry-run" <> help "Skip actually launching the tests. This is useful if you want to see the set of the tests that would be run, or start them manually in the terminal UI."))    <*> optional (flag False True (long "list-tests" <> help "List individual test modules"))+  <*> optional (flag False True (long "print-quickcheck-flags" <> help "Print the additional QuickCheck flags"))   <*> optional (flag False True (long "print-slack-flags" <> help "Print the additional Slack flags"))   <*> optional (flag False True (long "print-webdriver-flags" <> help "Print the additional Webdriver flags"))    <*> individualTestParser -  <*> commandLineWebdriverOptions internal+  <*> commandLineQuickCheckOptions internal   <*> commandLineSlackOptions internal+  <*> commandLineWebdriverOptions internal    <*> userOptionsParser @@ -108,6 +125,14 @@   <|> flag' Headless (long "headless" <> help "Open browser in headless mode" <> maybeInternal)   <|> flag Current Xvfb (long "xvfb" <> help "Open browser in Xvfb session" <> maybeInternal) +commandLineQuickCheckOptions :: (forall f a. Mod f a) -> Parser CommandLineQuickCheckOptions+commandLineQuickCheckOptions maybeInternal = CommandLineQuickCheckOptions+  <$> optional (option auto (long "quickcheck-seed" <> help "QuickCheck seed" <> metavar "INT" <> maybeInternal))+  <*> optional (option auto (long "quickcheck-max-discard-ratio" <> help "Maximum number of discarded tests per successful test before giving up" <> metavar "INT" <> maybeInternal))+  <*> optional (option auto (long "quickcheck-max-size" <> help "Size to use for the biggest test cases" <> metavar "INT" <> maybeInternal))+  <*> optional (option auto (long "quickcheck-max-success" <> help "Maximum number of successful tests before succeeding" <> metavar "INT" <> maybeInternal))+  <*> optional (option auto (long "quickcheck-max-shrinks" <> help "Maximum number of shrinks before giving up" <> metavar "INT" <> maybeInternal))+ commandLineSlackOptions :: (forall f a. Mod f a) -> Parser CommandLineSlackOptions commandLineSlackOptions maybeInternal = CommandLineSlackOptions   <$> optional (strOption (long "slack-token" <> help "Slack token to use with the Slack formatter" <> metavar "STRING" <> maybeInternal))@@ -123,8 +148,44 @@    <*> optional (option auto (long "slack-max-message-size" <> help "Maximum message size in bytes (default: 8192)" <> metavar "INT" <> maybeInternal)) --- * Main parsing function+-- * Parse command line args +parseCommandLineArgs :: forall a. (Typeable a) => Parser a -> TopSpecWithOptions' a -> IO (CommandLineOptions a)+parseCommandLineArgs parser spec = do+  (clo, _, _) <- parseCommandLineArgs' parser spec+  return clo++parseCommandLineArgs' :: forall a. (Typeable a) => Parser a -> TopSpecWithOptions' a -> IO (+  CommandLineOptions a+  , Mod FlagFields (Maybe IndividualTestModule) -> Parser (Maybe IndividualTestModule)+  , [(NodeModuleInfo, T.Text)]+  )+parseCommandLineArgs' userOptionsParser spec = do+  let modulesAndShorthands = gatherMainFunctions (spec :: SpecFree (LabelValue "commandLineOptions" (CommandLineOptions a) :> BaseContext) IO ())+                           & L.sortOn nodeModuleInfoModuleName+                           & gatherShorthands+  let individualTestFlags maybeInternal =+        [[ Just $ flag' (Just $ IndividualTestModuleName nodeModuleInfoModuleName)+                        (long (T.unpack shorthand)+                          <> help (nodeModuleInfoModuleName+                          <> (if isJust nodeModuleInfoFn then "*" else ""))+                          <> maybeInternal)+         , case nodeModuleInfoFn of+             Nothing -> Nothing+             Just fn -> Just $ flag' (Just $ IndividualTestMainFn fn)+                                     (long (T.unpack (shorthand <> "-main"))+                                       <> help nodeModuleInfoModuleName+                                       <> internal+                                     )+         ]+        | (NodeModuleInfo {..}, shorthand) <- modulesAndShorthands]+  let individualTestParser maybeInternal = foldr (<|>) (pure Nothing) (catMaybes $ mconcat $ individualTestFlags maybeInternal)++  clo <- OA.execParser (commandLineOptionsWithInfo userOptionsParser (individualTestParser internal))+  return (clo, individualTestParser, modulesAndShorthands)++-- * Merge command line args with base options+ addOptionsFromArgs :: Options -> CommandLineOptions a -> IO (Options, Int) addOptionsFromArgs baseOptions (CommandLineOptions {..}) = do   let printFormatter = SomeFormatter $ defaultPrintFormatter { printFormatterLogLevel = optLogLevel }@@ -134,9 +195,12 @@    maybeMainFormatter <- case (optRepeatCount, optFormatter) of     (x, _) | x /= 1 -> return $ Just printFormatter-    (_, Auto) -> hIsTerminalDevice stdout >>= \case-      True -> return $ Just printFormatter-      False -> return $ Just tuiFormatter+    (_, Auto) ->+      -- Formerly this tried to use the TUI formatter by default after checking isTuiFormatterSupported.+      -- Unfortunately, this function returns true under "cabal test", which also redirects stdout. So+      -- you end up with no output and a hanging process (until you hit 'q'; stdin is still attached).+      -- Seems like the best default is just the print formatter.+      return $ Just printFormatter     (_, TUI) -> return $ Just tuiFormatter     (_, Print) -> return $ Just printFormatter     (_, PrintFailures) -> return $ Just failureReportFormatter@@ -146,12 +210,16 @@   let baseFormatters = optionsFormatters baseOptions                      & filter (not . isMainFormatter) +  let finalFormatters = baseFormatters <> catMaybes [maybeMainFormatter]+                      & fmap (setVisibilityThreshold optVisibilityThreshold)+   let options = baseOptions {     optionsTestArtifactsDirectory = case optFixedRoot of       Nothing -> TestArtifactsGeneratedDirectory "test_runs" (formatTime <$> getCurrentTime)       Just path -> TestArtifactsFixedDirectory path     , optionsFilterTree = TreeFilter <$> optTreeFilter-    , optionsFormatters = baseFormatters <> catMaybes [maybeMainFormatter]+    , optionsFormatters = finalFormatters+    , optionsDryRun = fromMaybe (optionsDryRun baseOptions) optDryRun     }    return (options, optRepeatCount)@@ -163,3 +231,12 @@       Nothing -> case cast x of         Just (_ :: TerminalUIFormatter) -> True         Nothing -> False++    setVisibilityThreshold Nothing x = x+    setVisibilityThreshold (Just v) x@(SomeFormatter f) = case cast f of+      Just pf@(PrintFormatter {}) -> SomeFormatter (pf { printFormatterVisibilityThreshold = v })+      Nothing -> case cast f of+        Just tuif@(TerminalUIFormatter {}) -> SomeFormatter (tuif { terminalUIVisibilityThreshold = v })+        Nothing -> case cast f of+          Just (frf :: FailureReportFormatter) -> SomeFormatter (frf { failureReportVisibilityThreshold = v })+          Nothing -> x

@@ -13,6 +13,7 @@  module Test.Sandwich.Formatters.FailureReport (   defaultFailureReportFormatter+  , FailureReportFormatter    -- * Options   , failureReportUseColor@@ -100,6 +101,8 @@   -- Print the failure reason   case result of     Success -> return ()+    DryRun -> return ()+    Cancelled -> return ()     Failure (ChildrenFailed {}) -> return ()     Failure reason -> do       p "\n"

@@ -87,6 +87,8 @@   -- Print the main header   case result of     Success -> pGreenLn runTreeLabel+    DryRun -> pin runTreeLabel+    Cancelled -> pin runTreeLabel     (Failure (Pending _ _)) -> pYellowLn runTreeLabel     (Failure reason) -> do       pRedLn runTreeLabel@@ -116,6 +118,8 @@     True -> do       case result of         Failure r -> withBumpIndent $ printFailureReason r+        Cancelled -> return ()         Success -> return ()+        DryRun -> return ()       finishPrinting common result     False -> return () -- TODO: print failure info even though node should be hidden?

@@ -25,6 +25,9 @@   -- * Auxiliary types   , InitialFolding(..)   , CustomTUIException(..)++  -- * Util+  , isTuiFormatterSupported   ) where  import Brick as B@@ -37,7 +40,8 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.IO.Unlift-import Control.Monad.Logger+import Control.Monad.Logger hiding (logError)+import Data.Either import Data.Foldable import qualified Data.List as L import Data.Maybe@@ -59,6 +63,7 @@ import Test.Sandwich.Formatters.TerminalUI.Types import Test.Sandwich.Interpreters.RunTree.Util import Test.Sandwich.Interpreters.StartTree+import Test.Sandwich.Logging import Test.Sandwich.RunTree import Test.Sandwich.Shutdown import Test.Sandwich.Types.ArgParsing@@ -72,13 +77,16 @@   runFormatter = runApp   finalizeFormatter _ _ _ = return () -runApp :: (MonadIO m, MonadLogger m, MonadUnliftIO m) => TerminalUIFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()-runApp (TerminalUIFormatter {..}) rts _maybeCommandLineOptions baseContext = liftIO $ do-  startTime <- getCurrentTime+isTuiFormatterSupported :: IO Bool+isTuiFormatterSupported = isRight <$> tryAny (V.mkVty V.defaultConfig) +runApp :: (MonadLoggerIO m, MonadUnliftIO m) => TerminalUIFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()+runApp (TerminalUIFormatter {..}) rts _maybeCommandLineOptions baseContext = do+  startTime <- liftIO getCurrentTime+   liftIO $ setInitialFolding terminalUIInitialFolding rts -  rtsFixed <- atomically $ mapM fixRunTree rts+  rtsFixed <- liftIO $ atomically $ mapM fixRunTree rts    let initialState = updateFilteredTree $         AppState {@@ -103,27 +111,31 @@           , _appCustomExceptionFormatters = terminalUICustomExceptionFormatters         } -  eventChan <- newBChan 10+  eventChan <- liftIO $ newBChan 10 -  currentFixedTree <- newTVarIO rtsFixed-  eventAsync <- async $ forever $ do-    newFixedTree <- atomically $ do-      currentFixed <- readTVar currentFixedTree-      newFixed <- mapM fixRunTree rts-      when (fmap getCommons newFixed == fmap getCommons currentFixed) retry-      writeTVar currentFixedTree newFixed-      return newFixed-    writeBChan eventChan (RunTreeUpdated newFixedTree)-    threadDelay terminalUIRefreshPeriod+  logFn <- askLoggerIO +  currentFixedTree <- liftIO $ newTVarIO rtsFixed+  eventAsync <- liftIO $ async $+    forever $ do+      handleAny (\e -> flip runLoggingT logFn (logError [i|Got exception in event async: #{e}|]) >> threadDelay terminalUIRefreshPeriod) $ do+        newFixedTree <- atomically $ do+          currentFixed <- readTVar currentFixedTree+          newFixed <- mapM fixRunTree rts+          when (fmap getCommons newFixed == fmap getCommons currentFixed) retry+          writeTVar currentFixedTree newFixed+          return newFixed+        writeBChan eventChan (RunTreeUpdated newFixedTree)+        threadDelay terminalUIRefreshPeriod+   let buildVty = do         v <- V.mkVty V.defaultConfig         let output = V.outputIface v         when (V.supportsMode output V.Mouse) $           liftIO $ V.setMode output V.Mouse True         return v-  initialVty <- buildVty-  flip onException (cancel eventAsync) $+  initialVty <- liftIO buildVty+  liftIO $ flip onException (cancel eventAsync) $     void $ customMain initialVty buildVty (Just eventChan) app initialState  app :: App AppState AppEvent ClickableName

@@ -127,6 +127,8 @@ chooseAttr (Done _ _ (Success {})) = successAttr chooseAttr (Done _ _ (Failure (Pending {}))) = pendingAttr chooseAttr (Done _ _ (Failure {})) = failureAttr+chooseAttr (Done _ _ DryRun) = notStartedAttr+chooseAttr (Done _ _ Cancelled) = failureAttr  -- * Logging and callstacks 

@@ -68,6 +68,8 @@         lensForStatus (Done {statusResult=Success}) = success         lensForStatus (Done {statusResult=(Failure (Pending {}))}) = pending         lensForStatus (Done {statusResult=(Failure _)}) = failure+        lensForStatus (Done {statusResult=DryRun}) = notStarted+        lensForStatus (Done {statusResult=Cancelled}) = failure  maxBy :: (Foldable t, Ord a) => (b -> a) -> t b -> b maxBy = maximumBy . comparing

@@ -34,6 +34,8 @@   toBrickWidget (Running {statusStartTime}) = return $ strWrap [i|Started at #{statusStartTime}|]   toBrickWidget (Done startTime endTime Success) = return $ strWrap [i|Succeeded in #{formatNominalDiffTime (diffUTCTime endTime startTime)}|]   toBrickWidget (Done {statusResult=(Failure failureReason)}) = toBrickWidget failureReason+  toBrickWidget (Done {statusResult=DryRun}) = return $ strWrap "Not started due to dry run"+  toBrickWidget (Done {statusResult=Cancelled}) = return $ strWrap "Cancelled"  instance ToBrickWidget FailureReason where   toBrickWidget (ExpectedButGot _ (SEB x1) (SEB x2)) = do

@@ -71,7 +71,7 @@   , terminalUIShowVisibilityThresholds = False   , terminalUILogLevel = Just LevelWarn   , terminalUIRefreshPeriod = 100000-  , terminalUIDefaultEditor = Just "emacsclient +LINE:COLUMN --no-wait"+  , terminalUIDefaultEditor = Just "emacsclient +$((LINE+1)):COLUMN --no-wait"   , terminalUIOpenInEditor = autoOpenInEditor   , terminalUICustomExceptionFormatters = []   }

@@ -48,8 +48,8 @@    runTree <- atomically $ specToRunTreeVariable baseContext spec -  unless optionsDryRun $ do-    void $ async $ void $ runNodesSequentially runTree baseContext+  if | optionsDryRun -> markAllChildrenWithResult runTree baseContext DryRun+     | otherwise -> void $ async $ void $ runNodesSequentially runTree baseContext    return runTree @@ -60,13 +60,13 @@   return rts  -- | For 0 repeats, repeat until a failure-runWithRepeat :: Int -> IO (ExitReason, Int) -> IO ()-runWithRepeat 0 action = do+runWithRepeat :: Int -> Int -> IO (ExitReason, Int) -> IO ()+runWithRepeat 0 totalTests action = do   (_, numFailures) <- action-  if | numFailures == 0 -> runWithRepeat 0 action+  if | numFailures == 0 -> runWithRepeat 0 totalTests action      | otherwise -> exitFailure -- | For 1 repeat, run once and return-runWithRepeat n action = do+runWithRepeat n totalTests action = do   (successes, total) <- (flip execStateT (0 :: Int, 0 :: Int)) $ flip fix (n - 1) $ \loop n -> do     (exitReason, numFailures) <- liftIO action @@ -76,7 +76,7 @@        | n > 0 -> loop (n - 1)        | otherwise -> return () -  putStrLn [i|#{successes} runs succeeded out of #{total} repeats|]+  putStrLn [i|#{successes} runs succeeded out of #{total} repeat#{if n > 1 then ("s" :: String) else ""} (#{totalTests} tests)|]    when (successes /= total) $ exitFailure @@ -145,9 +145,10 @@   , "fixed-root"   , "list-tests" +  , "print-quickcheck-flags"   , "print-slack-flags"-   , "print-webdriver-flags"+   , "headless"   ] 

@@ -9,6 +9,7 @@ module Test.Sandwich.Interpreters.StartTree (   startTree   , runNodesSequentially+  , markAllChildrenWithResult   ) where  @@ -66,6 +67,11 @@       Success -> do         void $ runNodesSequentially runNodeChildren ctx         return Success+      Cancelled -> do+        return Cancelled+      DryRun -> do+        void $ runNodesSequentially runNodeChildren ctx+        return DryRun startTree node@(RunNodeAfter {..}) ctx' = do   let RunNodeCommonWithStatus {..} = runNodeCommon   let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon

@@ -50,7 +50,7 @@  -- | Spawn a process with its stdout and stderr connected to the logging system. Every line output by the process -- will be fed to a 'debug' call.-createProcessWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => CreateProcess -> m ProcessHandle+createProcessWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => CreateProcess -> m ProcessHandle createProcessWithLogging cp = do   (hRead, hWrite) <- liftIO createPipe @@ -70,9 +70,11 @@ callCommandWithLogging cmd = do   (hRead, hWrite) <- liftIO createPipe -  (_, _, _, p) <- liftIO $ createProcess (shell cmd) { delegate_ctlc = True-                                                     , std_out = UseHandle hWrite-                                                     , std_err = UseHandle hWrite }+  (_, _, _, p) <- liftIO $ createProcess (shell cmd) {+    delegate_ctlc = True+    , std_out = UseHandle hWrite+    , std_err = UseHandle hWrite+    }    _ <- async $ forever $ do     line <- liftIO $ hGetLine hRead

@@ -18,6 +18,7 @@    -- * Command line options   , CommandLineOptions(..)+  , CommandLineQuickCheckOptions(..)   , CommandLineSlackOptions(..)   , CommandLineWebdriverOptions(..)   , BrowserToUse(..)

@@ -25,6 +25,9 @@   -- * Timing   , optionsTestTimerType +  -- * Dry run+  , optionsDryRun+   -- * Misc   , optionsProjectRoot   ) where

@@ -11,12 +11,12 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Control (MonadBaseControl)-import Test.Sandwich.Types.Spec import Test.Sandwich.Contexts+import Test.Sandwich.Types.Spec   --- | Wrapped around 'parallel'. Introduces a semaphore to limit the parallelism to N threads.+-- | Wrapper around 'parallel'. Introduces a semaphore to limit the parallelism to N threads. parallelN :: (   MonadBaseControl IO m, MonadIO m, MonadMask m   ) => Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()

@@ -1,15 +1,19 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE RecordWildCards #-}--- |  module Test.Sandwich.Shutdown where  import Control.Concurrent.Async import Control.Concurrent.STM+import Data.Time import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec   cancelNode :: RunNode context -> IO () cancelNode node = readTVarIO (runTreeStatus $ runNodeCommon node) >>= \case   Running {..} -> cancel statusAsync-  _ -> return ()+  NotStarted -> do+    now <- getCurrentTime+    atomically $ writeTVar (runTreeStatus $ runNodeCommon node) (Done now now Cancelled)+  Done {} -> return ()

@@ -112,7 +112,7 @@       False -> [e|Nothing|]   alterNodeOptionsFn <- [e|(\x -> x { nodeOptionsModuleInfo = Just ($(conE 'NodeModuleInfo) currentModule $(return maybeMainFunction)) })|]   [e|$(varE 'alterTopLevelNodeOptions) $(return alterNodeOptionsFn)-     $ $(varE getSpecCombiner) $(stringE $ mangleFolderName folder) (L.foldl1 (>>) $(listE $ fmap return specs))|]+     $ $(varE getSpecCombiner) $(stringE $ mangleFolderName folder) (L.foldl (>>) (pure ()) $(listE $ fmap return specs))|]  -- * Util 

@@ -46,18 +46,22 @@ data CommandLineOptions a = CommandLineOptions {   optFormatter :: FormatterType   , optLogLevel :: Maybe LogLevel+  , optVisibilityThreshold :: Maybe Int   , optTreeFilter :: Maybe String   , optRepeatCount :: Int   , optFixedRoot :: Maybe String+  , optDryRun :: Maybe Bool    , optListAvailableTests :: Maybe Bool+  , optPrintQuickCheckFlags :: Maybe Bool   , optPrintSlackFlags :: Maybe Bool   , optPrintWebDriverFlags :: Maybe Bool    , optIndividualTestModule :: Maybe IndividualTestModule -  , optWebdriverOptions :: CommandLineWebdriverOptions+  , optQuickCheckOptions :: CommandLineQuickCheckOptions   , optSlackOptions :: CommandLineSlackOptions+  , optWebdriverOptions :: CommandLineWebdriverOptions    , optUserOptions :: a   } deriving Show@@ -68,6 +72,16 @@ instance Show IndividualTestModule where   show (IndividualTestModuleName moduleName) = moduleName   show (IndividualTestMainFn _) = "<main function>"++-- * sandwich-quickcheck options++data CommandLineQuickCheckOptions = CommandLineQuickCheckOptions {+  optQuickCheckSeed :: Maybe Integer+  , optQuickCheckMaxDiscardRatio :: Maybe Int+  , optQuickCheckMaxSize :: Maybe Int+  , optQuickCheckMaxSuccess :: Maybe Int+  , optQuickCheckMaxShrinks :: Maybe Int+  } deriving Show  -- * sandwich-slack options 

@@ -107,12 +107,13 @@ -- * Other  type Var = TVar-data LogEntry = LogEntry { logEntryTime :: UTCTime-                         , logEntryLoc :: Loc-                         , logEntrySource :: LogSource-                         , logEntryLevel :: LogLevel-                         , logEntryStr :: LogStr-                         } deriving (Show, Eq)+data LogEntry = LogEntry {+  logEntryTime :: UTCTime+  , logEntryLoc :: Loc+  , logEntrySource :: LogSource+  , logEntryLevel :: LogLevel+  , logEntryStr :: LogStr+  } deriving (Show, Eq)  -- | Context passed around through the evaluation of a RunTree data RunTreeContext = RunTreeContext {@@ -179,7 +180,7 @@ class Formatter f where   formatterName :: f -> String   -- ^ Name of the formatter-  runFormatter :: (MonadIO m, MonadLogger m, MonadUnliftIO m, MonadCatch m) => f -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()+  runFormatter :: (MonadLoggerIO m, MonadUnliftIO m, MonadCatch m) => f -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()   -- ^ The main function, executed while the test tree is running   finalizeFormatter :: (MonadIO m, MonadLogger m, MonadCatch m) => f -> [RunNode BaseContext] -> BaseContext -> m ()   -- ^ Called after the test tree is completed, can be used to print final results

@@ -74,6 +74,8 @@  data Result = Success             | Failure FailureReason+            | DryRun+            | Cancelled   deriving (Show, Eq)  data ShowEqBox = forall s. (Show s, Eq s) => SEB s@@ -257,9 +259,6 @@   liftShowsPrec sp _ d (Describe'' {..}) = showsUnaryWith sp [i|Describe[#{label}]<#{show subspec}>|] d next   liftShowsPrec sp _ d (Parallel'' {..}) = showsUnaryWith sp [i|Parallel<#{show subspec}>|] d next   liftShowsPrec sp _ d (It'' {..}) = showsUnaryWith sp [i|It[#{label}]|] d next---- First write beforeEach/afterEach to demonstrate push down approach--- Then think about how/whether we can to introduceEach / aroundEach  -- * ----------------------------------------------------------