sandwich 0.1.0.9 → 0.1.0.10

raw patch · 17 files changed

+288/−24 lines, 17 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−0
• sandwich.cabal +3/−2
• src/Test/Sandwich.hs +4/−1
• src/Test/Sandwich/ArgParsing.hs +36/−0
• src/Test/Sandwich/Expectations.hs +22/−2
• src/Test/Sandwich/Formatters/MarkdownSummary.hs +85/−0
• src/Test/Sandwich/Formatters/Print.hs +6/−1
• src/Test/Sandwich/Formatters/Print/FailureReason.hs +2/−0
• src/Test/Sandwich/Formatters/Print/Util.hs +0/−1
• src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs +1/−0
• src/Test/Sandwich/Internal/Running.hs +1/−1
• src/Test/Sandwich/Interpreters/RunTree.hs +9/−9
• src/Test/Sandwich/Logging.hs +43/−1
• src/Test/Sandwich/Misc.hs +1/−0
• src/Test/Sandwich/ParallelN.hs +49/−6
• src/Test/Sandwich/Types/ArgParsing.hs +13/−0
• src/Test/Sandwich/Types/Spec.hs +7/−0

@@ -2,6 +2,12 @@  ## Unreleased changes ++## 0.1.0.10++* Add Markdown Summary formatter (useful with GitHub Actions)+* Release `sandwich-hedgehog` compatibility.+ ## 0.1.0.9  * Expose `optionsDryRun` and the `--dry-run` option.

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: d6ea486ba7ffe23a777baf26a52d55238719f87911caac302ebc2b64b70a4f32+-- hash: 933d39e891051a78e2b2f7d00c6879128eb9fce0b3c31eb6f21cb663e0643f14  name:           sandwich-version:        0.1.0.9+version:        0.1.0.10 synopsis:       Yet another test framework for Haskell description:    Please see the <https://codedownio.github.io/sandwich documentation>. category:       Testing@@ -46,6 +46,7 @@       Test.Sandwich.ArgParsing       Test.Sandwich.Formatters.Common.Count       Test.Sandwich.Formatters.Common.Util+      Test.Sandwich.Formatters.MarkdownSummary       Test.Sandwich.Formatters.Print.CallStacks       Test.Sandwich.Formatters.Print.Color       Test.Sandwich.Formatters.Print.Common

@@ -38,7 +38,6 @@   , it   , describe   , parallel-  , parallelN    -- * Context manager nodes   --@@ -67,6 +66,7 @@   , module Test.Sandwich.Misc   , module Test.Sandwich.Nodes   , module Test.Sandwich.Options+  , module Test.Sandwich.ParallelN   , module Test.Sandwich.TH   ) where @@ -132,6 +132,9 @@   if | optPrintQuickCheckFlags clo == Just True -> do          void $ withArgs ["--help"] $            OA.execParser quickCheckOptionsWithInfo+     | optPrintHedgehogFlags clo == Just True -> do+         void $ withArgs ["--help"] $+           OA.execParser hedgehogOptionsWithInfo      | optPrintSlackFlags clo == Just True -> do          void $ withArgs ["--help"] $            OA.execParser slackOptionsWithInfo

@@ -20,6 +20,7 @@ import Options.Applicative import qualified Options.Applicative as OA import Test.Sandwich.Formatters.FailureReport+import Test.Sandwich.Formatters.MarkdownSummary import Test.Sandwich.Formatters.Print.Types import Test.Sandwich.Formatters.Silent import Test.Sandwich.Formatters.TerminalUI@@ -53,6 +54,13 @@     <> 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."   ) +hedgehogOptionsWithInfo :: ParserInfo CommandLineHedgehogOptions+hedgehogOptionsWithInfo = OA.info (commandLineHedgehogOptions mempty <**> helper)+  (+    briefDesc+    <> header "Special options used by sandwich-hedgehog.\n\nIf a flag is passed, it will override the value in the Hedgehog option configured in the code."+  )+ slackOptionsWithInfo :: ParserInfo CommandLineSlackOptions slackOptionsWithInfo = OA.info (commandLineSlackOptions mempty <**> helper)   (@@ -77,15 +85,18 @@   <*> 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 (strOption (long "markdown-summary" <> help "File path to write a Markdown summary of the results." <> metavar "STRING"))    <*> 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-hedgehog-flags" <> help "Print the additional Hedgehog 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    <*> commandLineQuickCheckOptions internal+  <*> commandLineHedgehogOptions internal   <*> commandLineSlackOptions internal   <*> commandLineWebdriverOptions internal @@ -133,6 +144,14 @@   <*> 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)) +commandLineHedgehogOptions :: (forall f a. Mod f a) -> Parser CommandLineHedgehogOptions+commandLineHedgehogOptions maybeInternal = CommandLineHedgehogOptions+  <$> optional (option auto (long "hedgehog-seed" <> help "Seed as a tuple (a, b)" <> metavar "STRING" <> maybeInternal))+  <*> optional (option auto (long "hedgehog-size" <> help "Size of the randomly-generated data" <> metavar "INT" <> maybeInternal))+  <*> optional (option auto (long "hedgehog-discard-limit" <> help "The number of times a property is allowed to discard before the test runner gives up" <> metavar "INT" <> maybeInternal))+  <*> optional (option auto (long "hedgehog-shrink-limit" <> help "The number of times a property is allowed to shrink before the test runner gives up and prints the counterexample" <> metavar "INT" <> maybeInternal))+  <*> optional (option auto (long "hedgehog-shrink-retries" <> help "The number of times to re-run a test during shrinking" <> 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))@@ -208,6 +227,7 @@    -- Strip out any "main" formatters since the options control that   let baseFormatters = optionsFormatters baseOptions+                     & tryAddMarkdownSummaryFormatter optMarkdownSummaryPath                      & filter (not . isMainFormatter)    let finalFormatters = baseFormatters <> catMaybes [maybeMainFormatter]@@ -240,3 +260,19 @@         Nothing -> case cast f of           Just (frf :: FailureReportFormatter) -> SomeFormatter (frf { failureReportVisibilityThreshold = v })           Nothing -> x++    isMarkdownSummaryFormatter :: SomeFormatter -> Bool+    isMarkdownSummaryFormatter (SomeFormatter x) = case cast x of+      Just (_ :: MarkdownSummaryFormatter) -> True+      Nothing -> False++    setMarkdownSummaryFormatterPath :: FilePath -> SomeFormatter -> SomeFormatter+    setMarkdownSummaryFormatterPath path (SomeFormatter x) = case cast x of+      Just (y :: MarkdownSummaryFormatter) -> SomeFormatter (y { markdownSummaryPath = path })+      Nothing -> SomeFormatter x++    tryAddMarkdownSummaryFormatter :: Maybe FilePath -> [SomeFormatter] -> [SomeFormatter]+    tryAddMarkdownSummaryFormatter Nothing xs = xs+    tryAddMarkdownSummaryFormatter (Just path) xs+      | L.any isMarkdownSummaryFormatter xs = fmap (setMarkdownSummaryFormatterPath path) xs+      | otherwise = (SomeFormatter (defaultMarkdownSummaryFormatter path)) : xs

@@ -23,11 +23,11 @@ expectationFailure = throwIO . Reason (Just callStack)  -- | Throws a 'Pending' exception, which will cause the test to be marked as pending.-pending :: (HasCallStack, MonadThrow m) => m ()+pending :: (HasCallStack, MonadThrow m) => m a pending = throwIO $ Pending (Just callStack) Nothing  -- | Throws a 'Pending' exception with a message to add additional details.-pendingWith :: (HasCallStack, MonadThrow m) => String -> m ()+pendingWith :: (HasCallStack, MonadThrow m) => String -> m a pendingWith msg = throwIO $ Pending (Just callStack) (Just msg)  -- | Shorthand for a pending test example. You can quickly mark an 'it' node as pending by putting an "x" in front of it.@@ -102,6 +102,26 @@ shouldNotContainPredicate haystack pred = case L.find pred haystack of   Nothing -> return ()   Just _ -> expectationFailure [i|Expected #{show haystack} not to contain an item matching the predicate|]++-- | Asserts that the given 'Maybe' is 'Nothing'.+shouldBeNothing :: (HasCallStack, MonadThrow m, Show a) => Maybe a -> m ()+shouldBeNothing Nothing = return ()+shouldBeNothing x = expectationFailure [i|Expected Nothing but got #{x}|]++-- | Asserts that the given 'Maybe' is 'Just'.+shouldBeJust :: (HasCallStack, MonadThrow m, Show a) => Maybe a -> m ()+shouldBeJust (Just _) = return ()+shouldBeJust Nothing = expectationFailure [i|Expected Just but got Nothing.|]++-- | Asserts that the given 'Either' is 'Left'.+shouldBeLeft :: (HasCallStack, MonadThrow m, Show a, Show b) => Either a b -> m ()+shouldBeLeft (Left _) = return ()+shouldBeLeft x = expectationFailure [i|Expected Left but got #{x}|]++-- | Asserts that the given 'Either' is 'Right'.+shouldBeRight :: (HasCallStack, MonadThrow m, Show a, Show b) => Either a b -> m ()+shouldBeRight (Right _) = return ()+shouldBeRight x = expectationFailure [i|Expected Right but got #{x}.|]  -- | Asserts that the given text contains a substring. textShouldContain :: (HasCallStack, MonadThrow m) => T.Text -> T.Text -> m ()

@@ -0,0 +1,85 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}++-- | The markdown summary report formatter appends Markdown summary information to a given file.+--+-- This is a "secondary formatter," i.e. one that can run in the background while a "primary formatter" (such as the TerminalUI or Print formatters) monopolize the foreground.+--+-- Documentation can be found <https://codedownio.github.io/sandwich/docs/formatters/markdown_summary here>.++module Test.Sandwich.Formatters.MarkdownSummary (+  defaultMarkdownSummaryFormatter+  , MarkdownSummaryFormatter++  -- * Options+  , markdownSummaryPath+  , markdownSummarySuccessIcon+  , markdownSummaryFailureIcon+  ) where++import Control.Concurrent.STM+import Control.Monad.Catch+import Control.Monad.IO.Class+import Control.Monad.Logger+import Data.String.Interpolate+import Data.Text as T+import Data.Time+import System.IO+import Test.Sandwich.Formatters.Common.Count+import Test.Sandwich.Formatters.Common.Util+import Test.Sandwich.Interpreters.RunTree.Util (waitForTree)+import Test.Sandwich.RunTree+import Test.Sandwich.Types.ArgParsing+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Util+++data MarkdownSummaryFormatter = MarkdownSummaryFormatter {+  markdownSummaryPath :: FilePath+  , markdownSummarySuccessIcon :: Maybe Text+  , markdownSummaryFailureIcon :: Maybe Text+  } deriving (Show)++defaultMarkdownSummaryFormatter :: FilePath -> MarkdownSummaryFormatter+defaultMarkdownSummaryFormatter path = MarkdownSummaryFormatter {+  markdownSummaryPath = path+  , markdownSummarySuccessIcon = Just ":heavy_check_mark: "+  , markdownSummaryFailureIcon = Just ":x: "+  }++instance Formatter MarkdownSummaryFormatter where+  formatterName _ = "markdown-summary-formatter"+  runFormatter = run+  finalizeFormatter _ _ _ = return ()++run :: (MonadIO m, MonadLogger m, MonadCatch m) => MarkdownSummaryFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()+run (MarkdownSummaryFormatter {..}) rts _ _bc = do+  let total = countWhere isItBlock rts++  startTime <- liftIO getCurrentTime++  mapM_ (liftIO . waitForTree) rts++  endTime <- liftIO getCurrentTime+  let timeDiff = formatNominalDiffTime $ diffUTCTime endTime startTime++  fixedTree <- liftIO $ atomically $ mapM fixRunTree rts+  let failed = countWhere isFailedItBlock fixedTree+  let pending = countWhere isPendingItBlock fixedTree++  liftIO $ withFile markdownSummaryPath AppendMode $ \h -> do+    if | failed == 0 -> do+           whenJust markdownSummarySuccessIcon (liftIO . (hPutStr h) . T.unpack)+           hPutStr h [i|All tests passed in #{timeDiff}.|]+       | otherwise -> do+           whenJust markdownSummaryFailureIcon (liftIO . (hPutStr h) . T.unpack)+           hPutStr h [i|#{failed} failed of #{total} in #{timeDiff}.|]+    case pending of+      0 -> hPutStrLn h ""+      _ -> hPutStrLn h [i| (#{pending} pending)|]

@@ -122,4 +122,9 @@         Success -> return ()         DryRun -> return ()       finishPrinting common result-    False -> return () -- TODO: print failure info even though node should be hidden?+    False -> case result of+        Failure r -> do+          pRedLn ("^ " <> runTreeLabel)+          printFailureReason r+          finishPrinting common result+        _ -> return ()

@@ -25,6 +25,8 @@ printFailureReason :: FailureReason -> ReaderT (PrintFormatter, Int, Handle) IO () printFailureReason (Reason _ s) = do   printShowBoxPrettyWithTitleString "Reason: " s+printFailureReason (RawImage _ fallback _image) = do+  forM_ (L.lines fallback) pin printFailureReason (ChildrenFailed _ n) = do   picn midWhite ([i|#{n} #{if n == 1 then ("child" :: String) else "children"} failed|] :: String) printFailureReason (ExpectedButGot _ seb1 seb2) = do

@@ -1,7 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-}--- |  module Test.Sandwich.Formatters.Print.Util where 

@@ -64,6 +64,7 @@     Just msg -> hBox [withAttr pendingAttr $ str "Pending"                      , str (": " <> msg)]   toBrickWidget (Reason _ msg) = return $ boxWithTitle "Failure reason:" (strWrap msg)+  toBrickWidget (RawImage _ _ image) = return $ boxWithTitle "Failure reason:" (raw image)   toBrickWidget (ChildrenFailed _ n) = return $ boxWithTitle [i|Reason: #{n} #{if n == 1 then ("child" :: String) else "children"} failed|] (strWrap "")   toBrickWidget (GotException _ maybeMessage e@(SomeExceptionWithEq baseException)) = case fromException baseException of     Just (fr :: FailureReason) -> boxWithTitle heading <$> (toBrickWidget fr)

@@ -138,7 +138,7 @@ -- | TODO: get these automatically from mainCommandLineOptions takenMainOptions :: [T.Text] takenMainOptions = [-  "print", "tui", "silent", "auto"+  "print", "tui", "silent", "auto", "markdown-summary"   , "debug", "info", "warn", "error"   , "filter"   , "repeat"

@@ -57,31 +57,31 @@  -- | Convert a spec to a run tree specToRunTree' :: (Monad m) => Free (SpecCommand context IO) r -> ConvertM m [RunNodeFixed context]-specToRunTree'  (Free (Before'' loc no l f subspec next)) = do+specToRunTree' (Free (Before'' loc no l f subspec next)) = do   common <- getCommon l loc no   continueWith next =<< RunNodeBefore common <$> recurse l no common subspec <*> pure f-specToRunTree'  (Free (After'' loc no l f subspec next)) = do+specToRunTree' (Free (After'' loc no l f subspec next)) = do   common <- getCommon l loc no   continueWith next =<< RunNodeAfter common <$> recurse l no common subspec <*> pure f-specToRunTree'  (Free (Introduce'' loc no l _cl alloc cleanup subspec next)) = do+specToRunTree' (Free (Introduce'' loc no l _cl alloc cleanup subspec next)) = do   common <- getCommon l loc no   continueWith next =<< RunNodeIntroduce common <$> recurse l no common subspec <*> pure alloc <*> pure cleanup-specToRunTree'  (Free (IntroduceWith'' loc no l _cl action subspec next)) = do+specToRunTree' (Free (IntroduceWith'' loc no l _cl action subspec next)) = do   common <- getCommon l loc no   continueWith next =<< RunNodeIntroduceWith common <$> recurse l no common subspec <*> pure action-specToRunTree'  (Free (Around'' loc no l actionWith subspec next)) = do+specToRunTree' (Free (Around'' loc no l actionWith subspec next)) = do   common <- getCommon l loc no   continueWith next =<< RunNodeAround common <$> recurse l no common subspec <*> pure actionWith-specToRunTree'  (Free (Describe'' loc no l subspec next)) = do+specToRunTree' (Free (Describe'' loc no l subspec next)) = do   common <- getCommon l loc no   continueWith next =<< RunNodeDescribe common <$> recurse l no common subspec-specToRunTree'  (Free (Parallel'' loc no subspec next)) = do+specToRunTree' (Free (Parallel'' loc no subspec next)) = do   common <- getCommon "Parallel" loc no   continueWith next =<< RunNodeParallel common <$> recurse "Parallel" no common subspec-specToRunTree'  (Free (It'' loc no l example next)) = do+specToRunTree' (Free (It'' loc no l example next)) = do   common <- getCommon l loc no   continueWith next =<< RunNodeIt common <$> pure example-specToRunTree'  (Pure _) = return []+specToRunTree' (Pure _) = return []   -- * Util

@@ -1,12 +1,14 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE CPP #-}  -- | Logging functions.  module Test.Sandwich.Logging where  import Control.Concurrent.Async.Lifted+import qualified Control.Exception as C import Control.Exception.Safe import Control.Monad import Control.Monad.IO.Class@@ -14,12 +16,17 @@ import Control.Monad.Trans.Control (MonadBaseControl) import Data.String.Interpolate import Data.Text+import Foreign.C.Error+import GHC.IO.Exception import GHC.Stack-import System.Exit import System.IO import System.Process +#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail+#endif + -- * Basic logging functions  @@ -64,6 +71,41 @@    (_, _, _, p) <- liftIO $ createProcess (cp { std_out = UseHandle hWrite, std_err = UseHandle hWrite })   return p++-- | 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.+createProcessWithLoggingAndStdin :: (MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => CreateProcess -> String -> m ProcessHandle+createProcessWithLoggingAndStdin cp input = do+  (hRead, hWrite) <- liftIO createPipe++  let name = case cmdspec cp of+        ShellCommand {} -> "shell"+        RawCommand path _ -> path++  _ <- async $ forever $ do+    line <- liftIO $ hGetLine hRead+    debug [i|#{name}: #{line}|]++  (Just inh, _, _, p) <- liftIO $ createProcess (+    cp { std_out = UseHandle hWrite+       , std_err = UseHandle hWrite+       , std_in = CreatePipe }+    )++  unless (Prelude.null input) $+    liftIO $ ignoreSigPipe $ hPutStr inh input+  -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE+  liftIO $ ignoreSigPipe $ hClose inh++  return p++  where+    -- Copied from System.Process+    ignoreSigPipe :: IO () -> IO ()+    ignoreSigPipe = C.handle $ \case+      IOError { ioe_type  = ResourceVanished, ioe_errno = Just ioe } | Errno ioe == ePIPE -> return ()+      e -> throwIO e+  -- | Higher level version of 'createProcessWithLogging', accepting a shell command. callCommandWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => String -> m ()

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

@@ -1,17 +1,34 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ConstraintKinds #-}  -- | Wrapper around 'parallel' for limiting the threads using a semaphore. -module Test.Sandwich.ParallelN (parallelN) where+module Test.Sandwich.ParallelN (+  parallelN+  , parallelN' +  , parallelNFromArgs+  , parallelNFromArgs'++  , parallelSemaphore+  , HasParallelSemaphore++  , defaultParallelNodeOptions+  ) where+ import Control.Concurrent.QSem import Control.Exception.Safe import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Control (MonadBaseControl) import Test.Sandwich.Contexts+import Test.Sandwich.Types.ArgParsing+import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec  @@ -20,15 +37,41 @@ parallelN :: (   MonadBaseControl IO m, MonadIO m, MonadMask m   ) => Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()-parallelN n children = introduceParallelSemaphore n $ parallel $ aroundEach "Take parallel semaphore" claimRunSlot children+parallelN = parallelN' defaultParallelNodeOptions++parallelN' :: (+  MonadBaseControl IO m, MonadIO m, MonadMask m+  ) => NodeOptions -> Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()+parallelN' nodeOptions n children = introduce "Introduce parallel semaphore" parallelSemaphore (liftIO $ newQSem n) (const $ return ()) $+  parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children   where claimRunSlot f = do           s <- getContext parallelSemaphore           bracket_ (liftIO $ waitQSem s) (liftIO $ signalQSem s) (void f) +-- | Same as 'parallelN', but extracts the semaphore size from the command line options.+parallelNFromArgs :: forall context a m. (+  MonadBaseControl IO m, MonadIO m, MonadMask m, HasCommandLineOptions context a+  ) => (CommandLineOptions a -> Int) -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()+parallelNFromArgs = parallelNFromArgs' @context @a defaultParallelNodeOptions++parallelNFromArgs' :: forall context a m. (+  MonadBaseControl IO m, MonadIO m, MonadMask m, HasCommandLineOptions context a+  ) => NodeOptions -> (CommandLineOptions a -> Int) -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()+parallelNFromArgs' nodeOptions getParallelism children = introduce "Introduce parallel semaphore" parallelSemaphore getQSem (const $ return ()) $+  parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children+  where+    getQSem = do+      n <- getParallelism <$> getContext commandLineOptions+      liftIO $ newQSem n++    claimRunSlot f = do+      s <- getContext parallelSemaphore+      bracket_ (liftIO $ waitQSem s) (liftIO $ signalQSem s) (void f)+ parallelSemaphore :: Label "parallelSemaphore" QSem parallelSemaphore = Label -introduceParallelSemaphore :: (-  MonadIO m, MonadBaseControl IO m-  ) => Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()-introduceParallelSemaphore n = introduce "Introduce parallel semaphore" parallelSemaphore (liftIO $ newQSem n) (const $ return ())+type HasParallelSemaphore context = HasLabel context "parallelSemaphore" QSem++defaultParallelNodeOptions :: NodeOptions+defaultParallelNodeOptions = defaultNodeOptions { nodeOptionsVisibilityThreshold = 70 }

@@ -51,15 +51,18 @@   , optRepeatCount :: Int   , optFixedRoot :: Maybe String   , optDryRun :: Maybe Bool+  , optMarkdownSummaryPath :: Maybe FilePath    , optListAvailableTests :: Maybe Bool   , optPrintQuickCheckFlags :: Maybe Bool+  , optPrintHedgehogFlags :: Maybe Bool   , optPrintSlackFlags :: Maybe Bool   , optPrintWebDriverFlags :: Maybe Bool    , optIndividualTestModule :: Maybe IndividualTestModule    , optQuickCheckOptions :: CommandLineQuickCheckOptions+  , optHedgehogOptions :: CommandLineHedgehogOptions   , optSlackOptions :: CommandLineSlackOptions   , optWebdriverOptions :: CommandLineWebdriverOptions @@ -81,6 +84,16 @@   , optQuickCheckMaxSize :: Maybe Int   , optQuickCheckMaxSuccess :: Maybe Int   , optQuickCheckMaxShrinks :: Maybe Int+  } deriving Show++-- * sandwich-hedgehog options++data CommandLineHedgehogOptions = CommandLineHedgehogOptions {+  optHedgehogSeed :: Maybe String+  , optHedgehogSize :: Maybe Int+  , optHedgehogDiscardLimit :: Maybe Integer+  , optHedgehogShrinkLimit :: Maybe Integer+  , optHedgehogShrinkRetries :: Maybe Integer   } deriving Show  -- * sandwich-slack options

@@ -35,6 +35,7 @@ import Data.String.Interpolate import GHC.Stack import GHC.TypeLits+import Graphics.Vty.Image (Image) import Safe  #if !MIN_VERSION_base(4,13,0)@@ -101,6 +102,9 @@                                        , failureAsyncException :: SomeAsyncExceptionWithEq }                    | ChildrenFailed { failureCallStack :: Maybe CallStack                                     , failureNumChildren :: Int }+                   | RawImage { failureCallStack :: Maybe CallStack+                              , failureFallback :: String+                              , failureRawImage :: Image }   deriving (Show, Typeable, Eq)  instance Exception FailureReason@@ -249,6 +253,9 @@ type SpecFree context m a = Free (SpecCommand context m) a  makeFree_ ''SpecCommand++instance Show t => Show (SpecCommand context m t) where+  showsPrec = liftShowsPrec showsPrec showList  instance Show1 (SpecCommand context m) where   liftShowsPrec sp _ d (Before'' {..}) = showsUnaryWith sp [i|Before[#{label}]<#{show subspec}>|] d next