sandwich 0.1.0.5 → 0.1.0.6

raw patch · 9 files changed

+60/−26 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +4/−0
• sandwich.cabal +4/−3
• src/Test/Sandwich.hs +2/−0
• src/Test/Sandwich/ArgParsing.hs +1/−1
• src/Test/Sandwich/Contexts.hs +5/−0
• src/Test/Sandwich/Formatters/Print/FailureReason.hs +7/−4
• src/Test/Sandwich/Interpreters/StartTree.hs +2/−2
• src/Test/Sandwich/Logging.hs +1/−16
• src/Test/Sandwich/ParallelN.hs +34/−0

@@ -1,3 +1,7 @@ # Changelog for sandwich  ## Unreleased changes++## 0.1.0.5++* Add `parallelN` for limiting the number of threads in a `parallel`.

@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0.+-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack ----- hash: 244c3e7999c4afac51c061a4e2ca5575aeb323ac3ee3c20b70f36df7a861a50d+-- hash: aa45aa821e6aa80865e26cf2911cf666e76b4e5ce6ba1a0ef5b08a4ff626640d  name:           sandwich-version:        0.1.0.5+version:        0.1.0.6 synopsis:       Yet another test framework for Haskell description:    Please see the <https://codedownio.github.io/sandwich documentation>. category:       Testing@@ -75,6 +75,7 @@       Test.Sandwich.Interpreters.RunTree.Logging       Test.Sandwich.Interpreters.RunTree.Util       Test.Sandwich.Interpreters.StartTree+      Test.Sandwich.ParallelN       Test.Sandwich.RunTree       Test.Sandwich.Shutdown       Test.Sandwich.TestTimer

@@ -37,6 +37,7 @@   , it   , describe   , parallel+  , parallelN    -- * Context manager nodes   --@@ -100,6 +101,7 @@ 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

@@ -65,7 +65,7 @@    <*> optional (flag False True (long "list-tests" <> help "List individual test modules"))   <*> 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 Slack flags"))+  <*> optional (flag False True (long "print-webdriver-flags" <> help "Print the additional Webdriver flags"))    <*> individualTestParser 

@@ -32,3 +32,8 @@ -- introduce them manually getCommandLineOptions :: (HasCommandLineOptions context a, MonadReader context m, MonadIO m) => m (CommandLineOptions a) getCommandLineOptions = getContext commandLineOptions++-- | Get the user command line options, if configured.+-- This just calls 'getCommandLineOptions' and pulls out the user options.+getUserCommandLineOptions :: (HasCommandLineOptions context a, MonadReader context m, MonadIO m) => m a+getUserCommandLineOptions = optUserOptions <$> getContext commandLineOptions

@@ -24,7 +24,7 @@  printFailureReason :: FailureReason -> ReaderT (PrintFormatter, Int, Handle) IO () printFailureReason (Reason _ s) = do-  printShowBoxPrettyWithTitle "Reason: " (SEB s)+  printShowBoxPrettyWithTitleString "Reason: " s printFailureReason (ChildrenFailed _ n) = do   picn midWhite ([i|#{n} #{if n == 1 then ("child" :: String) else "children"} failed|] :: String) printFailureReason (ExpectedButGot _ seb1 seb2) = do@@ -70,6 +70,9 @@         picn midWhite title         printPretty True x >> p "\n" --- printShowBoxPretty (SEB v) = case P.reify v of---   Nothing -> forM_ (L.lines $ show v) pin---   Just x -> printPretty True x >> p "\n"+printShowBoxPrettyWithTitleString :: String -> String -> ReaderT (PrintFormatter, Int, Handle) IO ()+printShowBoxPrettyWithTitleString title s = do+  picn midWhite title+  withBumpIndent $ do+    forM_ (L.lines s) pin+  p "\n"

@@ -132,7 +132,7 @@     let wrappedAction = do           let failureResult e = case fromException e of                 Just fr@(Pending {}) -> Failure fr-                _ -> Failure $ Reason Nothing [i|around #{runTreeLabel} handler threw exception|]+                _ -> Failure $ Reason Nothing [i|around '#{runTreeLabel}' handler threw exception|]           flip withException (\e -> recordExceptionInStatus runTreeStatus e >> markAllChildrenWithResult runNodeChildren ctx (failureResult e)) $ do             runNodeActionWith $ do               results <- liftIO $ runNodesSequentially runNodeChildren ctx@@ -140,7 +140,7 @@               return results            (liftIO $ readIORef didRunWrappedAction) >>= \case-            Left () -> return $ Failure $ Reason Nothing [i|introduceWith '#{runTreeLabel}' handler didn't call action|]+            Left () -> return $ Failure $ Reason Nothing [i|around '#{runTreeLabel}' handler didn't call action|]             Right _ -> return Success     runExampleM'' wrappedAction ctx runTreeLogs (Just [i|Exception in introduceWith '#{runTreeLabel}' handler|]) startTree node@(RunNodeDescribe {..}) ctx' = do

@@ -65,22 +65,7 @@   (_, _, _, p) <- liftIO $ createProcess (cp { std_out = UseHandle hWrite, std_err = UseHandle hWrite })   return p --- | Same as 'createProcessWithLogging', but using 'readCreateProcess'.-readCreateProcessWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => CreateProcess -> String -> m String-readCreateProcessWithLogging 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}|]--  liftIO $ readCreateProcess (cp { std_out = UseHandle hWrite, std_err = UseHandle hWrite }) input---- | Higher level version of 'readCreateProcessWithLogging', accepting a shell command.+-- | Higher level version of 'createProcessWithLogging', accepting a shell command. callCommandWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => String -> m () callCommandWithLogging cmd = do   (hRead, hWrite) <- liftIO createPipe

@@ -0,0 +1,34 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE FlexibleContexts #-}++-- | Wrapper around 'parallel' for limiting the threads using a semaphore.++module Test.Sandwich.ParallelN (parallelN) 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.Types.Spec+import Test.Sandwich.Contexts++++-- | Wrapped 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 ()+parallelN n children = introduceParallelSemaphore n $ parallel $ aroundEach "Take parallel semaphore" claimRunSlot children+  where 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 ())