sandwich 0.3.0.5 → 0.3.1.0

raw patch · 43 files changed

+2275/−454 lines, 43 filesdep +networkPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: network

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−0
• app/Main.hs +36/−37
• discover/Main.hs +1/−1
• sandwich.cabal +15/−2
• src/Test/Sandwich.hs +148/−17
• src/Test/Sandwich/ArgParsing.hs +53/−7
• src/Test/Sandwich/Contexts.hs +2/−2
• src/Test/Sandwich/Formatters/Print/CallStacks.hs +11/−2
• src/Test/Sandwich/Formatters/Print/Logs.hs +2/−2
• src/Test/Sandwich/Formatters/Socket.hs +83/−0
• src/Test/Sandwich/Formatters/Socket/Commands.hs +246/−0
• src/Test/Sandwich/Formatters/Socket/Server.hs +150/−0
• src/Test/Sandwich/Formatters/TerminalUI.hs +55/−30
• src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs +3/−0
• src/Test/Sandwich/Formatters/TerminalUI/DebugSocket.hs +37/−0
• src/Test/Sandwich/Formatters/TerminalUI/Draw.hs +16/−1
• src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs +4/−0
• src/Test/Sandwich/Formatters/TerminalUI/Draw/Util.hs +8/−3
• src/Test/Sandwich/Formatters/TerminalUI/Keys.hs +1/−0
• src/Test/Sandwich/Formatters/TerminalUI/Types.hs +8/−0
• src/Test/Sandwich/Instrumentation.hs +188/−0
• src/Test/Sandwich/Internal/Running.hs +17/−10
• src/Test/Sandwich/Interpreters/RunTree/Logging.hs +14/−3
• src/Test/Sandwich/Interpreters/RunTree/Util.hs +0/−10
• src/Test/Sandwich/Interpreters/StartTree.hs +207/−67
• src/Test/Sandwich/Logging.hs +14/−179
• src/Test/Sandwich/Logging/Process.hs +198/−0
• src/Test/Sandwich/Logging/ProcessFileLogging.hs +162/−0
• src/Test/Sandwich/ManagedAsync.hs +121/−0
• src/Test/Sandwich/Options.hs +12/−8
• src/Test/Sandwich/ParallelN.hs +1/−1
• src/Test/Sandwich/TH.hs +1/−1
• src/Test/Sandwich/TestTimer.hs +42/−8
• src/Test/Sandwich/Types/ArgParsing.hs +9/−0
• src/Test/Sandwich/Types/RunTree.hs +40/−8
• src/Test/Sandwich/Types/Spec.hs +3/−3
• src/Test/Sandwich/Types/TestTimer.hs +4/−4
• src/Test/Sandwich/Waits.hs +6/−2
• test/Around.hs +127/−2
• test/Describe.hs +1/−1
• test/Introduce.hs +94/−25
• test/IntroduceWith.hs +116/−13
• test/TestUtil.hs +6/−5

@@ -1,5 +1,18 @@ # Changelog for sandwich +## 0.3.1.0++* Add a socket formatter (`Test.Sandwich.Formatters.Socket`) and a TUI debug socket (`Test.Sandwich.Formatters.TerminalUI.DebugSocket`).+* Add process file logging in `Test.Sandwich.Logging.ProcessFileLogging` (`createProcessWithFileLogging`).+* Add `Test.Sandwich.ManagedAsync`.+* Add `Test.Sandwich.Instrumentation`.+* Better avoid hangs from long running nodes (#118, #119).+* Make `--log-events` capture all the way up to the end of `runSandwich'`.+* Add `--list-tests-json`.+* Improve speedscope timing (#114).+* Fix an exception race and a typo in the introduce async exception handler.+* Remove spaces from `defaultTestArtifactsDirectory`.+ ## 0.3.0.5  * Preserve configured test artifacts directory (#109)

@@ -8,54 +8,53 @@ import UnliftIO.Exception import Control.Monad import Control.Monad.IO.Class-import Control.Monad.Logger (LogLevel(..)) import Data.String.Interpolate import Test.Sandwich-import Test.Sandwich.Formatters.FailureReport import Test.Sandwich.Formatters.LogSaver-import Test.Sandwich.Formatters.Print-import Test.Sandwich.Formatters.TerminalUI  -data Database = Database String+newtype Database = Database String   deriving Show  data Foo = Foo { fooInt :: Int, fooString :: String, fooBar :: Bar } deriving (Show, Eq) data Bar = Bar { barInt :: Int, barString :: String } deriving (Show, Eq) data Baz = Baz Int String Bar deriving (Show, Eq)-data Simple = Simple { simpleInt :: Int } deriving (Show, Eq)+newtype Simple = Simple { simpleInt :: Int } deriving (Show, Eq) -database = Label :: Label "database" Database-otherDatabase = Label :: Label "otherDatabase" Database+database :: Label "database" Database+database = Label +otherDatabase :: Label "otherDatabase" Database+otherDatabase = Label+ documentation :: TopSpec documentation = describe "arithmetic" $ do   it "tests addition" $ do-    (2 + 2) `shouldBe` 4+    (2 + 2) `shouldBe` (4 :: Int)    it "tests subtraction" $ do     warn "Having some trouble getting this test to pass..."-    (2 - 2) `shouldBe` 1+    (2 - 2) `shouldBe` (1 :: Int)    verySimple :: TopSpec verySimple = do   it "succeeds" (return ())-  it "tries shouldBe" (2 `shouldBe` 3)+  it "tries shouldBe" (2 `shouldBe` (3 :: Int))   it "tries shouldBe with Foo" (Foo 2 "asdf" (Bar 2 "asdf") `shouldBe` Foo 3 "fdsa" (Bar 3 "fdsa"))   it "tries shouldBe with Baz" (Baz 2 "asdf" (Bar 2 "asdf") `shouldBe` Baz 3 "fdsa" (Bar 3 "fdsa"))-  it "tries shouldBe with list" ([1, 2, 3] `shouldBe` [4, 5, 6])-  it "tries shouldBe with tuple" ((1, 2, 3) `shouldBe` (4, 5, 6))+  it "tries shouldBe with list" ([1, 2, 3] `shouldBe` ([4, 5, 6] :: [Int]))+  it "tries shouldBe with tuple" ((1, 2, 3) `shouldBe` ((4, 5, 6) :: (Int, Int, Int)))   it "tries shouldBe with list of constructors" ([Simple 1, Simple 2] `shouldBe` [Simple 3, Simple 4])-  it "tries shouldNotBe" (2 `shouldNotBe` 2)-  it "is pending" $ pending+  it "tries shouldNotBe" (2 `shouldNotBe` (2 :: Int))+  it "is pending" pending   it "is pending with message" $ pendingWith "Not implemented yet..."   it "throws an exception" $ do-    2 `shouldBe` 2-    throwIO $ userError "Want a stacktrace here"+    2 `shouldBe` (2 :: Int)+    void $ throwIO $ userError "Want a stacktrace here"     -- 3 `shouldBe` 4-    3 `shouldBe` 3+    3 `shouldBe` (3 :: Int)   it "does some logging" $ do     debug "debug message"     info "info message"@@ -73,7 +72,7 @@  cancellingIntroduce :: TopSpec cancellingIntroduce = do-  introduce "alloc sleeps forever" database ((forever $ liftIO $ threadDelay 1000000) >> return (Database "foo")) (const $ return ()) $ do+  introduce "alloc sleeps forever" database (forever (liftIO $ threadDelay 1000000) >> return (Database "foo")) (const $ return ()) $ do     it "sleeps forever" $ do       forever $ liftIO $ threadDelay 1     it "succeeds after 1 second" $ do@@ -83,7 +82,7 @@ manyRows :: TopSpec manyRows = do   forM_ [(0 :: Int)..100] $ \n ->-    it [i|does the thing #{n}|] (2 `shouldBe` 2)+    it [i|does the thing #{n}|] (2 `shouldBe` (2 :: Int))  simple :: TopSpec simple = do@@ -122,25 +121,25 @@     it "uses the DB" $ do       db <- getContext database       debug [i|Got db: #{db}|]-      liftIO $ threadDelay (3 * 10^6)+      liftIO $ threadDelay (3 * 10^(6 :: Int)) -  introduce "Database" database (debug "making DB" >> (return $ Database "outer")) (const $ return ()) $ do+  introduce "Database" database (debug "making DB" >> return (Database "outer")) (const $ return ()) $ do     it "uses the DB 1" $ do       db <- getContext database       debug [i|Got db: #{db}|] -    introduce "Database again" database (return $ Database "shadowing") (const $ return ()) $ do-      introduce "Database again" otherDatabase (return $ Database "other") (const $ return ()) $ do+    introduce "Database again" database (return (Database "shadowing")) (const $ return ()) $ do+      introduce "Database again" otherDatabase (return (Database "other")) (const $ return ()) $ do         it "uses the DB 2" $ do           db <- getContext database           debug [i|Got db: #{db}|]           otherDb <- getContext otherDatabase           debug [i|Got otherDb: #{otherDb}|] -    it "does a thing sequentially" $ sleepThenFail-    it "does a thing sequentially 2" $ sleepThenSucceed-    it "does a thing sequentially 3" $ sleepThenSucceed-    it "does a thing sequentially 4" $ sleepThenSucceed+    it "does a thing sequentially" sleepThenFail+    it "does a thing sequentially 2" sleepThenSucceed+    it "does a thing sequentially 3" sleepThenSucceed+    it "does a thing sequentially 4" sleepThenSucceed    afterEach "after each" (return ()) $ do     beforeEach "before each" (return ()) $ do@@ -154,19 +153,19 @@   it "does bar" sleepThenSucceed    after "after" (debug "doing after") $ do-    it "has a thing after it" $ sleepThenSucceed+    it "has a thing after it" sleepThenSucceed  introduceFailure :: TopSpec introduceFailure = do-  introduceWith "Database around" database (\action -> liftIO $ throwIO $ userError "Failed to get DB") $ do-    introduce "Database" database (debug "making DB" >> (return $ Database "outer")) (const $ return ()) $ do+  introduceWith "Database around" database (\_action -> liftIO $ throwIO $ userError "Failed to get DB") $ do+    introduce "Database" database (debug "making DB" >> return (Database "outer")) (const $ return ()) $ do       it "uses the DB 1" $ do         db <- getContext database         debug [i|Got db: #{db}|]  introduceWithInterrupt :: TopSpec introduceWithInterrupt = do-  introduceWith "Database around" database (\action -> liftIO $ threadDelay 999999999999999) $ do+  introduceWith "Database around" database (\_action -> liftIO $ threadDelay 999999999999999) $ do     it "uses the DB 1" $ do       db <- getContext database       debug [i|Got db: #{db}|]@@ -182,11 +181,11 @@ longLogs :: TopSpec longLogs = do   it "does thing 1" $-    shouldFail (2 `shouldBe` 3)+    shouldFail (2 `shouldBe` (3 :: Int))   it "does thing 2" $     shouldFailPredicate (\case                             Reason {} -> True-                            _ -> False) (2 `shouldBe` 3)+                            _ -> False) (2 `shouldBe` (3 :: Int))   it "does thing 3" $ do     forM_ [(0 :: Int)..200] $ \n -> debug [i|Log entry #{n}|]   it "does thing 4" $ return ()@@ -206,13 +205,13 @@  sleepThenSucceed :: ExampleM context () sleepThenSucceed = do-  liftIO $ threadDelay (2 * 10^1)+  liftIO $ threadDelay (2 * 10^(1 :: Int))   -- liftIO $ threadDelay (2 * 10^5)   -- liftIO $ threadDelay (1 * 10^6)  sleepThenFail :: ExampleM context () sleepThenFail = do-  liftIO $ threadDelay (2 * 10^1)+  liftIO $ threadDelay (2 * 10^(1 :: Int))   -- liftIO $ threadDelay (2 * 10^5)   -- liftIO $ threadDelay (1 * 10^6)-  2 `shouldBe` 3+  2 `shouldBe` (3 :: Int)

@@ -14,7 +14,7 @@ import Test.Sandwich.TH  -data SandwichDiscoverOptions = SandwichDiscoverOptions {+newtype SandwichDiscoverOptions = SandwichDiscoverOptions {   sandwichDiscoverModulePrefix :: String -- TODO: don't use this, instead detect the module some other way (haskell-src-exts? fancy regex?)   } 

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.38.0.+-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack  name:           sandwich-version:        0.3.0.5+version:        0.3.1.0 synopsis:       Yet another test framework for Haskell description:    Please see the <https://codedownio.github.io/sandwich documentation>. category:       Testing@@ -38,6 +38,7 @@       Test.Sandwich.Formatters.LogSaver       Test.Sandwich.Formatters.Print       Test.Sandwich.Formatters.Silent+      Test.Sandwich.Formatters.Socket       Test.Sandwich.Formatters.TerminalUI       Test.Sandwich.Internal       Test.Sandwich.TH@@ -57,8 +58,11 @@       Test.Sandwich.Formatters.Print.PrintPretty       Test.Sandwich.Formatters.Print.Types       Test.Sandwich.Formatters.Print.Util+      Test.Sandwich.Formatters.Socket.Commands+      Test.Sandwich.Formatters.Socket.Server       Test.Sandwich.Formatters.TerminalUI.AttrMap       Test.Sandwich.Formatters.TerminalUI.CrossPlatform+      Test.Sandwich.Formatters.TerminalUI.DebugSocket       Test.Sandwich.Formatters.TerminalUI.Draw       Test.Sandwich.Formatters.TerminalUI.Draw.ColorProgressBar       Test.Sandwich.Formatters.TerminalUI.Draw.RunTimes@@ -70,6 +74,7 @@       Test.Sandwich.Formatters.TerminalUI.OpenInEditor       Test.Sandwich.Formatters.TerminalUI.Types       Test.Sandwich.Golden.Update+      Test.Sandwich.Instrumentation       Test.Sandwich.Internal.Formatters       Test.Sandwich.Internal.Inspection       Test.Sandwich.Internal.Running@@ -81,6 +86,9 @@       Test.Sandwich.Interpreters.RunTree.Logging       Test.Sandwich.Interpreters.RunTree.Util       Test.Sandwich.Interpreters.StartTree+      Test.Sandwich.Logging.Process+      Test.Sandwich.Logging.ProcessFileLogging+      Test.Sandwich.ManagedAsync       Test.Sandwich.ParallelN       Test.Sandwich.RunTree       Test.Sandwich.Shutdown@@ -128,6 +136,7 @@     , monad-control     , monad-logger     , mtl+    , network     , optparse-applicative     , pretty-show     , process@@ -190,6 +199,7 @@     , monad-control     , monad-logger     , mtl+    , network     , optparse-applicative     , pretty-show     , process@@ -250,6 +260,7 @@     , monad-control     , monad-logger     , mtl+    , network     , optparse-applicative     , pretty-show     , process@@ -316,6 +327,7 @@     , monad-control     , monad-logger     , mtl+    , network     , optparse-applicative     , pretty-show     , process@@ -383,6 +395,7 @@     , monad-control     , monad-logger     , mtl+    , network     , optparse-applicative     , pretty-show     , process

@@ -56,6 +56,15 @@   , withTimingProfile   , withTimingProfile' +  -- * Managed async+  --+  -- | If you want to run asyncs within your tests, we can help keep track of+  -- them and make sure they get cleaned up.+  , managedAsync+  , managedAsyncWithUnmask+  , managedWithAsync+  , managedWithAsync_+   -- * Exports   , module Test.Sandwich.Contexts   , module Test.Sandwich.Expectations@@ -72,31 +81,40 @@ import Control.Monad import Control.Monad.Free import Control.Monad.IO.Class+import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Logger import Control.Monad.Reader+import qualified Data.Aeson as A+import qualified Data.ByteString.Lazy as BL import Data.Either import Data.Function import Data.IORef import qualified Data.List as L+import qualified Data.Map as M import Data.Maybe import Data.String.Interpolate import qualified Data.Text as T+import Data.Time (getCurrentTime)+import Debug.Trace (traceMarkerIO) import GHC.IO.Encoding import Options.Applicative import qualified Options.Applicative as OA import System.Environment import System.Exit import System.FilePath+import System.IO (hSetBuffering, BufferMode(..), IOMode(..), openFile, hClose) import Test.Sandwich.ArgParsing import Test.Sandwich.Contexts import Test.Sandwich.Expectations import Test.Sandwich.Formatters.Common.Count import Test.Sandwich.Golden.Update+import Test.Sandwich.Instrumentation 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 qualified Test.Sandwich.ManagedAsync as MA import Test.Sandwich.Misc import Test.Sandwich.Nodes import Test.Sandwich.Options@@ -111,6 +129,7 @@ import Test.Sandwich.Types.Spec import Test.Sandwich.Types.TestTimer import UnliftIO.Exception+import UnliftIO.Timeout (timeout)  #ifdef mingw32_HOST_OS import System.Win32.Console (setConsoleOutputCP)@@ -121,7 +140,7 @@ runSandwich :: Options -> CoreSpec -> IO () runSandwich options spec = do   (_exitReason, _itNodeFailures, totalFailures) <- runSandwich' Nothing options spec-  when (0 < totalFailures) $ exitFailure+  when (0 < totalFailures) exitFailure  -- | Run the spec, configuring the options from the command line. runSandwichWithCommandLineArgs :: Options -> TopSpecWithOptions -> IO ()@@ -154,6 +173,9 @@            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."+     | optListAvailableTestsJson clo == Just True -> do+         BL.putStr $ A.encode [M.fromList [("module" :: T.Text, nodeModuleInfoModuleName), ("flag", "--" <> T.unpack shorthand)]+                              | (NodeModuleInfo {..}, shorthand) <- modulesAndShorthands]      | optUpdateGolden (optGoldenOptions clo) == Just True -> do          updateGolden (optGoldenDir (optGoldenOptions clo))      | otherwise -> do@@ -163,18 +185,18 @@          let cliNodeOptions = defaultNodeOptions { nodeOptionsVisibilityThreshold = systemVisibilityThreshold                                                  , nodeOptionsCreateFolder = False } -         runWithRepeat repeatCount totalTests $+         let mkRunId idx = if repeatCount == 1 then "run" else [i|repeat-#{idx}|]+         runWithRepeat repeatCount totalTests $ \repeatIdx -> do+           let opts = options { optionsRunId = mkRunId repeatIdx }            case optIndividualTestModule clo of-             Nothing -> runSandwich' (Just $ clo { optUserOptions = () }) options $+             Nothing -> runSandwich' (Just $ clo { optUserOptions = () }) opts $                introduce' cliNodeOptions "some command line options" someCommandLineOptions (pure (SomeCommandLineOptions clo)) (const $ return ())-                 $ introduce' cliNodeOptions "command line options" commandLineOptions (pure clo) (const $ return ())-                 $ spec-             Just (IndividualTestModuleName x) -> runSandwich' (Just $ clo { optUserOptions = () }) options $ filterTreeToModule x $+                 $ introduce' cliNodeOptions "command line options" commandLineOptions (pure clo) (const $ return ()) spec+             Just (IndividualTestModuleName x) -> runSandwich' (Just $ clo { optUserOptions = () }) opts $ filterTreeToModule x $                introduce' cliNodeOptions "some command line options" someCommandLineOptions (pure (SomeCommandLineOptions clo)) (const $ return ())-                 $ introduce' cliNodeOptions "command line options" commandLineOptions (pure clo) (const $ return ())-                 $ spec+                 $ introduce' cliNodeOptions "command line options" commandLineOptions (pure clo) (const $ return ()) spec              Just (IndividualTestMainFn x) -> do-               let individualTestFlagStrings = [[ Just ("--" <> shorthand), const ("--" <> shorthand <> "-main") <$> nodeModuleInfoFn ]+               let individualTestFlagStrings = [[ Just ("--" <> shorthand), ("--" <> shorthand <> "-main") <$ nodeModuleInfoFn ]                                                | (NodeModuleInfo {..}, shorthand) <- modulesAndShorthands]                                              & mconcat                                              & catMaybes@@ -189,8 +211,26 @@ -- may also include other nodes like "introduce" nodes). runSandwich' :: Maybe (CommandLineOptions ()) -> Options -> CoreSpec -> IO (ExitReason, Int, Int) runSandwich' maybeCommandLineOptions options spec' = do+  let runId = optionsRunId options   baseContext <- baseContextFromOptions options +  -- Open late-log file if --log-logs is active+  maybeLateLogHandle <- case (maybeCommandLineOptions, baseContextRunRoot baseContext) of+    (Just clo, Just runRoot) | optLogLogs clo -> do+      h <- openFile (runRoot </> "late-logs.log") AppendMode+      hSetBuffering h LineBuffering+      return (Just h)+    _ -> return Nothing++  let options' = options { optionsLateLogFile = maybeLateLogHandle }++  let milestone msg = do+        traceMarkerIO [i|sandwich: #{msg}|]+        now <- getCurrentTime+        case optionsEventBroadcast options' of+          Just chan -> atomically $ writeTChan chan (NodeEvent now 0 "sandwich" (EventMilestone msg))+          Nothing -> return ()+   -- To prevent weird errors saving files like "commitAndReleaseBuffer: invalid argument (invalid character)",   -- especially on Windows   -- See https://gitlab.haskell.org/ghc/ghc/issues/8118@@ -209,16 +249,48 @@                         , nodeOptionsCreateFolder = False                         }) "Finalize test timer" (asks getTestTimer >>= liftIO . finalizeSpeedScopeTestTimer) spec' -  rts <- startSandwichTree' baseContext options spec+  milestone "startSandwichTree'"+  rts <- startSandwichTree' baseContext options' spec -  formatterAsyncs <- forM (optionsFormatters options) $ \(SomeFormatter f) -> async $ do-    let loggingFn = case baseContextRunRoot baseContext of-          Nothing -> flip runLoggingT (\_ _ _ _ -> return ())-          Just rootPath -> runFileLoggingT (rootPath </> (formatterName f) <.> "log")+  milestone "spawning formatters"+  formatterAsyncs <- forM (optionsFormatters options') $ \(SomeFormatter f) ->+    MA.managedAsync runId (T.pack [i|formatter:#{formatterName f}|]) $ do+      let loggingFn = case baseContextRunRoot baseContext of+            Nothing -> flip runLoggingT (\_ _ _ _ -> return ())+            Just rootPath -> runFileLoggingT (rootPath </> (formatterName f) <.> "log") -    loggingFn $-      runFormatter f rts maybeCommandLineOptions baseContext+      loggingFn $+        runFormatter f rts maybeCommandLineOptions baseContext +  -- Spawn file writer asyncs for --log-logs, --log-events, --log-rts-stats, --log-asyncs+  milestone "spawning file stream asyncs"+  (fileStreamAsyncs, maybeEventStreamAsync, maybeManagedAsyncStreamAsync) <- case (maybeCommandLineOptions, baseContextRunRoot baseContext) of+    (Just clo, Just runRoot) -> do+      others <- fmap catMaybes $ sequence+        [ if optLogLogs clo+          then case optionsLogBroadcast options' of+            Just chan -> Just <$> MA.managedAsync runId "stream-logs" (streamLogsToFile (runRoot </> "all-logs.log") chan)+            Nothing -> return Nothing+          else return Nothing+        , if optLogRtsStats clo+          then Just <$> MA.managedAsync runId "stream-rts-stats" (streamRtsStatsToFile (runRoot </> "rts-stats.log"))+          else return Nothing+        ]+      -- Spawn stream-events separately so we can drain it gracefully via EventEndOfStream+      maybeEvtAsync <- if optLogEvents clo+        then do+          writeTreeFile (runRoot </> "events-tree.txt") rts+          case optionsEventBroadcast options' of+            Just chan -> Just <$> MA.managedAsync runId "stream-events" (streamEventsToFile (runRoot </> "events.log") chan)+            Nothing -> return Nothing+        else return Nothing+      -- Spawn the managed-async event stream separately so we can cancel it last+      maybeManagedAsync <- if optLogAsyncs clo+        then Just <$> MA.managedAsync runId "stream-managed-asyncs" (streamManagedAsyncEventsToFile (runRoot </> "asyncs.log") MA.asyncEventBroadcast)+        else return Nothing+      return (others, maybeEvtAsync, maybeManagedAsync)+    _ -> return ([], Nothing, Nothing)+   exitReasonRef <- newIORef NormalExit    let shutdown sig = do@@ -234,24 +306,65 @@   _ <- installHandler sigTERM shutdown    -- Wait for the tree to finish+  milestone "waiting for tree"   mapM_ waitForTree rts+  milestone "tree finished"    -- Wait for all formatters to finish+  milestone "waiting for formatters"   finalResults :: [Either E.SomeException ()] <- forM formatterAsyncs $ E.try . wait   let failures = lefts finalResults   unless (null failures) $     putStrLn [i|Some formatters failed: '#{failures}'|]+  milestone "formatters finished"    -- Run finalizeFormatter method on formatters-  forM_ (optionsFormatters options) $ \(SomeFormatter f) -> do+  milestone [i|finalizing formatters: #{optionsFormatters options'}|]+  forM_ (optionsFormatters options') $ \(SomeFormatter f) -> do+    milestone [i|finalizing formatter: #{f}|]+     let loggingFn = case baseContextRunRoot baseContext of           Nothing -> flip runLoggingT (\_ _ _ _ -> return ())           Just rootPath -> runFileLoggingT (rootPath </> (formatterName f) <.> "log")      loggingFn $ finalizeFormatter f rts baseContext +  milestone "fixing tree"   fixedTree <- atomically $ mapM fixRunTree rts +  -- Close late-log file handle+  mapM_ hClose maybeLateLogHandle++  -- Emit the "done" milestone before draining the event stream+  milestone "done"++  -- Signal the event stream to stop and wait for it to drain (with 60s timeout)+  case optionsEventBroadcast options' of+    Just chan -> do+      now <- getCurrentTime+      atomically $ writeTChan chan (NodeEvent now 0 "sandwich" EventEndOfStream)+    Nothing -> return ()+  forM_ maybeEventStreamAsync $ \asy ->+    timeout 60_000_000 (wait asy) >>= \case+      Nothing -> do+        putStrLn "WARNING: stream-events async didn't exit within 60s, cancelling"+        cancel asy+      Just _ -> return ()++  -- Cancel remaining file stream asyncs (but not the managed-async stream yet)+  mapM_ cancel fileStreamAsyncs++  -- Cancel the managed-async stream last, so its finally block captures the final state+  mapM_ cancel maybeManagedAsyncStreamAsync++  -- Check for stale managed asyncs from this run+  milestone "checking for stale asyncs"+  asyncs <- MA.getManagedAsyncInfos+  unless (M.null asyncs) $ do+    putStrLn [i|WARNING: #{M.size asyncs} managed asyncs still running after tree finished:|]+    forM_ (M.toList asyncs) $ \(tid, x) ->+      putStrLn [i|  #{tid}: #{MA.asyncInfoName x}|]+   exitReason <- readIORef exitReasonRef   let failedItBlocks = countWhere isFailedItBlock fixedTree   let failedBlocks = countWhere isFailedBlock fixedTree@@ -265,3 +378,21 @@ countItNodes (Free (Introduce'' {..})) = countItNodes next + countItNodes subspecAugmented countItNodes (Free x) = countItNodes (next x) + countItNodes (subspec x) countItNodes (Pure _) = 0++-- * Managed async (context-aware aliases)++-- | Launch a managed async thread, tracking it with the run ID from 'BaseContext'.+managedAsync :: (MonadUnliftIO m, HasBaseContextMonad context m) => T.Text -> m a -> m (Async a)+managedAsync = MA.managedAsyncContext++-- | Like 'managedAsync', but the action receives an unmask function.+managedAsyncWithUnmask :: (MonadUnliftIO m, HasBaseContextMonad context m) => T.Text -> ((forall b. m b -> m b) -> m a) -> m (Async a)+managedAsyncWithUnmask = MA.managedAsyncWithUnmaskContext++-- | Run a managed async thread scoped to a callback.+managedWithAsync :: (MonadUnliftIO m, HasBaseContextMonad context m) => T.Text -> m a -> (Async a -> m b) -> m b+managedWithAsync = MA.managedWithAsyncContext++-- | Like 'managedWithAsync', but ignores the 'Async' handle.+managedWithAsync_ :: (MonadUnliftIO m, HasBaseContextMonad context m) => T.Text -> m a -> m b -> m b+managedWithAsync_ = MA.managedWithAsyncContext_

@@ -5,13 +5,13 @@  module Test.Sandwich.ArgParsing where +import Control.Concurrent.STM 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 (UTCTime)-import Data.Time.Clock.POSIX import Data.Typeable import Options.Applicative import qualified Options.Applicative as OA@@ -20,6 +20,7 @@ import Test.Sandwich.Formatters.MarkdownSummary import Test.Sandwich.Formatters.Print.Types import Test.Sandwich.Formatters.Silent+import Test.Sandwich.Formatters.Socket import Test.Sandwich.Formatters.TerminalUI import Test.Sandwich.Formatters.TerminalUI.Types import Test.Sandwich.Internal.Running@@ -92,9 +93,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 (option auto (long "warn-on-long-execution-ms" <> showDefault <> help "Warn on long-running nodes by writing to a file in the run root." <> metavar "INT"))+  <*> optional (option auto (long "cancel-on-long-execution-ms" <> showDefault <> help "Cancel long-running nodes and write to a file in the run root." <> metavar "INT"))   <*> optional (strOption (long "markdown-summary" <> help "File path to write a Markdown summary of the results." <> metavar "STRING"))+  <*> switch (long "tui-debug" <> help "Enable TUI debug socket at <test-root>/tui-debug.sock")+  <*> switch (long "socket" <> help "Enable interactive socket formatter at <test-root>/socket.sock")+  <*> switch (long "log-logs" <> help "Stream all test logs to <run-root>/logs.txt (for debugging)")+  <*> switch (long "log-events" <> help "Stream node lifecycle events to <run-root>/events.txt (for debugging)")+  <*> switch (long "log-rts-stats" <> help "Stream RTS memory stats to <run-root>/rts-stats.txt (for debugging)")+  <*> switch (long "log-asyncs" <> help "Stream managed async lifecycle events to <run-root>/managed-asyncs.log (for debugging)")    <*> optional (flag False True (long "list-tests" <> help "List individual test modules"))+  <*> optional (flag False True (long "list-tests-json" <> help "List individual test modules in JSON format"))   <*> optional (flag False True (long "print-golden-flags" <> help "Print the additional golden testing flags"))   <*> 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"))@@ -251,23 +261,38 @@           printFormatter         (_, TUI) ->           let mainTerminalUiFormatter = headMay [x | SomeFormatter (cast -> Just x@(TerminalUIFormatter {})) <- optionsFormatters baseOptions]-          in SomeFormatter $ (fromMaybe defaultTerminalUIFormatter mainTerminalUiFormatter) { terminalUILogLevel = optLogLevel }+          in SomeFormatter $ (fromMaybe defaultTerminalUIFormatter mainTerminalUiFormatter) {+            terminalUILogLevel = optLogLevel+            , terminalUIDebugSocket = optTuiDebugSocket+            }         (_, Print) -> printFormatter         (_, PrintFailures) -> failureReportFormatter         (_, Silent) -> silentFormatter    -- Strip out any "main" formatters since the options control that-  let baseFormatters = optionsFormatters baseOptions-                     & tryAddMarkdownSummaryFormatter optMarkdownSummaryPath-                     & filter (not . isMainFormatter)+  (baseFormatters, socketLogBroadcast, socketEventBroadcast) <- optionsFormatters baseOptions+    & tryAddMarkdownSummaryFormatter optMarkdownSummaryPath+    & tryAddSocketFormatter optSocketFormatter+  let baseFormatters' = filter (not . isMainFormatter) baseFormatters -  let finalFormatters = baseFormatters <> [mainFormatter]+  -- Ensure broadcast channels exist if file logging flags need them+  maybeLogBroadcast <- case socketLogBroadcast of+    Just ch -> return (Just ch)+    Nothing | optLogLogs -> Just <$> newBroadcastTChanIO+    Nothing -> return Nothing++  maybeEventBroadcast <- case socketEventBroadcast of+    Just ch -> return (Just ch)+    Nothing | optLogEvents -> Just <$> newBroadcastTChanIO+    Nothing -> return Nothing++  let finalFormatters = baseFormatters' <> [mainFormatter]                       & fmap (setVisibilityThreshold optVisibilityThreshold)    let options = baseOptions {     optionsTestArtifactsDirectory = case optFixedRoot of       Nothing -> case optionsTestArtifactsDirectory baseOptions of-        TestArtifactsNone -> TestArtifactsGeneratedDirectory "test_runs" (formatTime <$> getCurrentTime)+        TestArtifactsNone -> defaultTestArtifactsDirectory         existing -> existing       Just path -> TestArtifactsFixedDirectory path     , optionsPruneTree = case optTreePrune of@@ -278,6 +303,10 @@         xs -> Just $ TreeFilter xs     , optionsFormatters = finalFormatters     , optionsDryRun = fromMaybe (optionsDryRun baseOptions) optDryRun+    , optionsWarnOnLongExecutionMs = (optionsWarnOnLongExecutionMs baseOptions) <|> optWarnOnLongExecutionMs+    , optionsCancelOnLongExecutionMs = (optionsCancelOnLongExecutionMs baseOptions) <|> optCancelOnLongExecutionMs+    , optionsLogBroadcast = maybeLogBroadcast+    , optionsEventBroadcast = maybeEventBroadcast     }    return (options, optRepeatCount)@@ -314,3 +343,20 @@     tryAddMarkdownSummaryFormatter (Just path) xs       | L.any isMarkdownSummaryFormatter xs = fmap (setMarkdownSummaryFormatterPath path) xs       | otherwise = (SomeFormatter (defaultMarkdownSummaryFormatter path)) : xs++    isSocketFormatter :: SomeFormatter -> Bool+    isSocketFormatter (SomeFormatter x) = case cast x of+      Just (_ :: SocketFormatter) -> True+      Nothing -> False++    tryAddSocketFormatter :: Bool -> [SomeFormatter] -> IO ([SomeFormatter], Maybe (TChan (Int, String, LogEntry)), Maybe (TChan NodeEvent))+    tryAddSocketFormatter False xs = return (xs, Nothing, Nothing)+    tryAddSocketFormatter True xs+      | L.any isSocketFormatter xs =+          -- Extract the broadcast channels from the existing formatter+          let logChan = headMay [socketFormatterLogBroadcast sf | SomeFormatter (cast -> Just sf@(SocketFormatter {})) <- xs]+              eventChan = headMay [socketFormatterEventBroadcast sf | SomeFormatter (cast -> Just sf@(SocketFormatter {})) <- xs]+          in return (xs, logChan, eventChan)+      | otherwise = do+          sf <- defaultSocketFormatter+          return ((SomeFormatter sf) : xs, Just (socketFormatterLogBroadcast sf), Just (socketFormatterEventBroadcast sf))

@@ -54,9 +54,9 @@ -- | Push a label to the context. pushContext :: forall m l a intro context. Label l intro -> intro -> ExampleT (LabelValue l intro :> context) m a -> ExampleT context m a pushContext _label value (ExampleT action) = do-  ExampleT $ withReaderT (\context -> LabelValue value :> context) $ action+  ExampleT $ withReaderT (\context -> LabelValue value :> context) action  -- | Remove a label from the context. popContext :: forall m l a intro context. Label l intro -> ExampleT context m a -> ExampleT (LabelValue l intro :> context) m a popContext _label (ExampleT action) = do-  ExampleT $ withReaderT (\(_ :> context) -> context) $ action+  ExampleT $ withReaderT (\(_ :> context) -> context) action

@@ -1,6 +1,9 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -module Test.Sandwich.Formatters.Print.CallStacks where+module Test.Sandwich.Formatters.Print.CallStacks (+  printCallStack+  , printSrcLoc+  ) where  import Control.Monad import Control.Monad.IO.Class@@ -20,10 +23,16 @@ printCallStackLine :: (   MonadReader (PrintFormatter, Int, Handle) m, MonadIO m   ) => (String, SrcLoc) -> m ()-printCallStackLine (f, (SrcLoc {..})) = do+printCallStackLine (f, srcLoc) = do   pic logFunctionColor f    p " called at "+  printSrcLoc srcLoc++printSrcLoc :: (+  MonadReader (PrintFormatter, Int, Handle) m, MonadIO m+  ) => SrcLoc -> m ()+printSrcLoc (SrcLoc {..}) = do   pc logFilenameColor srcLocFile   p ":"   pc logLineColor (show srcLocStartLine)

@@ -7,6 +7,7 @@ import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader+import qualified Data.ByteString.Char8 as BS8 import Data.String.Interpolate import System.IO import Test.Sandwich.Formatters.Print.Color@@ -30,7 +31,6 @@         forM_ logEntries $ \entry ->           when (logEntryLevel entry >= logLevel) $ printLogEntry entry - printLogEntry :: (   MonadReader (PrintFormatter, Int, Handle) m, MonadIO m   ) => LogEntry -> m ()@@ -53,7 +53,7 @@   pc logChColor (show ch)   p "] " -  p (show logEntryStr)+  p (BS8.unpack logEntryStr)    p "\n" 

@@ -0,0 +1,83 @@+-- | The socket formatter creates a Unix domain socket that accepts interactive,+-- line-based commands to query the live test tree state.+--+-- 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) runs in the+-- foreground.+--+-- The socket server stays alive for the entire duration of the test executable,+-- so you can query it even after tests have completed (until 'finalizeFormatter'+-- cleans it up).+--+-- Connect with @socat - UNIX-CONNECT:\<run-root\>/socket.sock@ and type+-- @help@ to see available commands.++module Test.Sandwich.Formatters.Socket (+  defaultSocketFormatter+  , SocketFormatter(..)+  ) where++import Control.Concurrent.STM+import Control.Monad.IO.Class+import Data.IORef+import System.FilePath+import Test.Sandwich.Formatters.Socket.Server+import Test.Sandwich.Interpreters.RunTree.Util (waitForTree)+import Test.Sandwich.ManagedAsync+import Test.Sandwich.Types.ArgParsing+import Test.Sandwich.Types.RunTree+import UnliftIO.Async (Async, cancel)+++data SocketFormatter = SocketFormatter {+  socketFormatterPath :: Maybe FilePath+  -- ^ Socket path. Nothing = \<run-root\>/socket.sock+  , socketFormatterServerAsync :: IORef (Maybe (Async ()))+  -- ^ Internal: handle to the running server thread, used for cleanup.+  , socketFormatterLogBroadcast :: TChan (Int, String, LogEntry)+  -- ^ Broadcast channel for streaming logs to connected clients.+  , socketFormatterEventBroadcast :: TChan NodeEvent+  -- ^ Broadcast channel for streaming node lifecycle events to connected clients.+  }++instance Show SocketFormatter where+  show (SocketFormatter {socketFormatterPath}) =+    "SocketFormatter {socketFormatterPath = " <> show socketFormatterPath <> "}"++defaultSocketFormatter :: IO SocketFormatter+defaultSocketFormatter = do+  ref <- newIORef Nothing+  chan <- newBroadcastTChanIO+  eventChan <- newBroadcastTChanIO+  return SocketFormatter {+    socketFormatterPath = Nothing+    , socketFormatterServerAsync = ref+    , socketFormatterLogBroadcast = chan+    , socketFormatterEventBroadcast = eventChan+    }++instance Formatter SocketFormatter where+  formatterName _ = "socket-formatter"+  runFormatter = run+  finalizeFormatter sf _ _ = liftIO $ do+    mAsync <- readIORef (socketFormatterServerAsync sf)+    case mAsync of+      Nothing -> return ()+      Just a -> cancel a++run :: (MonadIO m) => SocketFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()+run (SocketFormatter {..}) rts _maybeCommandLineOptions bc = do+  let runId = baseContextRunId bc+  case resolveSocketPath of+    Nothing -> return ()+    Just path -> liftIO $ do+      a <- managedAsync runId "socket-server" (socketServer runId path rts socketFormatterLogBroadcast socketFormatterEventBroadcast)+      writeIORef socketFormatterServerAsync (Just a)+      -- Block until all tests complete+      mapM_ waitForTree rts+  where+    resolveSocketPath = case socketFormatterPath of+      Just p -> Just p+      Nothing -> case baseContextRunRoot bc of+        Just runRoot -> Just (runRoot </> "socket.sock")+        Nothing -> Nothing

@@ -0,0 +1,246 @@+{-# LANGUAGE RankNTypes #-}++module Test.Sandwich.Formatters.Socket.Commands (+  handleCommand+  ) where++import Control.Concurrent.STM+import Control.Monad.Logger+import qualified Data.ByteString.Char8 as BS8+import Data.Foldable (toList)+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.String.Interpolate+import Data.Time+import Test.Sandwich.Formatters.Common.Count+import Test.Sandwich.Formatters.Common.Util+import Test.Sandwich.RunTree+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+import Text.Read (readMaybe)+++-- | Handle a single command and return the response text.+-- The response does NOT include the trailing ".\n" terminator; the caller adds that.+handleCommand :: [RunNode BaseContext] -> UTCTime -> String -> IO String+handleCommand rts now cmd = case words cmd of+  ["help"] -> return helpText+  ["status"] -> cmdStatus rts+  ["active"] -> cmdActive rts now+  ["failures"] -> cmdFailures rts+  ["pending"] -> cmdPending rts+  ["tree"] -> cmdTree rts+  ["node", idStr] -> case readMaybe idStr of+    Just nid -> cmdNode rts nid+    Nothing -> return [i|Error: invalid node id "#{idStr}"|]+  ["logs", idStr] -> case readMaybe idStr of+    Just nid -> cmdLogs rts nid+    Nothing -> return [i|Error: invalid node id "#{idStr}"|]+  [] -> return ""+  (c:_) -> return [i|Unknown command: #{c}\nType "help" for available commands.|]++helpText :: String+helpText = unlines+  [ "Available commands:"+  , "  help        - Show this help"+  , "  status      - Summary counts: total, running, succeeded, failed, pending, not started"+  , "  active      - List currently running nodes"+  , "  failures    - List failed nodes with failure reason"+  , "  pending     - List pending nodes"+  , "  tree        - Full tree with indented status"+  , "  node <id>   - Detail for a specific node"+  , "  logs <id>   - Show logs for a specific node"+  , "  stream-logs      - Stream all logs live (disconnect to stop)"+  , "  stream-events    - Stream node lifecycle events (started/done) live"+  , "  stream-rts-stats - Stream GHC RTS memory stats every 1s (needs +RTS -T)"+  ]++-- | Snapshot the tree atomically+snapshot :: [RunNode BaseContext] -> IO [RunNodeFixed BaseContext]+snapshot rts = atomically $ mapM fixRunTree rts++-- * Commands++cmdStatus :: [RunNode BaseContext] -> IO String+cmdStatus rts = do+  fixed <- snapshot rts+  let total = countWhere isItBlock fixed+      running = countWhere isRunningItBlock fixed+      succeeded = countWhere isSuccessItBlock fixed+      failed = countWhere isFailedItBlock fixed+      pend = countWhere isPendingItBlock fixed+      notStarted = countWhere isNotStartedItBlock fixed+  return $ unlines+    [ [i|total:       #{total}|]+    , [i|running:     #{running}|]+    , [i|succeeded:   #{succeeded}|]+    , [i|failed:      #{failed}|]+    , [i|pending:     #{pend}|]+    , [i|not started: #{notStarted}|]+    ]++cmdActive :: [RunNode BaseContext] -> UTCTime -> IO String+cmdActive rts now = do+  fixed <- snapshot rts+  let nodes = concatMap (extractValues getActiveInfo) fixed+      activeNodes = [x | Just x <- nodes]+  if null activeNodes+    then return "No nodes currently running."+    else return $ unlines [formatActive n | n <- activeNodes]+  where+    getActiveInfo :: RunNodeWithStatus ctx Status (Seq LogEntry) Bool -> Maybe (String, Int, NominalDiffTime)+    getActiveInfo node = case runTreeStatus (runNodeCommon node) of+      Running {statusStartTime} ->+        let c = runNodeCommon node+        in Just (runTreeLabel c, runTreeId c, diffUTCTime now statusStartTime)+      _ -> Nothing++    formatActive (label, nid, elapsed) =+      let elapsedStr = formatNominalDiffTime elapsed+      in [i|  [#{nid}] #{label} (#{elapsedStr})|]++cmdFailures :: [RunNode BaseContext] -> IO String+cmdFailures rts = do+  fixed <- snapshot rts+  let nodes = concatMap (extractValues getFailureInfo) fixed+      failedNodes = [x | Just x <- nodes]+  if null failedNodes+    then return "No failures."+    else return $ unlines [formatFailure n | n <- failedNodes]+  where+    getFailureInfo :: RunNodeWithStatus ctx Status (Seq LogEntry) Bool -> Maybe (String, Int, FailureReason)+    getFailureInfo node = case runTreeStatus (runNodeCommon node) of+      Done {statusResult = Failure (Pending {})} -> Nothing+      Done {statusResult = Failure reason} ->+        let c = runNodeCommon node+        in Just (runTreeLabel c, runTreeId c, reason)+      _ -> Nothing++    formatFailure (label, nid, reason) =+      [i|  [#{nid}] #{label}: #{showFailureReason reason}|]++cmdPending :: [RunNode BaseContext] -> IO String+cmdPending rts = do+  fixed <- snapshot rts+  let nodes = concatMap (extractValues getPendingInfo) fixed+      pendingNodes = [x | Just x <- nodes]+  if null pendingNodes+    then return "No pending nodes."+    else return $ unlines [formatPendingNode n | n <- pendingNodes]+  where+    getPendingInfo :: RunNodeWithStatus ctx Status (Seq LogEntry) Bool -> Maybe (String, Int, Maybe String)+    getPendingInfo node = case runTreeStatus (runNodeCommon node) of+      Done {statusResult = Failure (Pending {failurePendingMessage})} ->+        let c = runNodeCommon node+        in Just (runTreeLabel c, runTreeId c, failurePendingMessage)+      _ -> Nothing++    formatPendingNode (label, nid, msg) = case msg of+      Just m -> [i|  [#{nid}] #{label}: #{m}|]+      Nothing -> [i|  [#{nid}] #{label}|]++cmdTree :: [RunNode BaseContext] -> IO String+cmdTree rts = do+  fixed <- snapshot rts+  return $ unlines $ concatMap (renderTree 0) fixed++renderTree :: Int -> RunNodeWithStatus context Status (Seq LogEntry) Bool -> [String]+renderTree depth node =+  let c = runNodeCommon node+      indent = replicate (depth * 2) ' '+      statusStr = showStatusBrief (runTreeStatus c)+      label = runTreeLabel c+      nid = runTreeId c+      line = [i|#{indent}[#{statusStr}] [#{nid}] #{label}|]+      children = case node of+        RunNodeIt {} -> []+        RunNodeIntroduce {runNodeChildrenAugmented} -> concatMap (renderTree (depth + 1)) runNodeChildrenAugmented+        RunNodeIntroduceWith {runNodeChildrenAugmented} -> concatMap (renderTree (depth + 1)) runNodeChildrenAugmented+        _ -> concatMap (renderTree (depth + 1)) (runNodeChildren node)+  in line : children++cmdNode :: [RunNode BaseContext] -> Int -> IO String+cmdNode rts nid = do+  fixed <- snapshot rts+  let allCommons = concatMap (extractValues (runNodeCommon)) fixed+      match = [c | c <- allCommons, runTreeId c == nid]+  case match of+    [] -> return [i|Error: no node with id #{nid}|]+    (c:_) -> return $ unlines+      [ [i|id:     #{runTreeId c}|]+      , [i|label:  #{runTreeLabel c}|]+      , [i|status: #{showStatusDetail (runTreeStatus c)}|]+      , [i|folder: #{maybe "(none)" id (runTreeFolder c)}|]+      ]++cmdLogs :: [RunNode BaseContext] -> Int -> IO String+cmdLogs rts nid = do+  fixed <- snapshot rts+  let allNodes = concatMap (extractValues (\n -> (runNodeCommon n))) fixed+      match = [c | c <- allNodes, runTreeId c == nid]+  case match of+    [] -> return [i|Error: no node with id #{nid}|]+    (c:_) -> do+      let logs = runTreeLogs c+      if Seq.null logs+        then return "(no logs)"+        else return $ unlines [showLogEntry e | e <- toList logs]++-- * Formatting helpers++showStatusBrief :: Status -> String+showStatusBrief NotStarted = "NOT STARTED"+showStatusBrief (Running {}) = "RUNNING"+showStatusBrief (Done {statusResult = Success}) = "OK"+showStatusBrief (Done {statusResult = Failure (Pending {})}) = "PENDING"+showStatusBrief (Done {statusResult = Failure _}) = "FAIL"+showStatusBrief (Done {statusResult = DryRun}) = "DRY RUN"+showStatusBrief (Done {statusResult = Cancelled}) = "CANCELLED"++showStatusDetail :: Status -> String+showStatusDetail NotStarted = "not started"+showStatusDetail (Running {statusStartTime}) = [i|running (started #{show statusStartTime})|]+showStatusDetail (Done {statusStartTime, statusEndTime, statusResult}) =+  let elapsed = formatNominalDiffTime (diffUTCTime statusEndTime statusStartTime)+  in [i|#{showResultBrief statusResult} (#{elapsed})|]++showResultBrief :: Result -> String+showResultBrief Success = "succeeded"+showResultBrief (Failure (Pending {})) = "pending"+showResultBrief (Failure _) = "failed"+showResultBrief DryRun = "dry run"+showResultBrief Cancelled = "cancelled"++showFailureReason :: FailureReason -> String+showFailureReason (Reason {failureReason}) = failureReason+showFailureReason (ExpectedButGot {failureValue1, failureValue2}) =+  [i|Expected #{show failureValue1} but got #{show failureValue2}|]+showFailureReason (DidNotExpectButGot {failureValue1}) =+  [i|Did not expect #{show failureValue1}|]+showFailureReason (GotException {failureMessage, failureException}) =+  case failureMessage of+    Just msg -> [i|#{msg}: #{show failureException}|]+    Nothing -> show failureException+showFailureReason (Pending {failurePendingMessage}) =+  maybe "pending" id failurePendingMessage+showFailureReason (GetContextException {failureException}) =+  [i|Context exception: #{show failureException}|]+showFailureReason (GotAsyncException {failureMessage, failureAsyncException}) =+  case failureMessage of+    Just msg -> [i|#{msg}: #{show failureAsyncException}|]+    Nothing -> show failureAsyncException+showFailureReason (ChildrenFailed {failureNumChildren}) =+  [i|#{failureNumChildren} children failed|]+showFailureReason (RawImage {failureFallback}) = failureFallback++showLogEntry :: LogEntry -> String+showLogEntry (LogEntry {logEntryTime, logEntryLevel, logEntryStr}) =+  let levelStr :: String+      levelStr = case logEntryLevel of+        LevelDebug -> "DEBUG"+        LevelInfo -> "INFO"+        LevelWarn -> "WARN"+        LevelError -> "ERROR"+        LevelOther t -> show t+      msgStr = BS8.unpack logEntryStr+  in [i|#{show logEntryTime} [#{levelStr}] #{msgStr}|]

@@ -0,0 +1,150 @@+module Test.Sandwich.Formatters.Socket.Server (+  socketServer+  ) where++import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Logger+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import Data.IORef+import Data.String.Interpolate+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Time+import GHC.Stats+import Network.Socket+import Network.Socket.ByteString (recv, sendAll)+import System.Directory (removeFile)+import Test.Sandwich.Formatters.Socket.Commands+import Test.Sandwich.Instrumentation (formatRtsStats)+import Test.Sandwich.ManagedAsync+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+import UnliftIO.Concurrent (threadDelay)+import UnliftIO.Exception+++-- | Bidirectional Unix socket server. Each client connection reads line-based+-- commands and sends back responses terminated by a line containing just ".".+socketServer :: T.Text -> FilePath -> [RunNode BaseContext] -> TChan (Int, String, LogEntry) -> TChan NodeEvent -> IO ()+socketServer runId socketPath rts logBroadcast eventBroadcast = do+  -- Clean up any existing socket file+  removeFile socketPath `catch` \(_ :: IOError) -> return ()++  bracket (socket AF_UNIX Stream defaultProtocol) close $ \sock -> do+    bind sock (SockAddrUnix socketPath)+    listen sock 5+    forever $ do+      (conn, _) <- accept sock+      void $ managedAsync runId "socket-connection" $ handleConnection conn rts logBroadcast eventBroadcast++handleConnection :: Socket -> [RunNode BaseContext] -> TChan (Int, String, LogEntry) -> TChan NodeEvent -> IO ()+handleConnection conn rts logBroadcast eventBroadcast = do+  bufRef <- newIORef BS.empty+  handle (\(_ :: IOError) -> close conn) $ do+    sendAll conn "Connected to sandwich socket formatter. Type \"help\" for commands.\n\n> "+    forever $ do+      line <- readLine conn bufRef+      now <- getCurrentTime+      let cmd = BS8.unpack (stripCR line)+      case words cmd of+        ["stream-logs"] -> streamLogs conn logBroadcast+        ["stream-events"] -> streamEvents conn eventBroadcast+        ["stream-rts-stats"] -> streamRtsStats conn+        _ -> do+          response <- handleCommand rts now cmd+          unless (null response) $ do+            sendAll conn (BS8.pack response)+            sendAll conn "\n"+          sendAll conn "> "++-- | Stream all log entries to the client until the connection is closed.+-- This is a blocking operation that never returns to the command loop.+streamLogs :: Socket -> TChan (Int, String, LogEntry) -> IO ()+streamLogs conn broadcastChan = do+  sendAll conn "Streaming logs (disconnect to stop)...\n"+  -- Duplicate the broadcast channel to get our own read position+  chan <- atomically $ dupTChan broadcastChan+  handle (\(_ :: IOError) -> return ()) $ forever $ do+    (nodeId, nodeLabel, LogEntry {..}) <- atomically $ readTChan chan+    let levelStr :: String+        levelStr = case logEntryLevel of+          LevelDebug -> "DEBUG"+          LevelInfo -> "INFO"+          LevelWarn -> "WARN"+          LevelError -> "ERROR"+          LevelOther t -> show t+        msgStr = BS8.unpack logEntryStr+        formatted = [i|#{show logEntryTime} [#{levelStr}] [#{nodeId}] #{nodeLabel}: #{msgStr}\n|]+    sendAll conn (BS8.pack formatted)++-- | Stream node lifecycle events (started, done) to the client.+streamEvents :: Socket -> TChan NodeEvent -> IO ()+streamEvents conn broadcastChan = do+  sendAll conn "Streaming events (disconnect to stop)...\n"+  chan <- atomically $ dupTChan broadcastChan+  handle (\(_ :: IOError) -> return ()) $ forever $ do+    NodeEvent {..} <- atomically $ readTChan chan+    let typeStr :: String+        typeStr = case nodeEventType of+          EventStarted -> "STARTED"+          EventDone Success -> "DONE:OK"+          EventDone (Failure (Pending {})) -> "DONE:PENDING"+          EventDone (Failure reason) -> [i|DONE:FAIL: #{showFailureReasonBrief reason}|]+          EventDone DryRun -> "DONE:DRYRUN"+          EventDone Cancelled -> "DONE:CANCELLED"+          EventSetupStarted -> "SETUP:STARTED"+          EventSetupFinished -> "SETUP:FINISHED"+          EventTeardownStarted -> "TEARDOWN:STARTED"+          EventTeardownFinished -> "TEARDOWN:FINISHED"+          EventMilestone msg -> [i|MILESTONE: #{msg}|]+          EventEndOfStream -> "END_OF_STREAM"+        formatted = [i|#{show nodeEventTime} [#{nodeEventId}] #{nodeEventLabel}: #{typeStr}\n|]+    sendAll conn (BS8.pack formatted)++showFailureReasonBrief :: FailureReason -> String+showFailureReasonBrief (Reason {failureReason}) = failureReason+showFailureReasonBrief (ChildrenFailed {failureNumChildren}) = [i|#{failureNumChildren} children failed|]+showFailureReasonBrief _ = "(see node detail)"++-- | Stream RTS stats to the client every second until the connection is closed.+-- Requires the program to be run with +RTS -T for stats to be available.+streamRtsStats :: Socket -> IO ()+streamRtsStats conn = do+  enabled <- getRTSStatsEnabled+  if not enabled+    then sendAll conn "RTS stats not available. Run with +RTS -T to enable.\n> "+    else do+      sendAll conn "Streaming RTS stats every 1s (disconnect to stop)...\n"+      handle (\(_ :: IOError) -> return ()) $ forever $ do+        stats <- getRTSStats+        let gc' = gc stats+        now <- getCurrentTime+        let line = formatRtsStats now stats gc'+        sendAll conn "\n\n"+        sendAll conn (T.encodeUtf8 line)+        threadDelay 1_000_000++-- | Read a single line from the socket, buffering leftover bytes.+-- Returns the line without the trailing newline.+readLine :: Socket -> IORef BS.ByteString -> IO BS.ByteString+readLine conn bufRef = do+  buf <- readIORef bufRef+  case BS8.elemIndex '\n' buf of+    Just idx -> do+      let (line, rest) = BS.splitAt idx buf+      writeIORef bufRef (BS.drop 1 rest) -- skip the '\n'+      return line+    Nothing -> do+      chunk <- recv conn 4096+      when (BS.null chunk) $ throwIO (userError "connection closed")+      writeIORef bufRef (buf <> chunk)+      readLine conn bufRef++-- | Strip trailing carriage return (for clients that send \r\n)+stripCR :: BS.ByteString -> BS.ByteString+stripCR bs+  | BS.null bs = bs+  | BS8.last bs == '\r' = BS.init bs+  | otherwise = bs

@@ -16,6 +16,7 @@   , terminalUIDefaultEditor   , terminalUIOpenInEditor   , terminalUICustomExceptionFormatters+  , terminalUIDebugSocket    -- * Auxiliary types   , InitialFolding(..)@@ -29,13 +30,13 @@ import Brick.BChan import Brick.Widgets.List import Control.Concurrent-import Control.Concurrent.Async import Control.Concurrent.STM import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger hiding (logError) import Control.Monad.Trans import Control.Monad.Trans.State hiding (get, put)+import qualified Data.ByteString.Char8 as BS8 import Data.Either import Data.Foldable import qualified Data.List as L@@ -43,6 +44,7 @@ import qualified Data.Sequence as Seq import qualified Data.Set as S import Data.String.Interpolate+import Data.Text (Text) import Data.Time import qualified Data.Vector as Vec import GHC.Stack@@ -53,6 +55,7 @@ import System.FilePath import Test.Sandwich.Formatters.TerminalUI.AttrMap import Test.Sandwich.Formatters.TerminalUI.CrossPlatform+import Test.Sandwich.Formatters.TerminalUI.DebugSocket import Test.Sandwich.Formatters.TerminalUI.Draw import Test.Sandwich.Formatters.TerminalUI.Filter import Test.Sandwich.Formatters.TerminalUI.Keys@@ -60,12 +63,14 @@ import Test.Sandwich.Interpreters.RunTree.Util import Test.Sandwich.Interpreters.StartTree import Test.Sandwich.Logging+import Test.Sandwich.ManagedAsync import Test.Sandwich.RunTree import Test.Sandwich.Shutdown import Test.Sandwich.Types.ArgParsing import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec import Test.Sandwich.Util+import UnliftIO.Async (cancel) import UnliftIO.Exception  @@ -85,6 +90,13 @@    (rtsFixed, initialSomethingRunning) <- liftIO $ atomically $ runStateT (mapM fixRunTree' rts) False +  -- Create debug channel for optional debug socket server+  debugChan <- liftIO $ newBroadcastTChanIO+  let debugFn :: Text -> IO ()+      debugFn msg = do+        now <- getCurrentTime+        atomically $ writeTChan debugChan (BS8.pack [i|#{formatTime defaultTimeLocale "%H:%M:%S%3Q" now} #{msg}\n|])+   let initialState = updateFilteredTree $         AppState {           _appRunTreeBase = rts@@ -96,16 +108,17 @@           , _appCurrentTime = startTime           , _appSomethingRunning = initialSomethingRunning -          , _appVisibilityThresholdSteps = L.sort $ L.nub $ terminalUIVisibilityThreshold : (fmap runTreeVisibilityLevel $ concatMap getCommons rts)+          , _appVisibilityThresholdSteps = L.sort $ L.nub $ terminalUIVisibilityThreshold : fmap runTreeVisibilityLevel (concatMap getCommons rts)           , _appVisibilityThreshold = terminalUIVisibilityThreshold            , _appLogLevel = terminalUILogLevel           , _appShowRunTimes = terminalUIShowRunTimes           , _appShowFileLocations = terminalUIShowFileLocations           , _appShowVisibilityThresholds = terminalUIShowVisibilityThresholds+          , _appShowLogSizes = terminalUIShowLogSizes -          , _appOpenInEditor = terminalUIOpenInEditor terminalUIDefaultEditor (const $ return ())-          , _appDebug = (const $ return ())+          , _appOpenInEditor = terminalUIOpenInEditor terminalUIDefaultEditor debugFn+          , _appDebug = debugFn           , _appCustomExceptionFormatters = terminalUICustomExceptionFormatters         } @@ -114,17 +127,19 @@   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, somethingRunning) <- atomically $ flip runStateT False $ do-          currentFixed <- lift $ readTVar currentFixedTree-          newFixed <- mapM fixRunTree' rts-          when (fmap getCommons newFixed == fmap getCommons currentFixed) (lift retry)-          lift $ writeTVar currentFixedTree newFixed-          return newFixed-        writeBChan eventChan (RunTreeUpdated newFixedTree somethingRunning)-        threadDelay terminalUIRefreshPeriod+  let eventAsync = liftIO $ forever $ do+        handleAny (\e -> flip runLoggingT logFn (logError [i|Got exception in event async: #{e}|]) >> threadDelay terminalUIRefreshPeriod) $ do+          debugFn "eventAsync: waiting for tree change"+          (newFixedTree, somethingRunning) <- atomically $ flip runStateT False $ do+            currentFixed <- lift $ readTVar currentFixedTree+            newFixed <- mapM fixRunTree' rts+            when (fmap getCommons newFixed == fmap getCommons currentFixed) (lift retry)+            lift $ writeTVar currentFixedTree newFixed+            return newFixed+          let nodeCount = length $ concatMap getCommons newFixedTree+          debugFn [i|eventAsync: tree changed, nodes=#{nodeCount} somethingRunning=#{somethingRunning}|]+          writeBChan eventChan (RunTreeUpdated newFixedTree somethingRunning)+          threadDelay terminalUIRefreshPeriod    let buildVty = do         v <- V.mkVty V.defaultConfig@@ -136,13 +151,21 @@    let updateCurrentTimeForever period = forever $ do         now <- getCurrentTime+        debugFn "CurrentTimeUpdated tick"         writeBChan eventChan (CurrentTimeUpdated now)         threadDelay period +  -- Optionally start the debug socket server in the test tree root+  let runId = baseContextRunId baseContext+  let withDebugSocket = case (terminalUIDebugSocket, baseContextRunRoot baseContext) of+        (True, Just runRoot) -> \action -> managedWithAsync_ runId "tui-debug-socket" (debugSocketServer runId (runRoot </> "tui-debug.sock") debugChan) action+        _ -> id+   liftIO $-    (case terminalUIClockUpdatePeriod of Nothing -> id; Just ts -> \action -> withAsync (updateCurrentTimeForever ts) (\_ -> action)) $-      flip onException (cancel eventAsync) $-        void $ customMain initialVty buildVty (Just eventChan) app initialState+    withDebugSocket $+    (case terminalUIClockUpdatePeriod of Nothing -> id; Just ts -> \action -> managedWithAsync_ runId "tui-clock-update" (updateCurrentTimeForever ts) action) $+    managedWithAsync_ runId "tui-event-async" eventAsync $+    void $ customMain initialVty buildVty (Just eventChan) app initialState  app :: App AppState AppEvent ClickableName app = App {@@ -188,9 +211,7 @@     & appSomethingRunning .~ somethingRunning     & updateFilteredTree appEvent s (AppEvent (CurrentTimeUpdated ts)) = do-  continue $ case (s ^. appSomethingRunning) of-    True -> s & appCurrentTime .~ ts-    False -> s+  continue $ s & appCurrentTime .~ ts  appEvent s (MouseDown ColorBar _ _ (B.Location (x, _))) = do   lookupExtent ColorBar >>= \case@@ -271,9 +292,10 @@           _ -> return ()     V.EvKey c [] | c == runAllKey -> do       now <- liftIO getCurrentTime+      let appRunId = baseContextRunId (s ^. appBaseContext)       when (all (not . isRunning . runTreeStatus . runNodeCommon) (s ^. appRunTree)) $ liftIO $ do         mapM_ clearRecursively (s ^. appRunTreeBase)-        void $ async $ void $ runNodesSequentially (s ^. appRunTreeBase) (s ^. appBaseContext)+        void $ managedAsync appRunId "tui-run-all" $ void $ runNodesSequentially (s ^. appRunTreeBase) (s ^. appBaseContext)       continue $ s         & appStartTime .~ now         & appCurrentTime .~ now@@ -283,6 +305,7 @@         _ -> do           -- Get the set of IDs for only this node's ancestors and children           let ancestorIds = S.fromList $ toList $ runTreeAncestors node+          let appRunId = baseContextRunId (s ^. appBaseContext)           case findRunNodeChildrenById ident (s ^. appRunTree) of             Nothing -> continue s             Just childIds -> do@@ -292,7 +315,7 @@               -- Start a run for all affected nodes               now <- liftIO getCurrentTime               let bc = (s ^. appBaseContext) { baseContextOnlyRunIds = Just allIds }-              void $ liftIO $ async $ void $ runNodesSequentially (s ^. appRunTreeBase) bc+              void $ liftIO $ managedAsync appRunId "tui-run-selected" $ void $ runNodesSequentially (s ^. appRunTreeBase) bc               continue $ s                 & appStartTime .~ now                 & appCurrentTime .~ now@@ -347,6 +370,8 @@       & appShowFileLocations %~ not     V.EvKey c [] | c == toggleVisibilityThresholdsKey -> continue $ s       & appShowVisibilityThresholds %~ not+    V.EvKey c [] | c == toggleShowLogSizesKey -> continue $ s+      & appShowLogSizes %~ not     V.EvKey c [] | c `elem` [V.KEsc, exitKey] -> do       -- Cancel everything and wait for cleanups       liftIO $ mapM_ cancelNode (s ^. appRunTreeBase)@@ -374,37 +399,37 @@ modifyToggled s f = case listSelectedElement (s ^. appMainList) of   Nothing -> continue s   Just (_i, MainListElem {..}) -> do-    liftIO $ atomically $ modifyTVar (runTreeToggled node) f+    liftIO $ atomically $ modifyTVar' (runTreeToggled node) f     continue s  modifyOpen :: AppState -> (Bool -> Bool) -> EventM ClickableName AppState () modifyOpen s f = case listSelectedElement (s ^. appMainList) of   Nothing -> continue s   Just (_i, MainListElem {..}) -> do-    liftIO $ atomically $ modifyTVar (runTreeOpen node) f+    liftIO $ atomically $ modifyTVar' (runTreeOpen node) f     continue s  openIndices :: [RunNode context] -> Seq.Seq Int -> IO () openIndices nodes openSet =   atomically $ forM_ (concatMap getCommons nodes) $ \node ->     when ((runTreeId node) `elem` (toList openSet)) $-      modifyTVar (runTreeOpen node) (const True)+      modifyTVar' (runTreeOpen node) (const True)  openToDepth :: (Foldable t) => t MainListElem -> Int -> IO () openToDepth elems thresh =   atomically $ forM_ elems $ \(MainListElem {..}) ->-    if | (depth < thresh) -> modifyTVar (runTreeOpen node) (const True)-       | otherwise -> modifyTVar (runTreeOpen node) (const False)+    if | (depth < thresh) -> modifyTVar' (runTreeOpen node) (const True)+       | otherwise -> modifyTVar' (runTreeOpen node) (const False)  setInitialFolding :: InitialFolding -> [RunNode BaseContext] -> IO () setInitialFolding InitialFoldingAllOpen _rts = return () setInitialFolding InitialFoldingAllClosed rts =   atomically $ forM_ (concatMap getCommons rts) $ \(RunNodeCommonWithStatus {..}) ->-    modifyTVar runTreeOpen (const False)+    modifyTVar' runTreeOpen (const False) setInitialFolding (InitialFoldingTopNOpen n) rts =   atomically $ forM_ (concatMap getCommons rts) $ \(RunNodeCommonWithStatus {..}) ->     when (Seq.length runTreeAncestors > n) $-      modifyTVar runTreeOpen (const False)+      modifyTVar' runTreeOpen (const False)  updateFilteredTree :: AppState -> AppState updateFilteredTree s = s

@@ -49,6 +49,7 @@   , (logLineAttr, fg solarizedCyan)   , (logChAttr, fg solarizedOrange)   , (logFunctionAttr, fg solarizedMagenta)+  , (logSizeAttr, fg midWhite)    -- Progress bar   , (progressCompleteAttr, bg (V.Color240 235))@@ -158,6 +159,8 @@ logLineAttr = mkAttrName "logLine" logChAttr = mkAttrName "logCh" logFunctionAttr = mkAttrName "logFunction"++logSizeAttr = mkAttrName "logSize"  -- * Exceptions and pretty printing 

@@ -0,0 +1,37 @@+module Test.Sandwich.Formatters.TerminalUI.DebugSocket (+  debugSocketServer+  ) where++import Control.Concurrent.STM+import Control.Monad+import Data.ByteString (ByteString)+import qualified Data.Text as T+import Network.Socket+import Network.Socket.ByteString (sendAll)+import System.Directory (removeFile)+import Test.Sandwich.ManagedAsync+import UnliftIO.Exception+++-- | Debug socket server that accepts connections and broadcasts events.+-- Connect with @nc -U \<path\>@ to receive line-oriented debug events.+debugSocketServer :: T.Text -> FilePath -> TChan ByteString -> IO ()+debugSocketServer runId socketPath chan = do+  -- Clean up any existing socket file+  removeFile socketPath `catch` \(_ :: IOError) -> return ()++  bracket (socket AF_UNIX Stream defaultProtocol) close $ \sock -> do+    bind sock (SockAddrUnix socketPath)+    listen sock 5+    forever $ do+      (conn, _) <- accept sock+      -- Spawn a thread to handle this connection+      void $ managedAsync runId "tui-debug-connection" $ handleConnection conn+  where+    handleConnection conn = do+      -- Duplicate the channel so this client gets its own read position+      chan' <- atomically $ dupTChan chan+      -- Send events until error (client disconnect)+      handle (\(_ :: IOError) -> close conn) $ forever $ do+        msg <- atomically $ readTChan chan'+        sendAll conn msg

@@ -10,6 +10,7 @@ import Control.Monad import Control.Monad.Logger import Control.Monad.Reader+import qualified Data.ByteString as BS import Data.Foldable import qualified Data.List as L import Data.Maybe@@ -19,6 +20,7 @@ import Data.Time.Clock import GHC.Stack import Lens.Micro hiding (ix)+import Numeric (showFFloat) import Safe import Test.Sandwich.Formatters.Common.Count import Test.Sandwich.Formatters.Common.Util@@ -74,6 +76,9 @@                       , withAttr visibilityThresholdIndicatorMutedAttr $ str "V="                       , withAttr visibilityThresholdIndicatorAttr $ str $ show visibilityLevel                       , str "]"]+      , if not (app ^. appShowLogSizes) then Nothing else+          let totalSize = sum $ fmap (BS.length . logEntryStr) logs+          in if totalSize > 0 then Just $ hBox [str " [", withAttr logSizeAttr (str $ formatBytes totalSize), str "]"] else Nothing       , Just $ padRight Max $ withAttr toggleMarkerAttr $ str (if toggled then " [-]" else " [+]")       , if not (app ^. appShowRunTimes) then Nothing else case status of           Running {..} -> Just $ getRunTimes app statusStartTime statusSetupFinishTime statusTeardownStartTime (app ^. appCurrentTime) True@@ -102,7 +107,7 @@       , str " "       , logLocWidget logEntryLoc       , str " "-      , txtWrap (E.decodeUtf8 $ fromLogStr logEntryStr)+      , txtWrap (E.decodeUtf8 logEntryStr)       ]      logLocWidget (Loc {loc_start=(line, ch), ..}) = hBox [@@ -151,3 +156,13 @@     _ -> failureCallStack reason getCallStackFromStatus _ (Done {statusResult=(Failure reason)}) = failureCallStack reason getCallStackFromStatus _ _ = Nothing++formatBytes :: Int -> String+formatBytes bytes+  | bytes < 1024 = show bytes <> " B"+  | bytes < 1024 * 1024 = [i|#{formatDecimal (fromIntegral bytes / 1024 :: Double) 1} KB|]+  | bytes < 1024 * 1024 * 1024 = [i|#{formatDecimal (fromIntegral bytes / (1024 * 1024) :: Double) 1} MB|]+  | otherwise = [i|#{formatDecimal (fromIntegral bytes / (1024 * 1024 * 1024) :: Double) 1} GB|]+  where+    formatDecimal :: Double -> Int -> String+    formatDecimal x decimals = showFFloat (Just decimals) x ""

@@ -96,12 +96,16 @@                                               , str $ showKey toggleFileLocationsKey                                               , str "/"                                               , str $ showKey toggleVisibilityThresholdsKey+                                              , str "/"+                                              , str $ showKey toggleShowLogSizesKey                                               , str "] "                                               , highlightMessageIfPredicate (^. appShowRunTimes) app (str "Times")                                               , str "/"                                               , highlightMessageIfPredicate (^. appShowFileLocations) app (str "locations")                                               , str "/"                                               , highlightMessageIfPredicate (^. appShowVisibilityThresholds) app (str "thresholds")+                                              , str "/"+                                              , highlightMessageIfPredicate (^. appShowLogSizes) app (str "log sizes")                                          ]                                        , hBox [str "["                                               , highlightIfLogLevel app LevelDebug [unKChar debugKey]

@@ -27,8 +27,13 @@      if imageHeight (image result) <= maxHeight       then return result-      -- Otherwise put the contents (pre-rendered) in a viewport-      -- and limit the height to the maximum allowable height.+      -- Otherwise put the contents in a viewport and limit the height to the+      -- maximum allowable height. Show a scroll bar on the right so it's clear+      -- the content is scrollable. Re-render the content slightly narrower than+      -- the available width so its right border is drawn just left of the+      -- scroll bar, which occupies the viewport's rightmost column, rather than+      -- underneath it.       else render (vLimit maxHeight $+                   withVScrollBars OnRight $                    viewport vpName Vertical $-                   Widget Fixed Fixed $ return result)+                   hLimit (ctx ^. availWidthL - 2) w)

@@ -32,6 +32,7 @@ toggleShowRunTimesKey = V.KChar 'T' toggleFileLocationsKey = V.KChar 'F' toggleVisibilityThresholdsKey = V.KChar 'V'+toggleShowLogSizesKey = V.KChar 'L' debugKey = V.KChar 'd' infoKey = V.KChar 'i' warnKey = V.KChar 'w'

@@ -29,6 +29,8 @@   -- ^ Whether to show or hide the files in which tests are defined.   , terminalUIShowVisibilityThresholds :: Bool   -- ^ Whether to show or hide visibility thresholds next to nodes.+  , terminalUIShowLogSizes :: Bool+  -- ^ Whether to show or hide log sizes in bytes next to nodes.   , terminalUILogLevel :: Maybe LogLevel   -- ^ Log level for test log displays.   , terminalUIRefreshPeriod :: Int@@ -53,6 +55,9 @@   -- It's also passed a debug callback that accepts a 'T.Text'; messages logged with this function will go into the formatter logs.   , terminalUICustomExceptionFormatters :: CustomExceptionFormatters   -- ^ Custom exception formatters, used to nicely format custom exception types.+  , terminalUIDebugSocket :: Bool+  -- ^ If True, create a Unix socket at @\<test-root\>/tui-debug.sock@ for debug output.+  -- Connect with @nc -U \<path\>@ to receive line-oriented debug events about the TUI event loop.   }  instance Show TerminalUIFormatter where@@ -72,12 +77,14 @@   , terminalUIShowRunTimes = True   , terminalUIShowFileLocations = False   , terminalUIShowVisibilityThresholds = False+  , terminalUIShowLogSizes = False   , terminalUILogLevel = Just LevelWarn   , terminalUIRefreshPeriod = 100000   , terminalUIClockUpdatePeriod = Just 1000000   , terminalUIDefaultEditor = Just "emacsclient +$((LINE+1)):COLUMN --no-wait"   , terminalUIOpenInEditor = autoOpenInEditor   , terminalUICustomExceptionFormatters = []+  , terminalUIDebugSocket = False   }  type CustomExceptionFormatters = [SomeException -> Maybe CustomTUIException]@@ -131,6 +138,7 @@   , _appShowRunTimes :: Bool   , _appShowFileLocations :: Bool   , _appShowVisibilityThresholds :: Bool+  , _appShowLogSizes :: Bool    , _appOpenInEditor :: SrcLoc -> IO ()   , _appDebug :: T.Text -> IO ()

@@ -0,0 +1,188 @@+module Test.Sandwich.Instrumentation (+  streamLogsToFile+  , streamEventsToFile+  , streamRtsStatsToFile+  , streamManagedAsyncEventsToFile+  , writeTreeFile++  , formatRtsStats+  ) where++import Control.Concurrent.STM+import Control.Monad+import Control.Monad.Logger+import qualified Data.ByteString.Char8 as BS8+import Data.IORef+import qualified Data.Map.Strict as M+import Data.String.Interpolate+import Data.Text (Text)+import qualified Data.Text.IO as T+import Data.Time+import Data.Word+import Debug.Trace (traceMarkerIO)+import GHC.Stats+import System.IO (IOMode(..), hFlush, hPutStr, hSetBuffering, BufferMode(..), withFile)+import Test.Sandwich.ManagedAsync (AsyncEvent(..), AsyncInfo(..), getManagedAsyncInfos)+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+import UnliftIO.Concurrent (threadDelay)+import UnliftIO.Exception+++-- | Stream all log entries from a broadcast channel to a file,+-- including the recursive heap size of each LogEntry.+-- When cancelled, writes a summary line with total bytes.+streamLogsToFile :: FilePath -> TChan (Int, String, LogEntry) -> IO ()+streamLogsToFile path broadcastChan = do+  chan <- atomically $ dupTChan broadcastChan+  totalRef <- newIORef (0 :: Word64)+  countRef <- newIORef (0 :: Int)+  withFile path AppendMode $ \h -> do+    hSetBuffering h LineBuffering+    let loop = forever $ do+          (nodeId, nodeLabel, LogEntry {..}) <- atomically $ readTChan chan+          let entrySize = fromIntegral (BS8.length logEntryStr) :: Word64+          modifyIORef' totalRef (+ entrySize)+          modifyIORef' countRef (+ 1)+          let levelStr :: String+              levelStr = case logEntryLevel of+                LevelDebug -> "DEBUG"+                LevelInfo -> "INFO"+                LevelWarn -> "WARN"+                LevelError -> "ERROR"+                LevelOther t -> show t+              msgStr = BS8.unpack logEntryStr+              formatted = [i|#{show logEntryTime} [#{levelStr}] [#{nodeId}] #{nodeLabel}: #{msgStr} (#{entrySize} bytes)\n|]+          hPutStr h formatted+          hFlush h+    loop `finally` do+      total <- readIORef totalRef+      count <- readIORef countRef+      hPutStr h [i|\nTotal: #{count} log entries, #{formatBytes total} total log bytes\n|]+      hFlush h++-- | Stream node lifecycle events from a broadcast channel to a file.+-- Exits cleanly when it receives an 'EventEndOfStream' event.+streamEventsToFile :: FilePath -> TChan NodeEvent -> IO ()+streamEventsToFile path broadcastChan = do+  chan <- atomically $ dupTChan broadcastChan+  withFile path AppendMode $ \h -> do+    hSetBuffering h LineBuffering+    let loop = do+          NodeEvent {..} <- atomically $ readTChan chan+          case nodeEventType of+            EventEndOfStream -> do+              hPutStr h [i|#{show nodeEventTime} [#{nodeEventId}] #{nodeEventLabel}: END_OF_STREAM\n|]+              hFlush h+            _ -> do+              traceMarkerIO [i|[#{nodeEventId}] #{nodeEventLabel}: #{typeStr nodeEventType}|]+              hPutStr h [i|#{show nodeEventTime} [#{nodeEventId}] #{nodeEventLabel}: #{typeStr nodeEventType}\n|]+              hFlush h+              loop+    loop+  where+    typeStr :: NodeEventType -> String+    typeStr typ = case typ of+      EventStarted -> "STARTED"+      EventDone Success -> "DONE:OK"+      EventDone (Failure (Pending {})) -> "DONE:PENDING"+      EventDone (Failure reason) -> [i|DONE:FAIL: #{showFailureReasonBrief reason}|]+      EventDone DryRun -> "DONE:DRYRUN"+      EventDone Cancelled -> "DONE:CANCELLED"+      EventSetupStarted -> "SETUP:STARTED"+      EventSetupFinished -> "SETUP:FINISHED"+      EventTeardownStarted -> "TEARDOWN:STARTED"+      EventTeardownFinished -> "TEARDOWN:FINISHED"+      EventMilestone msg -> [i|MILESTONE: #{msg}|]+      EventEndOfStream -> "END_OF_STREAM" -- unreachable, handled above++-- | Poll RTS stats every second and append to a file.+-- Requires the program to be run with +RTS -T for stats to be available.+streamRtsStatsToFile :: FilePath -> IO ()+streamRtsStatsToFile path = do+  enabled <- getRTSStatsEnabled+  when enabled $ do+    withFile path AppendMode $ \h -> do+      hSetBuffering h LineBuffering+      forever $ do+        now <- getCurrentTime+        stats <- getRTSStats+        let gc' = gc stats+        T.hPutStr h "\n\n"+        T.hPutStr h $ formatRtsStats now stats gc'+        hFlush h+        threadDelay 1000000++showFailureReasonBrief :: FailureReason -> String+showFailureReasonBrief (Reason {failureReason}) = failureReason+showFailureReasonBrief (ChildrenFailed {failureNumChildren}) = [i|#{failureNumChildren} children failed|]+showFailureReasonBrief _ = "(see node detail)"++formatRtsStats :: UTCTime -> RTSStats -> GCDetails -> Text+formatRtsStats now stats gc' = [__i|+  #{now}+  live_bytes:         #{formatBytes (gcdetails_live_bytes gc')}+  heap_size:          #{formatBytes (gcdetails_mem_in_use_bytes gc')}+  allocated_bytes:    #{formatBytes (allocated_bytes stats)}+  max_live_bytes:     #{formatBytes (max_live_bytes stats)}+  large_objects:      #{formatBytes (gcdetails_large_objects_bytes gc')}+  compact_bytes:      #{formatBytes (gcdetails_compact_bytes gc')}+  slop_bytes:         #{formatBytes (gcdetails_slop_bytes gc')}+  gcs:                #{gcs stats}+  major_gcs:          #{major_gcs stats}+  gc_cpu:             #{nsToMs (gc_cpu_ns stats)}ms+  mutator_cpu:        #{nsToMs (mutator_cpu_ns stats)}ms+  |]+  where+    nsToMs :: RtsTime -> RtsTime+    nsToMs ns = ns `div` 1000000++formatBytes :: Word64 -> String+formatBytes b+  | b < 1024 = [i|#{b} B|]+  | b < 1024 * 1024 = [i|#{b `div` 1024} KiB (#{b})|]+  | b < 1024 * 1024 * 1024 = [i|#{b `div` (1024 * 1024)} MiB (#{b})|]+  | otherwise = [i|#{b `div` (1024 * 1024 * 1024)} GiB (#{b})|]++-- | Stream managed async lifecycle events (started/finished) from a broadcast channel to a file.+-- When cancelled, writes a summary of all asyncs still alive at that point.+streamManagedAsyncEventsToFile :: FilePath -> TChan AsyncEvent -> IO ()+streamManagedAsyncEventsToFile path broadcastChan = do+  chan <- atomically $ dupTChan broadcastChan+  withFile path AppendMode $ \h -> do+    hSetBuffering h LineBuffering+    let loop = forever $ do+          event <- atomically $ readTChan chan+          now <- getCurrentTime+          let line :: String+              line = case event of+                AsyncStarted info -> [i|#{show now} STARTED (#{asyncInfoThreadId info}, parent #{asyncInfoParentThreadId info}, #{asyncInfoRunId info}) "#{asyncInfoName info}" |]+                AsyncFinished info -> [i|#{show now} FINISHED (#{asyncInfoThreadId info}, #{asyncInfoRunId info}) "#{asyncInfoName info}"|]+          hPutStr h (line <> "\n")+          hFlush h+    loop `finally` do+      now <- getCurrentTime+      remaining <- getManagedAsyncInfos+      hPutStr h [i|\n#{show now} === Remaining managed asyncs: #{M.size remaining} ===\n|]+      forM_ (M.toList remaining) $ \(tid, info) ->+        hPutStr h [i|  #{tid}: #{asyncInfoName info} (runId: #{asyncInfoRunId info})\n|]+      hFlush h++-- | Write a tree of node IDs and labels to a file for cross-referencing with events.+writeTreeFile :: FilePath -> [RunNodeWithStatus context s l t] -> IO ()+writeTreeFile path rts =+  writeFile path $ unlines $ concatMap (renderTree 0) rts++renderTree :: Int -> RunNodeWithStatus context s l t -> [String]+renderTree depth node = line : children+  where+    c = runNodeCommon node+    indent = replicate (depth * 2) ' '+    label = runTreeLabel c+    nid = runTreeId c+    line = [i|#{indent}[#{nid}] #{label}|]+    children = case node of+      RunNodeIt {} -> []+      RunNodeIntroduce {runNodeChildrenAugmented} -> concatMap (renderTree (depth + 1)) runNodeChildrenAugmented+      RunNodeIntroduceWith {runNodeChildrenAugmented} -> concatMap (renderTree (depth + 1)) runNodeChildrenAugmented+      _ -> concatMap (renderTree (depth + 1)) (runNodeChildren node)

@@ -1,9 +1,9 @@+{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-}  module Test.Sandwich.Internal.Running where -import Control.Concurrent.Async import Control.Concurrent.STM import Control.Monad import Control.Monad.Free@@ -22,6 +22,7 @@ import Test.Sandwich.Interpreters.RunTree import Test.Sandwich.Interpreters.RunTree.Util import Test.Sandwich.Interpreters.StartTree+import Test.Sandwich.ManagedAsync import Test.Sandwich.Options import Test.Sandwich.TestTimer import Test.Sandwich.Types.General@@ -38,13 +39,14 @@  startSandwichTree' :: BaseContext -> Options -> CoreSpec -> IO [RunNode BaseContext] startSandwichTree' baseContext (Options {optionsPruneTree=(unwrapTreeFilter -> pruneOpts), optionsFilterTree=(unwrapTreeFilter -> filterOpts), optionsDryRun}) spec = do+  let runId = baseContextRunId baseContext   runTree <- spec     & (\tree -> L.foldl' pruneTree tree pruneOpts)     & (\tree -> L.foldl' filterTree tree filterOpts)     & atomically . specToRunTreeVariable baseContext    if | optionsDryRun -> markAllChildrenWithResult runTree baseContext DryRun-     | otherwise -> void $ async $ void $ runNodesSequentially runTree baseContext+     | otherwise -> void $ managedAsync runId [i|root-nodes:#{runId}|] $ void $ runNodesSequentially runTree baseContext    return runTree @@ -58,20 +60,22 @@   return rts  -- | For 0 repeats, repeat until a failure-runWithRepeat :: Int -> Int -> IO (ExitReason, Int, Int) -> IO ()-runWithRepeat 0 totalTests action = do-  (_, _itNodeFailures, totalFailures) <- action-  if | totalFailures == 0 -> runWithRepeat 0 totalTests action-     | otherwise -> exitFailure+runWithRepeat :: Int -> Int -> (Int -> IO (ExitReason, Int, Int)) -> IO ()+runWithRepeat 0 _totalTests action = go 0+  where+    go !idx = do+      (_, _itNodeFailures, totalFailures) <- action idx+      if | totalFailures == 0 -> go (idx + 1)+         | otherwise -> exitFailure -- | For 1 repeat, run once and return runWithRepeat n totalTests action = do-  (successes, total) <- (flip execStateT (0 :: Int, 0 :: Int)) $ flip fix (n - 1) $ \loop n' -> do-    (exitReason, _itNodeFailures, totalFailures) <- liftIO action+  (successes, total) <- (flip execStateT (0 :: Int, 0 :: Int)) $ flip fix (0 :: Int) $ \loop idx -> do+    (exitReason, _itNodeFailures, totalFailures) <- liftIO $ action idx      modify $ \(successes, total) -> (successes + (if totalFailures == 0 then 1 else 0), total + 1)      if | exitReason == SignalExit -> return ()-       | n' > 0 -> loop (n' - 1)+       | idx < n - 1 -> loop (idx + 1)        | otherwise -> return ()    putStrLn [i|#{successes} runs succeeded out of #{total} repeat#{if n > 1 then ("s" :: String) else ""} (#{totalTests} tests)|]@@ -80,6 +84,7 @@  baseContextFromOptions :: Options -> IO BaseContext baseContextFromOptions options@(Options {..}) = do+  let runId = optionsRunId   runRoot <- case optionsTestArtifactsDirectory of     TestArtifactsNone -> return Nothing     TestArtifactsFixedDirectory dir' -> do@@ -117,6 +122,7 @@     , baseContextOnlyRunIds = Nothing     , baseContextTestTimerProfile = defaultProfileName     , baseContextTestTimer = testTimer+    , baseContextRunId = runId     }  @@ -142,6 +148,7 @@   , "repeat"   , "fixed-root"   , "list-tests"+  , "list-tests-json"    , "print-golden-flags"   , "print-hedgehog-flags"

@@ -1,3 +1,4 @@+{-# LANGUAGE BangPatterns #-}  module Test.Sandwich.Interpreters.RunTree.Logging (   logToMemory@@ -15,24 +16,34 @@ import System.IO import Test.Sandwich.Types.RunTree + logToMemory :: Maybe LogLevel -> TVar (Seq LogEntry) -> Loc -> LogSource -> LogLevel -> LogStr -> IO () logToMemory Nothing _ _ _ _ _ = return () logToMemory (Just minLevel) logs loc logSrc logLevel logStr =   when (logLevel >= minLevel) $ do     ts <- getCurrentTime-    atomically $ modifyTVar logs (|> LogEntry ts loc logSrc logLevel logStr)+    let !bs = fromLogStr logStr+    let !entry = LogEntry ts loc logSrc logLevel bs+    -- atomically $ modifyTVar' logs (\s -> let s' = s |> entry in forceSeq s' `seq` s')+    atomically $ modifyTVar' logs (|> entry)  logToMemoryAndFile :: Maybe LogLevel -> Maybe LogLevel -> LogEntryFormatter -> TVar (Seq LogEntry) -> Handle -> Loc -> LogSource -> LogLevel -> LogStr -> IO () logToMemoryAndFile maybeMemLogLevel maybeSavedLogLevel formatter logs h loc logSrc logLevel logStr = do+  let !bs = fromLogStr logStr   maybeTs <- case maybeMemLogLevel of     Just x | x <= logLevel -> do       ts <- getCurrentTime-      atomically $ modifyTVar logs (|> LogEntry ts loc logSrc logLevel logStr)+      let !entry = LogEntry ts loc logSrc logLevel bs+      -- atomically $ modifyTVar' logs (\s -> let s' = s |> entry in forceSeq s' `seq` s')+      atomically $ modifyTVar' logs (|> entry)       return $ Just ts     _ -> return Nothing    case maybeSavedLogLevel of     Just x | x <= logLevel -> do       ts <- maybe getCurrentTime return maybeTs-      BS8.hPutStr h $ formatter ts loc logSrc logLevel logStr+      BS8.hPutStr h $ formatter ts loc logSrc logLevel bs     _ -> return ()++-- forceSeq :: Seq LogEntry -> Seq LogEntry+-- forceSeq s = foldl' (\_ e -> e `seq` ()) () s `seq` s

@@ -5,11 +5,8 @@  import Control.Concurrent.STM import Control.Monad.Free-import Control.Monad.Logger import qualified Data.List as L-import Data.Sequence as Seq hiding ((:>)) import Data.String.Interpolate-import Data.Time.Clock import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec import Text.Printf@@ -22,13 +19,6 @@     Done {statusResult} -> return statusResult     NotStarted {} -> retry     Running {} -> retry---- | Append a log message outside of ExampleT. Only stored to in-memory logs, not disk.--- Only for debugging the interpreter, should not be exposed.-appendLogMessage :: ToLogStr msg => TVar (Seq LogEntry) -> msg -> IO ()-appendLogMessage logs msg = do-  ts <- getCurrentTime-  atomically $ modifyTVar logs (|> LogEntry ts (Loc "" "" "" (0, 0) (0, 0)) "manual" LevelDebug (toLogStr msg))  -- | Count how many folder children are present as children or siblings of the given node. countImmediateFolderChildren :: Free (SpecCommand context m) a -> Int

@@ -8,23 +8,26 @@   ) where  -import Control.Concurrent.Async import Control.Concurrent.MVar+import qualified Control.Exception as E import Control.Monad import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Logger import Control.Monad.Trans.Reader+import qualified Data.ByteString.Char8 as BS8 import Data.IORef import qualified Data.List as L import Data.Sequence hiding ((:>)) import qualified Data.Set as S import Data.String.Interpolate import qualified Data.Text as T-import Data.Time.Clock+import qualified Data.Text.IO as T+import Data.Time+import Data.Time.Clock.POSIX import Data.Typeable+import GHC.IO (unsafeUnmask) import GHC.Stack-import System.Directory import System.FilePath import System.IO import Test.Sandwich.Formatters.Print@@ -34,12 +37,16 @@ import Test.Sandwich.Formatters.Print.Printing import Test.Sandwich.Interpreters.RunTree.Logging import Test.Sandwich.Interpreters.RunTree.Util+import Test.Sandwich.ManagedAsync import Test.Sandwich.RunTree import Test.Sandwich.TestTimer import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec import Test.Sandwich.Types.TestTimer import Test.Sandwich.Util+import UnliftIO.Async+import UnliftIO.Concurrent (threadDelay)+import UnliftIO.Directory import UnliftIO.Exception import UnliftIO.STM @@ -53,7 +60,8 @@   let RunNodeCommonWithStatus {..} = runNodeCommon   let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon   runInAsync node ctx $ do-    (timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (setup)") (runExampleM runNodeBefore ctx runTreeLogs (Just [i|Exception in before '#{runTreeLabel}' handler|]))) >>= \case+    let label = runTreeLabel <> " (setup)"+    (timed runNodeCommon runTreeRecordTime (getBaseContext ctx) label (runExampleM runNodeCommon label runNodeBefore ctx runTreeLogs (Just [i|Exception in before '#{runTreeLabel}' handler|]))) >>= \case       (result@(Failure fr@(Pending {})), _setupStartTime, setupFinishTime) -> do         markAllChildrenWithResult runNodeChildren ctx (Failure fr)         return (result, mkSetupTimingInfo setupFinishTime)@@ -73,62 +81,76 @@   let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon   runInAsync node ctx $ do     result <- liftIO $ newIORef (Success, emptyExtraTimingInfo)-    finally (void $ runNodesSequentially runNodeChildren ctx)-            (do-                (ret, teardownStartTime, _teardownFinishTime) <- timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (teardown)") $-                  runExampleM runNodeAfter ctx runTreeLogs (Just [i|Exception in after '#{runTreeLabel}' handler|])-                writeIORef result (ret, mkTeardownTimingInfo teardownStartTime)-            )+    -- We use the 'finally' from @base@; see the comment below about 'bracket'+    E.finally (void $ runNodesSequentially runNodeChildren ctx)+              (do+                  let label = runTreeLabel <> " (teardown)"+                  (ret, teardownStartTime, _teardownFinishTime) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) label $+                    runExampleM runNodeCommon label runNodeAfter ctx runTreeLogs (Just [i|Exception in after '#{runTreeLabel}' handler|])+                  writeIORef result (ret, mkTeardownTimingInfo teardownStartTime)+              )     liftIO $ readIORef result startTree node@(RunNodeIntroduce {..}) ctx' = do   let RunNodeCommonWithStatus {..} = runNodeCommon   let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon   runInAsync node ctx $ do     result <- liftIO $ newIORef (Success, emptyExtraTimingInfo)-    bracket (do-                let asyncExceptionResult e = Failure $ GotAsyncException Nothing (Just [i|introduceWith #{runTreeLabel} alloc handler got async exception|]) (SomeAsyncExceptionWithEq e)-                flip withException (\(e :: SomeAsyncException) -> markAllChildrenWithResult runNodeChildrenAugmented ctx (asyncExceptionResult e)) $-                  timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (setup)") $-                    runExampleM' runNodeAlloc ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' allocation handler|])-            )-            (\(ret, setupStartTime, setupFinishTime) -> case ret of-                Left failureReason -> writeIORef result (Failure failureReason, mkSetupTimingInfo setupStartTime)-                Right intro -> do-                  teardownStartTime <- getCurrentTime-                  addTeardownStartTimeToStatus runTreeStatus teardownStartTime-                  (ret', _, _) <- timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (teardown)") $-                    runExampleM (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|])-                  writeIORef result (ret', ExtraTimingInfo (Just setupFinishTime) (Just teardownStartTime))-            )-            (\(ret, _setupStartTime, setupFinishTime) -> do-                addSetupFinishTimeToStatus runTreeStatus setupFinishTime-                case ret of-                  Left failureReason@(Pending {}) -> do-                    -- TODO: add note about failure in allocation-                    markAllChildrenWithResult runNodeChildrenAugmented ctx (Failure failureReason)-                  Left failureReason -> do-                    -- TODO: add note about failure in allocation-                    markAllChildrenWithResult runNodeChildrenAugmented ctx (Failure $ GetContextException Nothing (SomeExceptionWithEq $ toException failureReason))-                  Right intro -> do-                    -- Special hack to modify the test timer profile via an introduce, without needing to track it everywhere.-                    -- It would be better to track the profile at the type level-                    let ctxFinal = case cast intro of-                          Just (TestTimerProfile t) -> modifyBaseContext ctx (\bc -> bc { baseContextTestTimerProfile = t })-                          Nothing -> ctx+    -- The bracket from @base@ uses 'mask', while the one from @unliftio@ uses 'uninterruptibleMask'.+    -- We want to err on the side of avoiding deadlocks so we use the @base@ version.+    -- This also plays nicer with the 'withMaybeWarnOnLongExecution' and 'withMaybeCancelOnLongExecution' functions.+    -- See the discussion at https://github.com/fpco/safe-exceptions/issues/3+    let opts = baseContextOptions (getBaseContext ctx)+    liftIO $ E.bracket+      (do+          let asyncExceptionResult e = Failure $ GotAsyncException Nothing (Just [i|introduce #{runTreeLabel} alloc handler got async exception|]) (SomeAsyncExceptionWithEq e)+          let label = runTreeLabel <> " (setup)"+          getCurrentTime >>= \t -> emitEvent opts t runTreeId runTreeLabel EventSetupStarted+          flip withException (\(e :: SomeAsyncException) -> markAllChildrenWithResult runNodeChildrenAugmented ctx (asyncExceptionResult e)) $ do+            ret <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) label $+              runExampleM' runNodeCommon label runNodeAlloc ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' allocation handler|])+            getCurrentTime >>= \t -> emitEvent opts t runTreeId runTreeLabel EventSetupFinished+            return ret+      )+      (\(ret, setupStartTime, setupFinishTime) -> case ret of+          Left failureReason -> writeIORef result (Failure failureReason, mkSetupTimingInfo setupStartTime)+          Right intro -> do+            teardownStartTime <- getCurrentTime+            addTeardownStartTimeToStatus runTreeStatus teardownStartTime+            emitEvent opts teardownStartTime runTreeId runTreeLabel EventTeardownStarted+            let label = runTreeLabel <> " (teardown)"+            (ret', _, _) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) label $+              runExampleM runNodeCommon label (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|])+            getCurrentTime >>= \t -> emitEvent opts t runTreeId runTreeLabel EventTeardownFinished+            writeIORef result (ret', ExtraTimingInfo (Just setupFinishTime) (Just teardownStartTime))+      )+      (\(ret, _setupStartTime, setupFinishTime) -> do+          addSetupFinishTimeToStatus runTreeStatus setupFinishTime+          case ret of+            Left failureReason@(Pending {}) -> do+              -- TODO: add note about failure in allocation+              markAllChildrenWithResult runNodeChildrenAugmented ctx (Failure failureReason)+            Left failureReason -> do+              -- TODO: add note about failure in allocation+              markAllChildrenWithResult runNodeChildrenAugmented ctx (Failure $ GetContextException Nothing (SomeExceptionWithEq $ toException failureReason))+            Right intro -> do+              -- Special hack to modify the test timer profile via an introduce, without needing to track it everywhere.+              -- It would be better to track the profile at the type level+              let ctxFinal = case cast intro of+                    Just (TestTimerProfile t) -> modifyBaseContext ctx (\bc -> bc { baseContextTestTimerProfile = t })+                    Nothing -> ctx -                    void $ runNodesSequentially runNodeChildrenAugmented ((LabelValue intro) :> ctxFinal)-            )+              void $ runNodesSequentially runNodeChildrenAugmented ((LabelValue intro) :> ctxFinal)+      )     readIORef result startTree node@(RunNodeIntroduceWith {..}) ctx' = do   let RunNodeCommonWithStatus {..} = runNodeCommon   let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon   didRunWrappedAction <- liftIO $ newIORef (Left (), emptyExtraTimingInfo)+  let label = runTreeLabel <> " (body)"   runInAsync node ctx $ do     let wrappedAction = do           didAllocateVar <- liftIO $ newIORef False           let handler e = do-                recordExceptionInStatus runTreeStatus e-                 liftIO (readIORef didAllocateVar) >>= \case                   False -> do                     -- We didn't successfully allocate, so mark the children below this point as failed due to a@@ -150,6 +172,8 @@             -- let teardownLabel = runTreeLabel <> " (teardown)"             -- handleStartEvent tt (baseContextTestTimerProfile (getBaseContext ctx)) (T.pack setupLabel) +            let opts = baseContextOptions (getBaseContext ctx)+            liftIO getCurrentTime >>= \t -> liftIO $ emitEvent opts t runTreeId runTreeLabel EventSetupStarted             results <- runNodeIntroduceAction $ \intro -> do               -- Record the end event in the test timing               -- TODO: do we need to deal with exceptions here and in teardown? I think we we fail to emit the@@ -157,14 +181,16 @@               -- handleEndEvent tt (baseContextTestTimerProfile (getBaseContext ctx)) (T.pack setupLabel)               setupFinishTime <- liftIO getCurrentTime               addSetupFinishTimeToStatus runTreeStatus setupFinishTime+              liftIO $ emitEvent opts setupFinishTime runTreeId runTreeLabel EventSetupFinished                liftIO $ writeIORef didAllocateVar True -              (results, _, _) <- timed runTreeRecordTime (getBaseContext ctx) (runTreeLabel <> " (body)") $+              (results, _, _) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) label $                 liftIO $ runNodesSequentially runNodeChildrenAugmented (LabelValue intro :> ctx)                teardownStartTime <- liftIO getCurrentTime               addTeardownStartTimeToStatus runTreeStatus teardownStartTime+              liftIO $ emitEvent opts teardownStartTime runTreeId runTreeLabel EventTeardownStarted                liftIO $ writeIORef beginningCleanupVar (Just teardownStartTime)               -- handleStartEvent tt (baseContextTestTimerProfile (getBaseContext ctx)) (T.pack teardownLabel)@@ -175,6 +201,7 @@               Nothing -> return ()               Just teardownStartTime -> do                 -- handleEndEvent tt (baseContextTestTimerProfile (getBaseContext ctx)) (T.pack teardownLabel)+                liftIO getCurrentTime >>= \t -> liftIO $ emitEvent opts t runTreeId runTreeLabel EventTeardownFinished                 liftIO $ modifyIORef' didRunWrappedAction $ \(ret, timingInfo) ->                   (ret, timingInfo { teardownStartTime = Just teardownStartTime }) @@ -183,7 +210,7 @@           liftIO (readIORef didRunWrappedAction) >>= \case             (Left (), timingInfo) -> return (Failure $ Reason Nothing [i|introduceWith '#{runTreeLabel}' handler didn't call action|], timingInfo)             (Right _, timingInfo) -> return (Success, timingInfo)-    runExampleM' wrappedAction ctx runTreeLogs (Just [i|Exception in introduceWith '#{runTreeLabel}' handler|]) >>= \case+    runExampleM' runNodeCommon label wrappedAction ctx runTreeLogs (Just [i|Exception in introduceWith '#{runTreeLabel}' handler|]) >>= \case       Left err -> return (Failure err, emptyExtraTimingInfo)       Right x -> pure x startTree node@(RunNodeAround {..}) ctx' = do@@ -191,22 +218,37 @@   let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon   didRunWrappedAction <- liftIO $ newIORef (Left (), emptyExtraTimingInfo)   runInAsync node ctx $ do+    let opts = baseContextOptions (getBaseContext ctx)     let wrappedAction = do-          let failureResult e = case fromException e of-                Just fr@(Pending {}) -> Failure fr-                _ -> Failure $ Reason Nothing [i|around '#{runTreeLabel}' handler threw exception|]-          flip withException (\e -> recordExceptionInStatus runTreeStatus e) $ do+          didStartChildren <- liftIO $ newIORef False+          let handler e =+                -- If the handler failed before the children were started, mark them as failed+                -- due to a context issue. (Don't touch the node's own status here: that would+                -- race with the authoritative write in 'runInAsync'.) Otherwise let the+                -- children's existing statuses stand.+                liftIO (readIORef didStartChildren) >>= \case+                  False -> markAllChildrenWithResult runNodeChildren ctx $ case fromException e of+                    Just fr@(Pending {}) -> Failure fr+                    _ -> Failure $ GetContextException Nothing (SomeExceptionWithEq e)+                  True -> return ()++          flip withException handler $ do+            liftIO getCurrentTime >>= \t -> liftIO $ emitEvent opts t runTreeId runTreeLabel EventSetupStarted             runNodeActionWith $ do               setupFinishTime <- liftIO getCurrentTime               addSetupFinishTimeToStatus runTreeStatus setupFinishTime+              liftIO $ emitEvent opts setupFinishTime runTreeId runTreeLabel EventSetupFinished+              liftIO $ writeIORef didStartChildren True               results <- liftIO $ runNodesSequentially runNodeChildren ctx+              liftIO getCurrentTime >>= \t -> liftIO $ emitEvent opts t runTreeId runTreeLabel EventTeardownStarted               liftIO $ writeIORef didRunWrappedAction (Right results, mkSetupTimingInfo setupFinishTime)               return results +          liftIO getCurrentTime >>= \t -> liftIO $ emitEvent opts t runTreeId runTreeLabel EventTeardownFinished           (liftIO $ readIORef didRunWrappedAction) >>= \case             (Left (), timingInfo) -> return (Failure $ Reason Nothing [i|around '#{runTreeLabel}' handler didn't call action|], timingInfo)             (Right _, timingInfo) -> return (Success, timingInfo)-    runExampleM' wrappedAction ctx runTreeLogs (Just [i|Exception in around '#{runTreeLabel}' handler|]) >>= \case+    runExampleM' runNodeCommon runTreeLabel wrappedAction ctx runTreeLogs (Just [i|Exception in around '#{runTreeLabel}' handler|]) >>= \case       Left err -> return (Failure err, emptyExtraTimingInfo)       Right x -> pure x startTree node@(RunNodeDescribe {..}) ctx' = do@@ -222,9 +264,13 @@       0 -> return (Success, emptyExtraTimingInfo)       n -> return (Failure (ChildrenFailed Nothing n), emptyExtraTimingInfo) startTree node@(RunNodeIt {..}) ctx' = do+  let RunNodeCommonWithStatus {..} = runNodeCommon   let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon   runInAsync node ctx $ do-    (, emptyExtraTimingInfo) <$> runExampleM runNodeExample ctx (runTreeLogs runNodeCommon) Nothing+    let label = runTreeLabel+    (results, _, _) <- timed runNodeCommon runTreeRecordTime (getBaseContext ctx) label $+      runExampleM runNodeCommon label runNodeExample ctx runTreeLogs Nothing+    return (results, emptyExtraTimingInfo)  -- * Util @@ -233,14 +279,16 @@   let RunNodeCommonWithStatus {..} = runNodeCommon node   let bc@(BaseContext {..}) = getBaseContext ctx   let timerFn = if runTreeRecordTime then timeAction' (getTestTimer bc) baseContextTestTimerProfile (T.pack runTreeLabel) else id+  let asyncName = T.pack [i|node #{runTreeId}, #{runTreeLabel}|]   startTime <- liftIO getCurrentTime   mvar <- liftIO newEmptyMVar-  myAsync <- liftIO $ asyncWithUnmask $ \unmask -> do+  myAsync <- liftIO $ managedAsyncWithUnmask baseContextRunId asyncName $ \unmask -> do     flip withException (recordExceptionInStatus runTreeStatus) $ unmask $ do       readMVar mvar       (result, extraTimingInfo) <- timerFn action       endTime <- liftIO getCurrentTime       liftIO $ atomically $ writeTVar runTreeStatus $ Done startTime (setupFinishTime extraTimingInfo) (teardownStartTime extraTimingInfo) endTime result+      liftIO $ emitEvent baseContextOptions endTime runTreeId runTreeLabel (EventDone result)        whenFailure result $ \reason -> do         -- Make sure the folder exists, if configured@@ -253,7 +301,11 @@           _ -> do             whenJust baseContextErrorSymlinksDir $ \errorsDir ->               whenJust baseContextPath $ \dir -> do+#ifndef mingw32_HOST_OS                 whenJust baseContextRunRoot $ \runRoot -> do+#else+                whenJust baseContextRunRoot $ \_runRoot -> do+#endif                   let symlinkBaseName = case runTreeLoc of                         Nothing -> takeFileName dir                         Just loc -> [i|#{srcLocFile loc}_line#{srcLocStartLine loc}_#{takeFileName dir}|]@@ -295,6 +347,7 @@        return result   liftIO $ atomically $ writeTVar runTreeStatus $ Running startTime Nothing Nothing myAsync+  liftIO $ emitEvent baseContextOptions startTime runTreeId runTreeLabel EventStarted   liftIO $ putMVar mvar ()   return myAsync  -- TODO: fix race condition with writing to runTreeStatus (here and above) @@ -329,7 +382,7 @@ markAllChildrenWithResult children baseContext status = do   now <- liftIO getCurrentTime   forM_ (L.filter (shouldRunChild' baseContext) $ concatMap getCommons children) $ \child ->-    liftIO $ atomically $ modifyTVar (runTreeStatus child) $ \case+    liftIO $ atomically $ modifyTVar' (runTreeStatus child) $ \case       Running {..} -> Done now statusSetupFinishTime statusTeardownStartTime now status       done@(Done {}) -> done { statusResult = status }       _ -> Done now Nothing Nothing now status@@ -355,13 +408,17 @@  -- * Running examples -runExampleM :: HasBaseContext r => ExampleM r () -> r -> TVar (Seq LogEntry) -> Maybe String -> IO Result-runExampleM ex ctx logs exceptionMessage = runExampleM' ex ctx logs exceptionMessage >>= \case+runExampleM :: (+  HasBaseContext r+  ) => RunNodeCommonWithStatus (TVar Status) l t -> String -> ExampleM r () -> r -> TVar (Seq LogEntry) -> Maybe String -> IO Result+runExampleM rnc label ex ctx logs exceptionMessage = runExampleM' rnc label ex ctx logs exceptionMessage >>= \case   Left err -> return $ Failure err   Right () -> return Success -runExampleM' :: HasBaseContext r => ExampleM r a -> r -> TVar (Seq LogEntry) -> Maybe String -> IO (Either FailureReason a)-runExampleM' ex ctx logs exceptionMessage = do+runExampleM' :: (+  HasBaseContext r+  ) => RunNodeCommonWithStatus (TVar Status) l t -> String -> ExampleM r a -> r -> TVar (Seq LogEntry) -> Maybe String -> IO (Either FailureReason a)+runExampleM' rnc label ex ctx logs exceptionMessage = do   maybeTestDirectory <- getTestDirectory ctx   let options = baseContextOptions $ getBaseContext ctx @@ -369,16 +426,39 @@   -- withFile will catch IOException and fill in its own information, making the   -- resulting error confusing   withLogFn maybeTestDirectory options $ \logFn ->-    handleAny (wrapInFailureReasonIfNecessary exceptionMessage)-      (Right <$> (runLoggingT (runReaderT (unExampleT ex) ctx) logFn))+    handleAny (wrapInFailureReasonIfNecessary exceptionMessage) $+    withMaybeWarnOnLongExecution (getBaseContext ctx) rnc label $+    withMaybeCancelOnLongExecution (getBaseContext ctx) rnc label $+    (Right <$> (runLoggingT (runReaderT (unExampleT ex) ctx) logFn))    where     withLogFn :: Maybe FilePath -> Options -> (LogFn -> IO a) -> IO a-    withLogFn Nothing (Options {..}) action = action (logToMemory optionsSavedLogLevel logs)+    withLogFn Nothing (Options {..}) action = action (withLateLogCheck optionsLateLogFile $ withBroadcast optionsLogBroadcast $ logToMemory optionsSavedLogLevel logs)     withLogFn (Just logPath) (Options {..}) action = withFile (logPath </> "test_logs.txt") AppendMode $ \h -> do       hSetBuffering h LineBuffering-      action (logToMemoryAndFile optionsMemoryLogLevel optionsSavedLogLevel optionsLogFormatter logs h)+      action (withLateLogCheck optionsLateLogFile $ withBroadcast optionsLogBroadcast $ logToMemoryAndFile optionsMemoryLogLevel optionsSavedLogLevel optionsLogFormatter logs h) +    withBroadcast :: Maybe (TChan (Int, String, LogEntry)) -> LogFn -> LogFn+    withBroadcast Nothing logFn = logFn+    withBroadcast (Just chan) logFn = \loc logSrc logLevel logStr -> do+      logFn loc logSrc logLevel logStr+      ts <- getCurrentTime+      atomically $ writeTChan chan (runTreeId rnc, runTreeLabel rnc, LogEntry ts loc logSrc logLevel (fromLogStr logStr))++    withLateLogCheck :: Maybe Handle -> LogFn -> LogFn+    withLateLogCheck Nothing logFn = logFn+    withLateLogCheck (Just lateH) logFn = \loc logSrc logLevel logStr -> do+      logFn loc logSrc logLevel logStr+      status <- readTVarIO (runTreeStatus rnc)+      case status of+        Done {} -> do+          ts <- getCurrentTime+          let bs = fromLogStr logStr+          let line = [i|#{show ts} [LATE] [#{runTreeId rnc}] #{runTreeLabel rnc}: #{BS8.unpack bs}\n|]+          BS8.hPutStr lateH (BS8.pack line)+          hFlush lateH+        _ -> return ()+     getTestDirectory :: (HasBaseContext a) => a -> IO (Maybe FilePath)     getTestDirectory (getBaseContext -> (BaseContext {..})) = case baseContextPath of       Nothing -> return Nothing@@ -394,17 +474,22 @@         _ -> GotException Nothing msg (SomeExceptionWithEq e)  addSetupFinishTimeToStatus :: (MonadIO m) => TVar Status -> UTCTime -> m ()-addSetupFinishTimeToStatus statusVar setupFinishTime = atomically $ modifyTVar statusVar $ \case+addSetupFinishTimeToStatus statusVar setupFinishTime = atomically $ modifyTVar' statusVar $ \case   status@(Running {}) -> status { statusSetupFinishTime = Just setupFinishTime }   status@(Done {}) -> status { statusSetupFinishTime = Just setupFinishTime }   x -> x  addTeardownStartTimeToStatus :: (MonadIO m) => TVar Status -> UTCTime -> m ()-addTeardownStartTimeToStatus statusVar t = atomically $ modifyTVar statusVar $ \case+addTeardownStartTimeToStatus statusVar t = atomically $ modifyTVar' statusVar $ \case   status@(Running {}) -> status { statusTeardownStartTime = Just t }   status@(Done {}) -> status { statusTeardownStartTime = Just t }   x -> x +emitEvent :: Options -> UTCTime -> Int -> String -> NodeEventType -> IO ()+emitEvent (Options {optionsEventBroadcast = Just chan}) ts nid label evtType =+  atomically $ writeTChan chan (NodeEvent ts nid label evtType)+emitEvent _ _ _ _ _ = return ()+ recordExceptionInStatus :: (MonadIO m) => TVar Status -> SomeException -> m () recordExceptionInStatus status e = do   endTime <- liftIO getCurrentTime@@ -413,15 +498,70 @@         _ -> case fromException e of           Just (e' :: FailureReason) -> Failure e'           _ -> Failure (GotException Nothing Nothing (SomeExceptionWithEq e))-  liftIO $ atomically $ modifyTVar status $ \case+  liftIO $ atomically $ modifyTVar' status $ \case     Running {..} -> Done statusStartTime statusSetupFinishTime statusTeardownStartTime endTime ret     _ -> Done endTime Nothing Nothing endTime ret -timed :: (MonadUnliftIO m) => Bool -> BaseContext -> String -> m a -> m (a, UTCTime, UTCTime)-timed recordTime bc@(BaseContext {..}) label action = do+timed :: forall m a s l t. (MonadUnliftIO m) => RunNodeCommonWithStatus s l t -> Bool -> BaseContext -> String -> m a -> m (a, UTCTime, UTCTime)+timed _rnc recordTime bc@(BaseContext {..}) label action = do   let timerFn = if recordTime then timeAction' (getTestTimer bc) baseContextTestTimerProfile (T.pack label) else id    startTime <- liftIO getCurrentTime   ret <- timerFn action   endTime <- liftIO getCurrentTime   pure (ret, startTime, endTime)++withMaybeWarnOnLongExecution :: (MonadUnliftIO m) => BaseContext -> RunNodeCommonWithStatus s l t -> String -> m a -> m a+withMaybeWarnOnLongExecution (BaseContext {..}) rnc@(RunNodeCommonWithStatus {..}) label inner = case optionsWarnOnLongExecutionMs baseContextOptions of+  Nothing -> inner+  Just maxTimeMs -> do+    managedWithAsync_ baseContextRunId (T.pack [i|warn-long:#{runTreeId}:#{label}|]) (waiter maxTimeMs) inner++  where+    waiter maxTimeMs = do+      -- Use unsafeUnmask to make threadDelay interruptible even in masked cleanup contexts+      -- (like the bracket call of an Introduce node)+      liftIO $ unsafeUnmask $ threadDelay (maxTimeMs * 1000)++      micros <- liftIO getCurrentMicrosInteger++      whenJust baseContextRunRoot $ \runRoot -> do+        let dir = runRoot </> "long-execution-warnings"+        createDirectoryIfMissing True dir+        writeInfoToFile rnc maxTimeMs (dir </> (nodeToFolderName [i|#{micros}-#{runTreeId}-warn-#{label}|] 1 0) <.> "log") label++withMaybeCancelOnLongExecution :: (MonadUnliftIO m) => BaseContext -> RunNodeCommonWithStatus s l t -> String -> m a -> m a+withMaybeCancelOnLongExecution (BaseContext {..}) rnc@(RunNodeCommonWithStatus {..}) label inner = case optionsCancelOnLongExecutionMs baseContextOptions of+  Nothing -> inner+  Just maxTimeMs ->+    race (waiter maxTimeMs) inner >>= \case+      Left _ -> do+        micros <- liftIO getCurrentMicrosInteger+        whenJust baseContextRunRoot $ \runRoot -> do+          let dir = runRoot </> "long-execution-warnings"+          createDirectoryIfMissing True dir+          writeInfoToFile rnc maxTimeMs (dir </> (nodeToFolderName [i|#{micros}-#{runTreeId}-cancel-#{label}|] 1 0) <.> "log") label+        throwIO $ Reason (Just callStack) $ [i|Timed out long-running node|]+      Right x -> return x+  where+    waiter maxTimeMs =+      -- Use unsafeUnmask to make threadDelay interruptible even in masked cleanup contexts+      liftIO $ unsafeUnmask $ threadDelay (maxTimeMs * 1000)++writeInfoToFile :: MonadUnliftIO m => RunNodeCommonWithStatus s l t -> Int -> FilePath -> String -> m ()+writeInfoToFile (RunNodeCommonWithStatus {..}) ms fileName label =+  bracket (liftIO $ openFile fileName WriteMode) (liftIO . hClose) $ \h -> do+    liftIO $ T.hPutStrLn h [__i|Node was still running after #{ms}ms: #{label}++                                Ancestors: #{runTreeAncestors}++                                Folder: #{runTreeFolder}+                                |]+    whenJust runTreeLoc $ \(SrcLoc {..}) ->+      liftIO $ T.hPutStrLn h [__i|\nLoc: #{srcLocFile}:#{srcLocStartLine}:#{srcLocStartCol} in #{srcLocPackage}:#{srcLocModule}+                                 |]++getCurrentMicrosInteger :: IO Integer+getCurrentMicrosInteger = do+  t <- getPOSIXTime+  return $ round (t * 1000000)

@@ -9,7 +9,7 @@   , Test.Sandwich.Logging.logError   , Test.Sandwich.Logging.logOther -  -- * Process functions with logging+  -- * Process functions with direct logging   , createProcessWithLogging   , readCreateProcessWithLogging   , createProcessWithLoggingAndStdin@@ -19,29 +19,24 @@   , readCreateProcessWithLogging'   , createProcessWithLoggingAndStdin'   , callCommandWithLogging'++  -- * Process functions with file logging+  , createProcessWithFileLogging+  , readCreateProcessWithFileLogging+  , createProcessWithFileLoggingAndStdin+  , callCommandWithFileLogging++  , createProcessWithFileLogging'+  , readCreateProcessWithFileLogging'+  , createProcessWithFileLoggingAndStdin'+  , callCommandWithFileLogging'   ) where -import Control.Concurrent-import Control.DeepSeq (rnf)-import qualified Control.Exception as C-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.IO.Unlift import Control.Monad.Logger hiding (logOther)-import Data.String.Interpolate import Data.Text (Text)-import Foreign.C.Error-import GHC.IO.Exception import GHC.Stack-import System.IO-import System.IO.Error (mkIOError)-import System.Process-import UnliftIO.Async hiding (wait)-import UnliftIO.Exception--#if !MIN_VERSION_base(4,13,0)-import Control.Monad.Fail-#endif+import Test.Sandwich.Logging.Process+import Test.Sandwich.Logging.ProcessFileLogging   -- * Basic logging functions@@ -66,163 +61,3 @@ -- | Log with a custom 'LogLevel'. logOther :: (HasCallStack, MonadLogger m) => LogLevel -> Text -> m () logOther = logOtherCS callStack----- * System.Process helpers------ | Functions for launching processes while capturing their output in the logs.---- | 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 :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => CreateProcess -> m ProcessHandle-createProcessWithLogging = withFrozenCallStack (createProcessWithLogging' LevelDebug)---- | Spawn a process with its stdout and stderr connected to the logging system.-createProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => LogLevel -> CreateProcess -> m ProcessHandle-createProcessWithLogging' logLevel cp = do-  (hRead, hWrite) <- liftIO createPipe--  let name = case cmdspec cp of-        ShellCommand {} -> "shell"-        RawCommand path _ -> path--  _ <- async $ forever $ do-    line <- liftIO $ hGetLine hRead-    logOtherCS callStack logLevel [i|#{name}: #{line}|]--  (_, _, _, p) <- liftIO $ createProcess (cp { std_out = UseHandle hWrite, std_err = UseHandle hWrite })-  return p---- | Like 'readCreateProcess', but capture the stderr output in the logs.--- Every line output by the process will be fed to a 'debug' call.-readCreateProcessWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => CreateProcess -> String -> m String-readCreateProcessWithLogging = withFrozenCallStack (readCreateProcessWithLogging' LevelDebug)---- | Like 'readCreateProcess', but capture the stderr output in the logs.-readCreateProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m String-readCreateProcessWithLogging' logLevel cp input = do-  (hReadErr, hWriteErr) <- liftIO createPipe--  let name = case cmdspec cp of-        ShellCommand {} -> "shell"-        RawCommand path _ -> path--  _ <- async $ forever $ do-    line <- liftIO $ hGetLine hReadErr-    logOtherCS callStack logLevel [i|#{name}: #{line}|]--  -- Do this just like 'readCreateProcess'-  -- https://hackage.haskell.org/package/process-1.6.17.0/docs/src/System.Process.html#readCreateProcess-  (ex, output) <- liftIO $ withCreateProcess (cp { std_in = CreatePipe, std_out = CreatePipe, std_err = UseHandle hWriteErr }) $ \sin' sout _ p -> do-    case (sin', sout) of-      (Just hIn, Just hOut) -> do-        output  <- hGetContents hOut-        withForkWait (C.evaluate $ rnf output) $ \waitOut -> do-          -- now write any input-          unless (Prelude.null input) $-            ignoreSigPipe $ hPutStr hIn input-          -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE-          ignoreSigPipe $ hClose hIn--          -- wait on the output-          waitOut-          hClose hOut--        -- wait on the process-        ex <- waitForProcess p-        return (ex, output)-      (Nothing, _) -> liftIO $ throwIO $ userError "readCreateProcessWithStderrLogging: Failed to get a stdin handle."-      (_, Nothing) -> liftIO $ throwIO $ userError "readCreateProcessWithStderrLogging: Failed to get a stdout handle."--  case ex of-    ExitSuccess -> return output-    ExitFailure r -> liftIO $ processFailedException "readCreateProcessWithLogging" cmd args r--  where-    cmd = case cp of-            CreateProcess { cmdspec = ShellCommand sc } -> sc-            CreateProcess { cmdspec = RawCommand fp _ } -> fp-    args = case cp of-             CreateProcess { cmdspec = ShellCommand _ } -> []-             CreateProcess { cmdspec = RawCommand _ args' } -> args'----- | 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 :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m) => CreateProcess -> String -> m ProcessHandle-createProcessWithLoggingAndStdin = withFrozenCallStack (createProcessWithLoggingAndStdin' LevelDebug)---- | Spawn a process with its stdout and stderr connected to the logging system.-createProcessWithLoggingAndStdin' :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m ProcessHandle-createProcessWithLoggingAndStdin' logLevel 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-    logOtherCS callStack logLevel [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---- | Higher level version of 'createProcessWithLogging', accepting a shell command.-callCommandWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => String -> m ()-callCommandWithLogging = withFrozenCallStack (callCommandWithLogging' LevelDebug)---- | Higher level version of 'createProcessWithLogging'', accepting a shell command.-callCommandWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => LogLevel -> String -> m ()-callCommandWithLogging' logLevel cmd = do-  (hRead, hWrite) <- liftIO createPipe--  (_, _, _, p) <- liftIO $ createProcess (shell cmd) {-    delegate_ctlc = True-    , std_out = UseHandle hWrite-    , std_err = UseHandle hWrite-    }--  _ <- async $ forever $ do-    line <- liftIO $ hGetLine hRead-    logOtherCS callStack logLevel [i|#{cmd}: #{line}|]--  liftIO (waitForProcess p) >>= \case-    ExitSuccess -> return ()-    ExitFailure r -> liftIO $ throwIO $ userError [i|callCommandWithLogging failed for '#{cmd}': '#{r}'|]----- * Util---- Copied from System.Process-withForkWait :: IO () -> (IO () ->  IO a) -> IO a-withForkWait asy body = do-  waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))-  mask $ \restore -> do-    tid <- forkIO $ try (restore asy) >>= putMVar waitVar-    let wait = takeMVar waitVar >>= either throwIO return-    restore (body wait) `C.onException` killThread tid---- 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---- Copied from System.Process-processFailedException :: String -> String -> [String] -> Int -> IO a-processFailedException fun cmd args exit_code =-  ioError (mkIOError OtherError (fun ++ ": " ++ cmd ++-                                 Prelude.concatMap ((' ':) . show) args ++-                                 " (exit " ++ show exit_code ++ ")")-            Nothing Nothing)

@@ -0,0 +1,198 @@+{-# LANGUAGE CPP #-}++-- | Functions for launching processes while capturing their output in the test logs.++module Test.Sandwich.Logging.Process (+  -- * Process functions with direct logging+  createProcessWithLogging+  , readCreateProcessWithLogging+  , createProcessWithLoggingAndStdin+  , callCommandWithLogging++  , createProcessWithLogging'+  , readCreateProcessWithLogging'+  , createProcessWithLoggingAndStdin'+  , callCommandWithLogging'+  ) where++import Control.Concurrent+import Control.DeepSeq (rnf)+import qualified Control.Exception as C+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Logger hiding (logOther)+import Data.String.Interpolate+import Foreign.C.Error+import GHC.IO.Exception+import GHC.Stack+import System.IO+import System.IO.Error (mkIOError)+import Test.Sandwich.ManagedAsync+import Test.Sandwich.Types.RunTree+import UnliftIO.Async+import UnliftIO.Exception+import UnliftIO.Process++#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail+#endif+++-- | 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 :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> m (ProcessHandle, Async ())+createProcessWithLogging = withFrozenCallStack (createProcessWithLogging' LevelDebug)++-- | Spawn a process with its stdout and stderr connected to the logging system.+createProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> CreateProcess -> m (ProcessHandle, Async ())+createProcessWithLogging' logLevel cp = do+  (hRead, hWrite) <- liftIO createPipe++  let name = case cmdspec cp of+        ShellCommand {} -> "shell"+        RawCommand path _ -> path++  streamsReaderAsy <- managedAsyncContext "streams-reader" $ forever $ do+    line <- liftIO $ hGetLine hRead+    logOtherCS callStack logLevel [i|#{name}: #{line}|]++  (_, _, _, p) <- liftIO $ createProcess (cp { std_out = UseHandle hWrite, std_err = UseHandle hWrite })+  return (p, streamsReaderAsy)++-- | Like 'readCreateProcess', but capture the stderr output in the logs.+-- Every line output by the process will be fed to a 'debug' call.+readCreateProcessWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> String -> m String+readCreateProcessWithLogging = withFrozenCallStack (readCreateProcessWithLogging' LevelDebug)++-- | Like 'readCreateProcess', but capture the stderr output in the logs.+readCreateProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> CreateProcess -> String -> m String+readCreateProcessWithLogging' logLevel cp input = do+  (hReadErr, hWriteErr) <- liftIO createPipe++  let name = case cmdspec cp of+        ShellCommand {} -> "shell"+        RawCommand path _ -> path++  let stderrReader = forever $ do+        line <- liftIO $ hGetLine hReadErr+        logOtherCS callStack logLevel [i|#{name}: #{line}|]++  (ex, output) <-+    managedWithAsyncContext_ "stderr-reader" stderrReader $+    withCreateProcess (cp { std_in = CreatePipe, std_out = CreatePipe, std_err = UseHandle hWriteErr }) $ \sin' sout _ p ->+      -- Do this just like 'readCreateProcess'+      -- https://hackage.haskell.org/package/process-1.6.17.0/docs/src/System.Process.html#readCreateProcess+      case (sin', sout) of+        (Just hIn, Just hOut) -> liftIO $ do+          output  <- hGetContents hOut+          withForkWait (C.evaluate $ rnf output) $ \waitOut -> do+            -- now write any input+            unless (Prelude.null input) $+              ignoreSigPipe $ hPutStr hIn input+            -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE+            ignoreSigPipe $ hClose hIn++            -- wait on the output+            waitOut+            hClose hOut++          -- wait on the process+          ex <- waitForProcess p+          return (ex, output)+        (Nothing, _) -> liftIO $ throwIO $ userError "readCreateProcessWithStderrLogging: Failed to get a stdin handle."+        (_, Nothing) -> liftIO $ throwIO $ userError "readCreateProcessWithStderrLogging: Failed to get a stdout handle."++  case ex of+    ExitSuccess -> return output+    ExitFailure r -> liftIO $ processFailedException "readCreateProcessWithLogging" cmd args r++  where+    cmd = case cp of+            CreateProcess { cmdspec = ShellCommand sc } -> sc+            CreateProcess { cmdspec = RawCommand fp _ } -> fp+    args = case cp of+             CreateProcess { cmdspec = ShellCommand _ } -> []+             CreateProcess { cmdspec = RawCommand _ args' } -> args'+++-- | 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 :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> String -> m (ProcessHandle, Async ())+createProcessWithLoggingAndStdin = withFrozenCallStack (createProcessWithLoggingAndStdin' LevelDebug)++-- | Spawn a process with its stdout and stderr connected to the logging system.+createProcessWithLoggingAndStdin' :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> CreateProcess -> String -> m (ProcessHandle, Async ())+createProcessWithLoggingAndStdin' logLevel cp input = do+  (hRead, hWrite) <- liftIO createPipe++  let name = case cmdspec cp of+        ShellCommand {} -> "shell"+        RawCommand path _ -> path++  readAsy <- managedAsyncContext "read-process-streams" $ forever $ do+    line <- liftIO $ hGetLine hRead+    logOtherCS callStack logLevel [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, readAsy)++-- | Higher level version of 'createProcessWithLogging', accepting a shell command.+callCommandWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => String -> m ()+callCommandWithLogging = withFrozenCallStack (callCommandWithLogging' LevelDebug)++-- | Higher level version of 'createProcessWithLogging'', accepting a shell command.+callCommandWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => LogLevel -> String -> m ()+callCommandWithLogging' logLevel cmd = do+  (hRead, hWrite) <- liftIO createPipe++  (_, _, _, p) <- liftIO $ createProcess (shell cmd) {+    delegate_ctlc = True+    , std_out = UseHandle hWrite+    , std_err = UseHandle hWrite+    }++  let streamsReader = forever $ do+        line <- liftIO $ hGetLine hRead+        logOtherCS callStack logLevel [i|#{cmd}: #{line}|]++  managedWithAsyncContext_ "stderr-reader" streamsReader $+    liftIO (waitForProcess p) >>= \case+      ExitSuccess -> return ()+      ExitFailure r -> liftIO $ throwIO $ userError [i|callCommandWithLogging failed for '#{cmd}': '#{r}'|]+++-- * Util++-- Copied from System.Process+withForkWait :: IO () -> (IO () ->  IO a) -> IO a+withForkWait asy body = do+  waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))+  mask $ \restore -> do+    tid <- forkIO $ try (restore asy) >>= putMVar waitVar+    let wait' = takeMVar waitVar >>= either throwIO return+    restore (body wait') `C.onException` killThread tid++-- 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++-- Copied from System.Process+processFailedException :: String -> String -> [String] -> Int -> IO a+processFailedException fun cmd args exit_code =+  ioError (mkIOError OtherError (fun ++ ": " ++ cmd +++                                 Prelude.concatMap ((' ':) . show) args +++                                 " (exit " ++ show exit_code ++ ")")+            Nothing Nothing)

@@ -0,0 +1,162 @@+{-# LANGUAGE CPP #-}++-- | Functions for launching processes while capturing their output to files in the test tree.++module Test.Sandwich.Logging.ProcessFileLogging (+  createProcessWithFileLogging+  , readCreateProcessWithFileLogging+  , createProcessWithFileLoggingAndStdin+  , callCommandWithFileLogging++  , createProcessWithFileLogging'+  , readCreateProcessWithFileLogging'+  , createProcessWithFileLoggingAndStdin'+  , callCommandWithFileLogging'+  ) where++import Control.Concurrent+import Control.DeepSeq (rnf)+import qualified Control.Exception as C+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Logger+import Data.String.Interpolate+import Foreign.C.Error+import GHC.IO.Exception+import GHC.Stack+import System.FilePath+import System.IO+import System.Process+import Test.Sandwich.Contexts+import Test.Sandwich.Expectations+import Test.Sandwich.Types.RunTree+import UnliftIO.Exception++#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail+#endif+++-- | Derive a short name from a 'CreateProcess' for use in log file names.+-- For 'RawCommand', takes the base filename of the executable.+-- For 'ShellCommand', takes the first word of the command string.+processName :: CreateProcess -> String+processName cp = case cmdspec cp of+  RawCommand path _ -> takeFileName path+  ShellCommand cmd -> case words cmd of+    (w:_) -> takeFileName w+    [] -> "shell"++-- | Spawn a process with its stdout and stderr logged to files in the test tree.+createProcessWithFileLogging :: (+  HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m+  ) => CreateProcess -> m ProcessHandle+createProcessWithFileLogging cp = withFrozenCallStack $ createProcessWithFileLogging' (processName cp) cp++-- | Spawn a process with its stdout and stderr logged to files in the test tree.+createProcessWithFileLogging' :: (+  HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m+  ) => FilePath -> CreateProcess -> m ProcessHandle+createProcessWithFileLogging' name cp = withFrozenCallStack $ do+  getCurrentFolder >>= \case+    Nothing -> expectationFailure [i|createProcessWithFileLogging: no current folder, so unable to log for '#{name}'.|]+    Just dir ->+      bracket (liftIO $ openTempFile dir (name <.> "out")) (\(_outfile, hOut) -> liftIO $ hClose hOut) $ \(_outfile, hOut) ->+      bracket (liftIO $ openTempFile dir (name <.> "err")) (\(_errfile, hErr) -> liftIO $ hClose hErr) $ \(_errfile, hErr) -> do+        (_, _, _, p) <- liftIO $ createProcess (cp { std_out = UseHandle hOut, std_err = UseHandle hErr })+        return p++-- | Like 'readCreateProcess', but capture the stderr output to a file in the test tree.+-- Returns the stdout output as a 'String'.+readCreateProcessWithFileLogging :: (+  HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m+  ) => CreateProcess -> String -> m String+readCreateProcessWithFileLogging cp = withFrozenCallStack $ readCreateProcessWithFileLogging' (processName cp) cp++-- | Like 'readCreateProcessWithFileLogging', but accepting a name to use for the log files.+readCreateProcessWithFileLogging' :: (+  HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m+  ) => FilePath -> CreateProcess -> String -> m String+readCreateProcessWithFileLogging' name cp input = withFrozenCallStack $ do+  getCurrentFolder >>= \case+    Nothing -> expectationFailure [i|readCreateProcessWithFileLogging: no current folder, so unable to log for '#{name}'.|]+    Just dir ->+      bracket (liftIO $ openTempFile dir (name <.> "err")) (\(_errfile, hErr) -> liftIO $ hClose hErr) $ \(_errfile, hErr) -> do+        (ex, output) <- liftIO $ withCreateProcess (cp { std_in = CreatePipe, std_out = CreatePipe, std_err = UseHandle hErr }) $ \sin' sout _ p -> do+          case (sin', sout) of+            (Just hIn, Just hOut) -> do+              output <- hGetContents hOut+              withForkWait (C.evaluate $ rnf output) $ \waitOut -> do+                unless (Prelude.null input) $+                  ignoreSigPipe $ hPutStr hIn input+                ignoreSigPipe $ hClose hIn+                waitOut+                hClose hOut+              ex <- waitForProcess p+              return (ex, output)+            (Nothing, _) -> throwIO $ userError "readCreateProcessWithFileLogging: Failed to get a stdin handle."+            (_, Nothing) -> throwIO $ userError "readCreateProcessWithFileLogging: Failed to get a stdout handle."+        case ex of+          ExitSuccess -> return output+          ExitFailure r -> liftIO $ throwIO $ userError [i|readCreateProcessWithFileLogging failed for '#{name}': exit code #{r}|]++-- | Spawn a process with its stdout and stderr logged to files in the test tree,+-- passing the given string as stdin.+createProcessWithFileLoggingAndStdin :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m, HasBaseContextMonad context m) => CreateProcess -> String -> m ProcessHandle+createProcessWithFileLoggingAndStdin cp = withFrozenCallStack $ createProcessWithFileLoggingAndStdin' (processName cp) cp++-- | Like 'createProcessWithFileLoggingAndStdin', but accepting a name to use for the log files.+createProcessWithFileLoggingAndStdin' :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m, HasBaseContextMonad context m) => FilePath -> CreateProcess -> String -> m ProcessHandle+createProcessWithFileLoggingAndStdin' name cp input = withFrozenCallStack $ do+  getCurrentFolder >>= \case+    Nothing -> expectationFailure [i|createProcessWithFileLoggingAndStdin: no current folder, so unable to log for '#{name}'.|]+    Just dir ->+      bracket (liftIO $ openTempFile dir (name <.> "out")) (\(_outfile, hOut) -> liftIO $ hClose hOut) $ \(_outfile, hOut) ->+      bracket (liftIO $ openTempFile dir (name <.> "err")) (\(_errfile, hErr) -> liftIO $ hClose hErr) $ \(_errfile, hErr) -> do+        (Just inh, _, _, p) <- liftIO $ createProcess (cp { std_out = UseHandle hOut+                                                           , std_err = UseHandle hErr+                                                           , std_in = CreatePipe })+        unless (Prelude.null input) $+          liftIO $ ignoreSigPipe $ hPutStr inh input+        liftIO $ ignoreSigPipe $ hClose inh+        return p++-- | Higher level version of 'createProcessWithFileLogging', accepting a shell command.+callCommandWithFileLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => String -> m ()+callCommandWithFileLogging cmd = withFrozenCallStack $ callCommandWithFileLogging' (processName (shell cmd)) cmd++-- | Like 'callCommandWithFileLogging', but accepting a name to use for the log files.+callCommandWithFileLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m, HasBaseContextMonad context m) => FilePath -> String -> m ()+callCommandWithFileLogging' name cmd = withFrozenCallStack $ do+  getCurrentFolder >>= \case+    Nothing -> expectationFailure [i|callCommandWithFileLogging: no current folder, so unable to log for '#{name}'.|]+    Just dir ->+      bracket (liftIO $ openTempFile dir (name <.> "out")) (\(_outfile, hOut) -> liftIO $ hClose hOut) $ \(_outfile, hOut) ->+      bracket (liftIO $ openTempFile dir (name <.> "err")) (\(_errfile, hErr) -> liftIO $ hClose hErr) $ \(_errfile, hErr) -> do+        (_, _, _, p) <- liftIO $ createProcess (shell cmd) {+          delegate_ctlc = True+          , std_out = UseHandle hOut+          , std_err = UseHandle hErr+          }+        liftIO (waitForProcess p) >>= \case+          ExitSuccess -> return ()+          ExitFailure r -> liftIO $ throwIO $ userError [i|callCommandWithFileLogging failed for '#{cmd}': '#{r}'|]+++-- * Util++-- Copied from System.Process+withForkWait :: IO () -> (IO () ->  IO a) -> IO a+withForkWait asy body = do+  waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))+  mask $ \restore -> do+    tid <- forkIO $ try (restore asy) >>= putMVar waitVar+    let wait = takeMVar waitVar >>= either throwIO return+    restore (body wait) `C.onException` killThread tid++-- 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

@@ -0,0 +1,121 @@+{-# LANGUAGE RankNTypes #-}++module Test.Sandwich.ManagedAsync (+  -- * With explicit run ID+  managedAsync+  , managedAsyncWithUnmask+  , managedWithAsync+  , managedWithAsync_++  -- * With run ID from BaseContext+  , managedAsyncContext+  , managedAsyncWithUnmaskContext+  , managedWithAsyncContext+  , managedWithAsyncContext_++  -- * Types and utilities+  , AsyncInfo(..)+  , AsyncEvent(..)+  , asyncEventBroadcast+  , getManagedAsyncInfos+  ) where++import Control.Concurrent (ThreadId, myThreadId)+import Control.Concurrent.STM+import Control.Monad.IO.Unlift+import Control.Monad.Reader+import Data.IORef+import qualified Data.Map.Strict as M+import qualified Data.Text as T+import System.IO.Unsafe (unsafePerformIO)+import Test.Sandwich.Types.RunTree (HasBaseContextMonad, BaseContext(..), getBaseContext)+import UnliftIO.Async+import UnliftIO.Exception+++data AsyncInfo = AsyncInfo {+  asyncInfoThreadId :: !T.Text+  , asyncInfoParentThreadId :: !T.Text+  , asyncInfoName :: !T.Text+  , asyncInfoRunId :: !T.Text+  } deriving (Show, Eq)++data AsyncEvent = AsyncStarted !AsyncInfo | AsyncFinished !AsyncInfo++{-# NOINLINE allManagedAsyncs #-}+allManagedAsyncs :: IORef (M.Map ThreadId AsyncInfo)+allManagedAsyncs = unsafePerformIO $ newIORef M.empty++{-# NOINLINE asyncEventBroadcast #-}+asyncEventBroadcast :: TChan AsyncEvent+asyncEventBroadcast = unsafePerformIO newBroadcastTChanIO++getManagedAsyncInfos :: IO (M.Map T.Text AsyncInfo)+getManagedAsyncInfos = M.mapKeys (T.pack . show) <$> readIORef allManagedAsyncs++managedAsync :: MonadUnliftIO m => T.Text -> T.Text -> m a -> m (Async a)+managedAsync runId name action = do+  parentThreadId <- liftIO myThreadId+  async $ bracketedAction parentThreadId runId name action++managedAsyncWithUnmask :: MonadUnliftIO m => T.Text -> T.Text -> ((forall b. m b -> m b) -> m a) -> m (Async a)+managedAsyncWithUnmask runId name action = do+  parentThreadId <- liftIO myThreadId+  asyncWithUnmask $ \unmask -> bracketedAction parentThreadId runId name (action unmask)++managedWithAsync :: MonadUnliftIO m => T.Text -> T.Text -> m a -> (Async a -> m b) -> m b+managedWithAsync runId name action cb = do+  parentThreadId <- liftIO myThreadId+  withAsync (bracketedAction parentThreadId runId name action) cb++managedWithAsync_ :: MonadUnliftIO m => T.Text -> T.Text -> m a -> m b -> m b+managedWithAsync_ runId name f g = managedWithAsync runId name f (const g)++-- * With run ID from BaseContext++-- | Like 'managedAsync', but extracts the run ID from 'BaseContext'.+managedAsyncContext :: (MonadUnliftIO m, HasBaseContextMonad context m) => T.Text -> m a -> m (Async a)+managedAsyncContext name action = do+  runId <- baseContextRunId <$> asks getBaseContext+  managedAsync runId name action++-- | Like 'managedAsyncWithUnmask', but extracts the run ID from 'BaseContext'.+managedAsyncWithUnmaskContext :: (MonadUnliftIO m, HasBaseContextMonad context m) => T.Text -> ((forall b. m b -> m b) -> m a) -> m (Async a)+managedAsyncWithUnmaskContext name action = do+  runId <- baseContextRunId <$> asks getBaseContext+  managedAsyncWithUnmask runId name action++-- | Like 'managedWithAsync', but extracts the run ID from 'BaseContext'.+managedWithAsyncContext :: (MonadUnliftIO m, HasBaseContextMonad context m) => T.Text -> m a -> (Async a -> m b) -> m b+managedWithAsyncContext name action cb = do+  runId <- baseContextRunId <$> asks getBaseContext+  managedWithAsync runId name action cb++-- | Like 'managedWithAsync_', but extracts the run ID from 'BaseContext'.+managedWithAsyncContext_ :: (MonadUnliftIO m, HasBaseContextMonad context m) => T.Text -> m a -> m b -> m b+managedWithAsyncContext_ name f g = managedWithAsyncContext name f (const g)++-- * Internal++bracketedAction :: MonadUnliftIO m => ThreadId -> T.Text -> T.Text -> m a -> m a+bracketedAction parentThreadId runId name action = bracket record unrecord (const action)+  where+    record :: MonadUnliftIO m => m ThreadId+    record = do+      asyncThreadId <- liftIO myThreadId+      let info = AsyncInfo {+            asyncInfoThreadId = T.pack (show asyncThreadId)+            , asyncInfoParentThreadId = T.pack (show parentThreadId)+            , asyncInfoName = name+            , asyncInfoRunId = runId+            }+      liftIO $ atomicModifyIORef' allManagedAsyncs (\m -> (M.insert asyncThreadId info m, ()))+      liftIO $ atomically $ writeTChan asyncEventBroadcast (AsyncStarted info)+      return asyncThreadId++    unrecord :: MonadUnliftIO m => ThreadId -> m ()+    unrecord asyncThreadId = liftIO $ do+      mInfo <- atomicModifyIORef' allManagedAsyncs (\m -> (M.delete asyncThreadId m, M.lookup asyncThreadId m))+      case mInfo of+        Just info -> atomically $ writeTChan asyncEventBroadcast (AsyncFinished info)+        Nothing -> return ()

@@ -36,15 +36,12 @@   ) where  import Control.Monad.Logger+import Data.Function ((&)) import Data.Time.Clock import Test.Sandwich.Formatters.Print import Test.Sandwich.Types.RunTree -#ifdef mingw32_HOST_OS-import Data.Function ((&))-#endif - -- | A reasonable default set of options. defaultOptions :: Options defaultOptions = Options {@@ -58,19 +55,26 @@   , optionsFormatters = [SomeFormatter defaultPrintFormatter]   , optionsProjectRoot = Nothing   , optionsTestTimerType = SpeedScopeTestTimerType { speedScopeTestTimerWriteRawTimings = False }+  , optionsWarnOnLongExecutionMs = Nothing+  , optionsCancelOnLongExecutionMs = Nothing+  , optionsLogBroadcast = Nothing+  , optionsEventBroadcast = Nothing+  , optionsLateLogFile = Nothing+  , optionsRunId = "run0"   } +-- | Generate a test artifacts directory based on a timestamp.+--+-- Replace the colons with underscores, which makes this more safe for various+-- systems including Windows and GitHub Actions. defaultTestArtifactsDirectory :: TestArtifactsDirectory defaultTestArtifactsDirectory = TestArtifactsGeneratedDirectory "test_runs" getFolderName   where-#ifndef mingw32_HOST_OS-    getFolderName = show <$> getCurrentTime-#else     getFolderName = do       ts <- show <$> getCurrentTime       return $ ts         & replace ':' '_'+        & replace ' ' '_'      replace :: Eq a => a -> a -> [a] -> [a]     replace a b = map $ \c -> if c == a then b else c-#endif

@@ -81,7 +81,7 @@   -> SpecFree context m () parallelNFromArgs' nodeOptions getParallelism = parallelN'' nodeOptions f   where-    f = (getParallelism <$> getContext commandLineOptions) >>= liftIO . newQSem+    f = getContext commandLineOptions >>= (liftIO . newQSem) . getParallelism  parallelN'' :: (   MonadUnliftIO m

@@ -136,7 +136,7 @@  capitalize :: T.Text -> T.Text capitalize t | T.length t == 1 = T.toUpper t-capitalize t = (toUpper $ T.head t) `T.cons` (T.tail t)+capitalize t = toUpper (T.head t) `T.cons` (T.tail t)  splitR :: (Char -> Bool) -> String -> [String] splitR _ [] = []

@@ -46,6 +46,9 @@ type EventName = T.Text type ProfileName = T.Text +allTestsEventName :: EventName+allTestsEventName = "All tests"+ -- * User functions  -- | Time a given action with a given event name. This name will be the "stack frame" of the given action in the profiling results. This function will use the current timing profile name.@@ -98,6 +101,8 @@  newSpeedScopeTestTimer :: FilePath -> Bool -> IO TestTimer newSpeedScopeTestTimer path writeRawTimings = do+  startTime <- liftIO getPOSIXTime+   createDirectoryIfMissing True path    maybeHandle <- case writeRawTimings of@@ -108,14 +113,31 @@       return $ Just h    speedScopeFile <- newMVar emptySpeedScopeFile-  return $ SpeedScopeTestTimer path maybeHandle speedScopeFile+  return $ SpeedScopeTestTimer startTime path maybeHandle speedScopeFile  finalizeSpeedScopeTestTimer :: TestTimer -> IO () finalizeSpeedScopeTestTimer NullTestTimer = return () finalizeSpeedScopeTestTimer (SpeedScopeTestTimer {..}) = do+  endTime <- liftIO getPOSIXTime++  speedScopeFile <- readMVar testTimerSpeedScopeFile+   whenJust testTimerHandle hClose-  readMVar testTimerSpeedScopeFile >>= BL.writeFile (testTimerBasePath </> "speedscope.json") . A.encode +  -- Wrap every test profile in an overall frame called 'allTestsEventName'. If+  -- we don't do this, the speedscope viewer will show each profile as if it+  -- starts at time 0.+  let finalSpeedScopeFile :: SpeedScopeFile = L.foldl'+        (\ssf profileName ->+           ssf+           & prependSpeedScopeEvent testTimerStartTime profileName allTestsEventName SpeedScopeEventTypeOpen+           & appendSpeedScopeEvent endTime profileName allTestsEventName SpeedScopeEventTypeClose+        )+        speedScopeFile+        (fmap (^. name) (speedScopeFile ^. profiles))++  BL.writeFile (testTimerBasePath </> "speedscope.json") $ A.encode finalSpeedScopeFile+ timeAction' :: (MonadUnliftIO m) => TestTimer -> T.Text -> T.Text -> m a -> m a timeAction' NullTestTimer _ _ = id timeAction' (SpeedScopeTestTimer {..}) profileName eventName = bracket_@@ -137,7 +159,7 @@   -> m SpeedScopeFile handleStartEvent' maybeHandle profileName eventName file time = do   whenJust maybeHandle $ \h -> liftIO $ T.hPutStrLn h [i|#{time} START #{show profileName} #{eventName}|]-  return $ handleSpeedScopeEvent file time profileName eventName SpeedScopeEventTypeOpen+  return $ appendSpeedScopeEvent time profileName eventName SpeedScopeEventTypeOpen file  handleEndEvent :: (MonadUnliftIO m) => TestTimer -> T.Text -> T.Text -> m () handleEndEvent NullTestTimer _profileName _eventName = return ()@@ -154,13 +176,26 @@   -> m SpeedScopeFile handleEndEvent' maybeHandle profileName eventName file time = do   whenJust maybeHandle $ \h -> liftIO $ T.hPutStrLn h [i|#{time} END #{show profileName} #{eventName}|]-  return $ handleSpeedScopeEvent file time profileName eventName SpeedScopeEventTypeClose+  return $ appendSpeedScopeEvent time profileName eventName SpeedScopeEventTypeClose file +appendSpeedScopeEvent :: POSIXTime -> T.Text -> T.Text -> SpeedScopeEventType -> SpeedScopeFile -> SpeedScopeFile+appendSpeedScopeEvent time profileName eventName eventType initialFile = flip execState initialFile $ do+  (frameID, profileIndex) <- getFrameIDAndProfileIndex time profileName eventName +  modify' $ over (profiles . ix profileIndex . events) (S.|> (SpeedScopeEvent eventType frameID time))+          . over (profiles . ix profileIndex . endValue) (max time)++prependSpeedScopeEvent :: POSIXTime -> T.Text -> T.Text -> SpeedScopeEventType -> SpeedScopeFile -> SpeedScopeFile+prependSpeedScopeEvent time profileName eventName eventType initialFile = flip execState initialFile $ do+  (frameID, profileIndex) <- getFrameIDAndProfileIndex time profileName eventName++  modify' $ over (profiles . ix profileIndex . events) ((SpeedScopeEvent eventType frameID time) S.<|)+          . over (profiles . ix profileIndex . startValue) (min time)+ -- | TODO: maybe use an intermediate format so the frames (and possibly profiles) aren't stored as lists, -- so we don't have to do O(N) L.length and S.findIndexL-handleSpeedScopeEvent :: SpeedScopeFile -> POSIXTime -> T.Text -> T.Text -> SpeedScopeEventType -> SpeedScopeFile-handleSpeedScopeEvent initialFile time profileName eventName eventType = flip execState initialFile $ do+getFrameIDAndProfileIndex :: POSIXTime -> T.Text -> T.Text -> State SpeedScopeFile (Int, Int)+getFrameIDAndProfileIndex time profileName eventName = do   frameID <- get >>= \f -> case S.findIndexL (== SpeedScopeFrame eventName) (f ^. shared . frames) of     Just j -> return j     Nothing -> do@@ -173,5 +208,4 @@       modify' $ over profiles (\x -> x <> [newProfile profileName time])       return $ L.length (f ^. profiles) -  modify' $ over (profiles . ix profileIndex . events) (S.|> (SpeedScopeEvent eventType frameID time))-          . over (profiles . ix profileIndex . endValue) (max time)+  return (frameID, profileIndex)

@@ -56,9 +56,18 @@   , optRepeatCount :: Int   , optFixedRoot :: Maybe String   , optDryRun :: Maybe Bool+  , optWarnOnLongExecutionMs :: Maybe Int+  , optCancelOnLongExecutionMs :: Maybe Int   , optMarkdownSummaryPath :: Maybe FilePath+  , optTuiDebugSocket :: Bool+  , optSocketFormatter :: Bool+  , optLogLogs :: Bool+  , optLogEvents :: Bool+  , optLogRtsStats :: Bool+  , optLogAsyncs :: Bool    , optListAvailableTests :: Maybe Bool+  , optListAvailableTestsJson :: Maybe Bool   , optPrintGoldenFlags :: Maybe Bool   , optPrintQuickCheckFlags :: Maybe Bool   , optPrintHedgehogFlags :: Maybe Bool

@@ -23,6 +23,7 @@ import Data.Time import Data.Typeable import GHC.Stack+import System.IO (Handle) import Test.Sandwich.Types.ArgParsing import Test.Sandwich.Types.Spec import Test.Sandwich.Types.TestTimer@@ -111,13 +112,31 @@  type Var = TVar data LogEntry = LogEntry {-  logEntryTime :: UTCTime-  , logEntryLoc :: Loc-  , logEntrySource :: LogSource-  , logEntryLevel :: LogLevel-  , logEntryStr :: LogStr+  logEntryTime :: !UTCTime+  , logEntryLoc :: !Loc+  , logEntrySource :: !LogSource+  , logEntryLevel :: !LogLevel+  , logEntryStr :: !BS8.ByteString   } deriving (Show, Eq) +data NodeEvent = NodeEvent {+  nodeEventTime :: !UTCTime+  , nodeEventId :: !Int+  , nodeEventLabel :: !String+  , nodeEventType :: !NodeEventType+  } deriving (Show, Eq)++data NodeEventType+  = EventStarted+  | EventDone !Result+  | EventSetupStarted+  | EventSetupFinished+  | EventTeardownStarted+  | EventTeardownFinished+  | EventMilestone !String+  | EventEndOfStream+  deriving (Show, Eq)+ -- | Context passed around through the evaluation of a RunTree data RunTreeContext = RunTreeContext {   runTreeCurrentAncestors :: Seq Int@@ -136,6 +155,7 @@   , baseContextOnlyRunIds :: Maybe (S.Set Int)   , baseContextTestTimerProfile :: T.Text   , baseContextTestTimer :: TestTimer+  , baseContextRunId :: T.Text   }  -- | Has-* class for asserting a 'BaseContext' is available.@@ -228,7 +248,7 @@ type LogFn = Loc -> LogSource -> LogLevel -> LogStr -> IO ()  -- | A callback for formatting a log entry to a 'BS8.ByteString'.-type LogEntryFormatter = UTCTime -> Loc -> LogSource -> LogLevel -> LogStr -> BS8.ByteString+type LogEntryFormatter = UTCTime -> Loc -> LogSource -> LogLevel -> BS8.ByteString -> BS8.ByteString  -- The defaultLogStr formatter weirdly puts information after the message. Use our own defaultLogEntryFormatter :: LogEntryFormatter@@ -240,7 +260,7 @@   <> toLogStr src   <> ") "   <> (if isDefaultLoc loc then "" else "@(" <> toLogStr (BS8.pack fileLocStr) <> ") ")-  <> msg+  <> toLogStr msg   <> "\n"    where@@ -291,8 +311,20 @@   -- We use this hint to connect 'CallStack' paths (which are relative to the project root) to their actual path on disk.   , optionsTestTimerType :: TestTimerType   -- ^ Whether to enable the test timer. When the test timer is present, timing information will be emitted to the project root (if present).+  , optionsWarnOnLongExecutionMs :: Maybe Int+  -- ^ If set, alerts user to nodes that run for the given number of milliseconds, by writing to a file in the root directory.+  , optionsCancelOnLongExecutionMs :: Maybe Int+  -- ^ Same as 'optionsWarnOnLongExecutionMs', but also cancels the problematic nodes.+  , optionsLogBroadcast :: Maybe (TChan (Int, String, LogEntry))+  -- ^ Broadcast channel for streaming log entries to external consumers (e.g. socket formatter).+  -- Each entry is tagged with (nodeId, nodeLabel, logEntry).+  , optionsEventBroadcast :: Maybe (TChan NodeEvent)+  -- ^ Broadcast channel for streaming node lifecycle events (started, done) to external consumers.+  , optionsLateLogFile :: Maybe Handle+  -- ^ If set, log writes that occur after a node is already Done will be written to this file handle.+  , optionsRunId :: T.Text+  -- ^ An identifier for this test run, used to track managed async threads.   }-  -- | A wrapper type for exceptions with attached callstacks. Haskell doesn't currently offer a way -- to reliably get a callstack from an exception, but if you can throw (or catch+rethrow) this type

@@ -62,7 +62,7 @@   liftBase = liftBaseDefault  instance MonadTrans (ExampleT context) where-  lift x = ExampleT $ ReaderT (\_ -> (LoggingT (\_ -> x)))+  lift x = ExampleT $ ReaderT (const (LoggingT (const x)))  instance MonadTransControl (ExampleT context) where   type StT (ExampleT context) a = StT LoggingT (StT (ReaderT context) a)@@ -126,7 +126,7 @@                    | RawImage { failureCallStack :: Maybe CallStack                               , failureFallback :: String                               , failureRawImage :: Image }-  deriving (Show, Typeable, Eq)+  deriving (Show, Eq)  instance Exception FailureReason @@ -148,7 +148,7 @@  data Label (l :: Symbol) a = Label -data LabelValue (l :: Symbol) a = LabelValue { unLabelValue :: a }+newtype LabelValue (l :: Symbol) a = LabelValue { unLabelValue :: a }  -- TODO: get rid of overlapping instance -- Maybe look at https://kseo.github.io/posts/2017-02-05-avoid-overlapping-instances-with-closed-type-families.html

@@ -1,6 +1,5 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ConstraintKinds #-}@@ -23,7 +22,7 @@  -- * SpeedScope types -data SpeedScopeFrame = SpeedScopeFrame {+newtype SpeedScopeFrame = SpeedScopeFrame {   _name :: T.Text   } deriving (Show, Eq) $(deriveJSON (A.defaultOptions {@@ -32,7 +31,7 @@                  }) ''SpeedScopeFrame) $(makeLensesWith testTimerLensRules ''SpeedScopeFrame) -data SpeedScopeShared = SpeedScopeShared {+newtype SpeedScopeShared = SpeedScopeShared {   _frames :: Seq SpeedScopeFrame   } deriving Show $(deriveJSON (A.defaultOptions {@@ -119,7 +118,8 @@ -- * Main type  data TestTimer = SpeedScopeTestTimer {-  testTimerBasePath :: FilePath+  testTimerStartTime :: POSIXTime+  , testTimerBasePath :: FilePath   , testTimerHandle :: Maybe Handle   , testTimerSpeedScopeFile :: MVar SpeedScopeFile   } | NullTestTimer

@@ -19,6 +19,7 @@   ) where  import Control.Monad.IO.Unlift+import qualified Data.List as L import Data.String.Interpolate import Data.Time import Data.Typeable@@ -70,9 +71,12 @@       if #if MIN_VERSION_base(4,14,0)         | Just (_ :: Timeout) <- fromExceptionUnwrap e -> do-            throwIO $ Reason (Just (popCallStack callStack)) "Timeout in waitUntil"+            throwIO $ Reason (Just (popCallStackSafe callStack)) "Timeout in waitUntil"         | Just (SyncExceptionWrapper (cast -> Just (SomeException (cast -> Just (SomeAsyncException (cast -> Just (_ :: Timeout))))))) <- cast inner -> do-            throwIO $ Reason (Just (popCallStack callStack)) "Timeout in waitUntil"+            throwIO $ Reason (Just (popCallStackSafe callStack)) "Timeout in waitUntil" #endif         | otherwise -> do             throwIO e++popCallStackSafe :: CallStack -> CallStack+popCallStackSafe cs = if L.null (getCallStack cs) then cs else popCallStack cs

@@ -2,21 +2,31 @@  module Around where -import Control.Concurrent import Control.Monad import Control.Monad.IO.Class+import Control.Monad.IO.Unlift import Control.Monad.Trans.Writer import Data.String.Interpolate import GHC.Stack import Test.Sandwich+import Test.Sandwich.Internal import TestUtil+import UnliftIO.Async+import UnliftIO.Concurrent import UnliftIO.Exception+import UnliftIO.STM   tests :: MonadIO m => WriterT [SomeException] m () tests = do   run aroundDoesNotFailOnChildFailure   run aroundReceivesSubtreeResult+  run aroundSyncExceptionDuringAllocate+  run aroundSyncExceptionDuringTest+  run aroundSyncExceptionDuringCleanup+  run aroundAsyncExceptionDuringAllocate+  run aroundAsyncExceptionDuringTest+  run aroundAsyncExceptionDuringCleanup  main :: IO () main = mainWith tests@@ -37,10 +47,125 @@ aroundReceivesSubtreeResult = do   mvar <- newEmptyMVar -  _ <- runAndGetResults $ around "around label" (>>= (liftIO . putMVar mvar)) $ do+  _ <- runAndGetResults $ around "around label" (>>= (putMVar mvar)) $ do     it "does thing 1" $ 2 `shouldBe` (3 :: Int)     it "does thing 1" $ 2 `shouldBe` (2 :: Int)    takeMVar mvar >>= \case     [Failure {}, Success] -> return ()     xs -> error [i|Expected a failure and a success, but got '#{xs}'|]++-- | Sync exception during the allocate phase (the around handler throws before running+-- the children). The around node carries the contextual failure message; the children,+-- which never got a context, fail with a context exception.+aroundSyncExceptionDuringAllocate :: (HasCallStack) => IO ()+aroundSyncExceptionDuringAllocate = do+  results <- runAndGetResults $ around "around label" (\_ -> throwSomeUserError) $ do+    it "does thing 1" $ return ()++  results `mustBe` [Failure (GotException Nothing (Just "Exception in around 'around label' handler") someUserErrorWrapped)+                   , Failure (GetContextException Nothing someUserErrorWrapped)]++-- | Sync exception during the body (the test itself). The around node succeeds; only the+-- child fails.+aroundSyncExceptionDuringTest :: (HasCallStack) => IO ()+aroundSyncExceptionDuringTest = do+  results <- runAndGetResults $ around "around label" void $ do+    it "does thing 1" throwSomeUserError++  results `mustBe` [Success+                   , Failure (GotException Nothing Nothing someUserErrorWrapped)]++-- | Sync exception during the cleanup phase (the around handler throws after running the+-- children). The around node's own status carries the contextual failure message.+aroundSyncExceptionDuringCleanup :: (HasCallStack) => IO ()+aroundSyncExceptionDuringCleanup = do+  results <- runAndGetResults $ around "around label" (\action -> action >> throwSomeUserError) $ do+    it "does thing 1" $ return ()++  results `mustBe` [Failure (GotException Nothing (Just "Exception in around 'around label' handler") someUserErrorWrapped)+                   , Success]++-- | Async exception: cancel the around node while the allocate phase is running (before the+-- children are started). The around node is cancelled and the children, which never got a+-- context, fail with a context exception.+aroundAsyncExceptionDuringAllocate :: (HasCallStack) => IO ()+aroundAsyncExceptionDuringAllocate = do+  allocStarted <- newEmptyMVar++  rts <- startSandwichTree defaultOptions $ around "around label" (\_ -> putMVar allocStarted () >> sleepForever) $ do+    it "does thing 1" $ return ()++  topNode <- case rts of+    [x@(RunNodeAround {runNodeChildren=[RunNodeIt {}]})] -> pure x+    _ -> error "Unexpected rts"++  -- Wait until the allocate phase is running, then cancel the top level async+  takeMVar allocStarted+  cancelNode topNode++  -- Waiting for the tree should not throw an exception+  mapM_ waitForTree rts++  fixedTree <- atomically $ mapM fixRunTree rts+  let results = fmap statusToResult $ concatMap getStatuses fixedTree++  results `mustBe` [Failure (GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq $ SomeAsyncException AsyncCancelled))+                   , Failure (GetContextException Nothing (SomeExceptionWithEq (toException (SomeAsyncException AsyncCancelled))))]++-- | Async exception: cancel the around node while a child test is running.+-- Both the around node and the child should end up cancelled.+aroundAsyncExceptionDuringTest :: (HasCallStack) => IO ()+aroundAsyncExceptionDuringTest = do+  mvar <- newEmptyMVar++  rts <- startSandwichTree defaultOptions $ around "around label" void $ do+    it "does thing 1" $ do+      putMVar mvar ()+      sleepForever++  topNode <- case rts of+    [x@(RunNodeAround {runNodeChildren=[RunNodeIt {}]})] -> pure x+    _ -> error "Unexpected rts"++  -- Wait until we get into the actual test example, then cancel the top level async+  takeMVar mvar+  cancelNode topNode++  -- Waiting for the tree should not throw an exception+  mapM_ waitForTree rts++  fixedTree <- atomically $ mapM fixRunTree rts+  let results = fmap statusToResult $ concatMap getStatuses fixedTree++  results `mustBe` [Failure (GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq $ SomeAsyncException AsyncCancelled))+                   , Failure (GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq $ SomeAsyncException AsyncCancelled))]++-- | Async exception: cancel the around node while the cleanup phase is running (after the+-- children returned). The body already succeeded; the around node is cancelled.+aroundAsyncExceptionDuringCleanup :: (HasCallStack) => IO ()+aroundAsyncExceptionDuringCleanup = do+  cleanupStarted <- newEmptyMVar++  rts <- startSandwichTree defaultOptions $ around "around label" (\action -> action >> putMVar cleanupStarted () >> sleepForever) $ do+    it "does thing 1" $ return ()++  topNode <- case rts of+    [x@(RunNodeAround {runNodeChildren=[RunNodeIt {}]})] -> pure x+    _ -> error "Unexpected rts"++  -- Wait until the cleanup phase is running, then cancel the top level async+  takeMVar cleanupStarted+  cancelNode topNode++  -- Waiting for the tree should not throw an exception+  mapM_ waitForTree rts++  fixedTree <- atomically $ mapM fixRunTree rts+  let results = fmap statusToResult $ concatMap getStatuses fixedTree++  results `mustBe` [Failure (GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq $ SomeAsyncException AsyncCancelled))+                   , Success]++sleepForever :: MonadUnliftIO m => m ()+sleepForever = threadDelay 999999999999999

@@ -23,7 +23,7 @@ describeFailsWhenChildFails :: (HasCallStack) => IO () describeFailsWhenChildFails = do   results <- runAndGetResults $ describe "describe label" $ do-    it "does thing 1" $ throwSomeUserError+    it "does thing 1" throwSomeUserError     it "does thing 2" $ return ()    (results !! 0) `mustBe` (Failure (ChildrenFailed {failureCallStack = Nothing, failureNumChildren = 1}))

@@ -3,66 +3,106 @@ module Introduce where  -import Control.Concurrent-import Control.Concurrent.Async-import Control.Concurrent.STM import Control.Monad.IO.Class+import Control.Monad.IO.Unlift import Control.Monad.Trans.Writer import Data.Foldable import GHC.Stack import Test.Sandwich import Test.Sandwich.Internal+import UnliftIO.Async+import UnliftIO.Concurrent import UnliftIO.Exception+import UnliftIO.STM  import TestUtil  tests :: MonadIO m => WriterT [SomeException] m () tests = do-  run introduceCleansUpOnTestException-  run introduceDoesNotCleanUpOnAllocateException-  run introduceFailsOnCleanUpException-  run introduceCleansUpOnCancelDuringTest+  run introduceSyncExceptionDuringAllocate+  run introduceSyncExceptionDuringTest+  run introduceSyncExceptionDuringCleanup+  run introduceAsyncExceptionDuringAllocate+  run introduceAsyncExceptionDuringTest+  run introduceAsyncExceptionDuringCleanup  main :: IO () main = mainWith tests  -- * Tests -introduceCleansUpOnTestException :: (HasCallStack) => IO ()-introduceCleansUpOnTestException = do+-- | Sync exception during the allocate phase. Allocation failed, so cleanup does not run+-- and the child fails with a context exception.+introduceSyncExceptionDuringAllocate :: (HasCallStack) => IO ()+introduceSyncExceptionDuringAllocate = do+  (results, msgs) <- runAndGetResultsAndLogs $ introduce "introduce" fakeDatabaseLabel (throwSomeUserError >> return FakeDatabase) (\_ -> debug "doing cleanup") $ do+    it "does thing 1" $ return ()++  msgs `mustBe` [[], []]+  results `mustBe` [Failure (GotException Nothing (Just "Failure in introduce 'introduce' allocation handler") someUserErrorWrapped)+                   , Failure (GetContextException Nothing (SomeExceptionWithEq (SomeException (GotException Nothing (Just "Failure in introduce 'introduce' allocation handler") someUserErrorWrapped))))]++-- | Sync exception during the body (the test itself). Allocation succeeded, so cleanup+-- runs; the introduce node succeeds and only the child fails.+introduceSyncExceptionDuringTest :: (HasCallStack) => IO ()+introduceSyncExceptionDuringTest = do   (results, msgs) <- runAndGetResultsAndLogs $ introduce "introduce" fakeDatabaseLabel (return FakeDatabase) (\_ -> debug "doing cleanup") $ do-    it "does thing 1" $ throwSomeUserError+    it "does thing 1" throwSomeUserError    msgs `mustBe` [["doing cleanup"], []]   results `mustBe` [Success                    , Failure (GotException Nothing Nothing someUserErrorWrapped)] -introduceDoesNotCleanUpOnAllocateException :: (HasCallStack) => IO ()-introduceDoesNotCleanUpOnAllocateException = do-  (results, msgs) <- runAndGetResultsAndLogs $ introduce "introduce" fakeDatabaseLabel (throwSomeUserError >> return FakeDatabase) (\_ -> debug "doing cleanup") $ do+-- | Sync exception during the cleanup phase. The body already succeeded; only the+-- introduce node fails.+introduceSyncExceptionDuringCleanup :: (HasCallStack) => IO ()+introduceSyncExceptionDuringCleanup = do+  (results, msgs) <- runAndGetResultsAndLogs $ introduce "introduce" fakeDatabaseLabel (return FakeDatabase) (const throwSomeUserError) $ do     it "does thing 1" $ return ()    msgs `mustBe` [[], []]-  results `mustBe` [Failure (GotException Nothing (Just "Failure in introduce 'introduce' allocation handler") someUserErrorWrapped)-                   , Failure (GetContextException Nothing (SomeExceptionWithEq (SomeException (GotException Nothing (Just "Failure in introduce 'introduce' allocation handler") someUserErrorWrapped))))]+  results `mustBe` [Failure (GotException Nothing (Just "Failure in introduce 'introduce' cleanup handler") someUserErrorWrapped)+                   , Success] -introduceFailsOnCleanUpException :: (HasCallStack) => IO ()-introduceFailsOnCleanUpException = do-  (results, msgs) <- runAndGetResultsAndLogs $ introduce "introduce" fakeDatabaseLabel (return FakeDatabase) (\_ -> throwSomeUserError) $ do+-- | Async exception: cancel the introduce node while the allocate phase is running (before+-- the body). The node is cancelled, cleanup does not run, and the child, which never got a+-- context, fails with a context exception.+introduceAsyncExceptionDuringAllocate :: (HasCallStack) => IO ()+introduceAsyncExceptionDuringAllocate = do+  allocStarted <- newEmptyMVar++  rts <- startSandwichTree defaultOptions $ introduce "introduce" fakeDatabaseLabel (putMVar allocStarted () >> sleepForever >> return FakeDatabase) (\_ -> debug "doing cleanup") $ do     it "does thing 1" $ return () +  topNode <- case rts of+    [x@(RunNodeIntroduce {runNodeChildrenAugmented=[RunNodeIt {}]})] -> pure x+    _ -> error "Unexpected rts"++  -- Wait until the allocate phase is running, then cancel the top level async+  takeMVar allocStarted+  cancelNode topNode++  -- Waiting for the tree should not throw an exception+  mapM_ waitForTree rts++  fixedTree <- atomically $ mapM fixRunTree rts+  let results = fmap statusToResult $ concatMap getStatuses fixedTree+  let msgs = fmap (toList . (fmap logEntryStr)) $ concatMap getLogs fixedTree+   msgs `mustBe` [[], []]-  results `mustBe` [Failure (GotException Nothing (Just "Failure in introduce 'introduce' cleanup handler") someUserErrorWrapped)-                   , Success]+  results `mustBe` [Failure (GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq $ SomeAsyncException AsyncCancelled))+                   , Failure (GotAsyncException Nothing (Just "introduce introduce alloc handler got async exception") (SomeAsyncExceptionWithEq (SomeAsyncException AsyncCancelled)))] -introduceCleansUpOnCancelDuringTest :: (HasCallStack) => IO ()-introduceCleansUpOnCancelDuringTest = do+-- | Async exception: cancel the introduce node while a child test is running. Cleanup runs,+-- and both the introduce node and the child end up cancelled.+introduceAsyncExceptionDuringTest :: (HasCallStack) => IO ()+introduceAsyncExceptionDuringTest = do   mvar <- newEmptyMVar    rts <- startSandwichTree defaultOptions $ introduce "introduce" fakeDatabaseLabel (return FakeDatabase) (\_ -> debug "doing cleanup") $ do     it "does thing 1" $ do-      liftIO $ putMVar mvar ()-      liftIO $ threadDelay 999999999999999+      putMVar mvar ()+      sleepForever    topNode <- case rts of     [x@(RunNodeIntroduce {runNodeChildrenAugmented=[RunNodeIt {}]})] -> pure x@@ -73,7 +113,7 @@   cancelNode topNode    -- Waiting for the tree should not throw an exception-  _ <- mapM waitForTree rts+  mapM_ waitForTree rts    fixedTree <- atomically $ mapM fixRunTree rts   let results = fmap statusToResult $ concatMap getStatuses fixedTree@@ -82,3 +122,32 @@   msgs `mustBe` [["doing cleanup"], []]   results `mustBe` [Failure (GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq $ SomeAsyncException AsyncCancelled))                    , Failure (GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq $ SomeAsyncException AsyncCancelled))]++-- | Async exception: cancel the introduce node while the cleanup phase is running (after the+-- body returned). The body already succeeded; the introduce node is cancelled.+introduceAsyncExceptionDuringCleanup :: (HasCallStack) => IO ()+introduceAsyncExceptionDuringCleanup = do+  cleanupStarted <- newEmptyMVar++  rts <- startSandwichTree defaultOptions $ introduce "introduce" fakeDatabaseLabel (return FakeDatabase) (\_ -> putMVar cleanupStarted () >> sleepForever) $ do+    it "does thing 1" $ return ()++  topNode <- case rts of+    [x@(RunNodeIntroduce {runNodeChildrenAugmented=[RunNodeIt {}]})] -> pure x+    _ -> error "Unexpected rts"++  -- Wait until the cleanup phase is running, then cancel the top level async+  takeMVar cleanupStarted+  cancelNode topNode++  -- Waiting for the tree should not throw an exception+  mapM_ waitForTree rts++  fixedTree <- atomically $ mapM fixRunTree rts+  let results = fmap statusToResult $ concatMap getStatuses fixedTree++  results `mustBe` [Failure (GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq $ SomeAsyncException AsyncCancelled))+                   , Success]++sleepForever :: MonadUnliftIO m => m ()+sleepForever = threadDelay 999999999999999

@@ -2,41 +2,60 @@  module IntroduceWith where -+import Control.Monad import Control.Monad.IO.Class+import Control.Monad.IO.Unlift import Control.Monad.Trans.Writer import GHC.Stack import Test.Sandwich+import Test.Sandwich.Internal+import UnliftIO.Async+import UnliftIO.Concurrent import UnliftIO.Exception+import UnliftIO.STM  import TestUtil  tests :: MonadIO m => WriterT [SomeException] m () tests = do-  run introduceWithFailsOnAllocateException-  run introduceWithFailsOnCleanUpException+  run introduceWithSyncExceptionDuringAllocate+  run introduceWithSyncExceptionDuringTest+  run introduceWithSyncExceptionDuringCleanup+  run introduceWithAsyncExceptionDuringAllocate+  run introduceWithAsyncExceptionDuringTest+  run introduceWithAsyncExceptionDuringCleanup  main :: IO () main = mainWith tests  -- * Tests -introduceWithFailsOnAllocateException :: (HasCallStack) => IO ()-introduceWithFailsOnAllocateException = do-  (results, msgs) <- runAndGetResultsAndLogs $ introduceWith "introduce with" fakeDatabaseLabel withAction $ do+-- | Sync exception thrown during the allocate phase (before the body action is called).+-- Allocation failed, so the child fails with a context exception.+introduceWithSyncExceptionDuringAllocate :: (HasCallStack) => IO ()+introduceWithSyncExceptionDuringAllocate = do+  (results, msgs) <- runAndGetResultsAndLogs $ introduceWith "introduce with" fakeDatabaseLabel (\_ -> throwSomeUserError) $ do     it "does thing 1" $ return ()    msgs `mustBe` [[], []]   results `mustBe` [Failure (GotException Nothing (Just "Exception in introduceWith 'introduce with' handler") someUserErrorWrapped)                    , Failure (GetContextException Nothing someUserErrorWrapped)]-  where-    withAction action = do-      throwSomeUserError-      _ <- action FakeDatabase-      return () -introduceWithFailsOnCleanUpException :: (HasCallStack) => IO ()-introduceWithFailsOnCleanUpException = do+-- | Sync exception thrown during the body (the test itself). The introduceWith node+-- succeeds (allocation/cleanup were fine); only the child fails.+introduceWithSyncExceptionDuringTest :: (HasCallStack) => IO ()+introduceWithSyncExceptionDuringTest = do+  (results, msgs) <- runAndGetResultsAndLogs $ introduceWith "introduce with" fakeDatabaseLabel (\action -> void $ action FakeDatabase) $ do+    it "does thing 1" throwSomeUserError++  msgs `mustBe` [[], []]+  results `mustBe` [Success+                   , Failure (GotException Nothing Nothing someUserErrorWrapped)]++-- | Sync exception thrown during the cleanup phase (after the body action returned).+-- The body already succeeded; only the introduceWith node fails.+introduceWithSyncExceptionDuringCleanup :: (HasCallStack) => IO ()+introduceWithSyncExceptionDuringCleanup = do   (results, msgs) <- runAndGetResultsAndLogs $ introduceWith "introduce with" fakeDatabaseLabel withAction $ do     it "does thing 1" $ return () @@ -47,3 +66,87 @@     withAction action = do       _ <- action FakeDatabase       throwSomeUserError++-- | Async exception: cancel the introduceWith node while the allocate phase is running+-- (before the body action is called). The node is cancelled and the child, which never+-- got a context, fails with a context exception.+introduceWithAsyncExceptionDuringAllocate :: (HasCallStack) => IO ()+introduceWithAsyncExceptionDuringAllocate = do+  allocStarted <- newEmptyMVar++  rts <- startSandwichTree defaultOptions $ introduceWith "introduce with" fakeDatabaseLabel (\_ -> putMVar allocStarted () >> sleepForever) $ do+    it "does thing 1" $ return ()++  topNode <- case rts of+    [x@(RunNodeIntroduceWith {runNodeChildrenAugmented=[RunNodeIt {}]})] -> pure x+    _ -> error "Unexpected rts"++  -- Wait until the allocate phase is running, then cancel the top level async+  takeMVar allocStarted+  cancelNode topNode++  -- Waiting for the tree should not throw an exception+  mapM_ waitForTree rts++  fixedTree <- atomically $ mapM fixRunTree rts+  let results = fmap statusToResult $ concatMap getStatuses fixedTree++  results `mustBe` [Failure (GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq $ SomeAsyncException AsyncCancelled))+                   , Failure (GetContextException Nothing (SomeExceptionWithEq (toException (SomeAsyncException AsyncCancelled))))]++-- | Async exception: cancel the introduceWith node while a child test is running.+-- Both the introduceWith node and the child should end up cancelled.+introduceWithAsyncExceptionDuringTest :: (HasCallStack) => IO ()+introduceWithAsyncExceptionDuringTest = do+  mvar <- newEmptyMVar++  rts <- startSandwichTree defaultOptions $ introduceWith "introduce with" fakeDatabaseLabel (\action -> void $ action FakeDatabase) $ do+    it "does thing 1" $ do+      putMVar mvar ()+      sleepForever++  topNode <- case rts of+    [x@(RunNodeIntroduceWith {runNodeChildrenAugmented=[RunNodeIt {}]})] -> pure x+    _ -> error "Unexpected rts"++  -- Wait until we get into the actual test example, then cancel the top level async+  takeMVar mvar+  cancelNode topNode++  -- Waiting for the tree should not throw an exception+  mapM_ waitForTree rts++  fixedTree <- atomically $ mapM fixRunTree rts+  let results = fmap statusToResult $ concatMap getStatuses fixedTree++  results `mustBe` [Failure (GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq $ SomeAsyncException AsyncCancelled))+                   , Failure (GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq $ SomeAsyncException AsyncCancelled))]++-- | Async exception: cancel the introduceWith node while the cleanup phase is running+-- (after the body action returned). The body already succeeded; the node is cancelled.+introduceWithAsyncExceptionDuringCleanup :: (HasCallStack) => IO ()+introduceWithAsyncExceptionDuringCleanup = do+  cleanupStarted <- newEmptyMVar++  rts <- startSandwichTree defaultOptions $ introduceWith "introduce with" fakeDatabaseLabel (\action -> void (action FakeDatabase) >> putMVar cleanupStarted () >> sleepForever) $ do+    it "does thing 1" $ return ()++  topNode <- case rts of+    [x@(RunNodeIntroduceWith {runNodeChildrenAugmented=[RunNodeIt {}]})] -> pure x+    _ -> error "Unexpected rts"++  -- Wait until the cleanup phase is running, then cancel the top level async+  takeMVar cleanupStarted+  cancelNode topNode++  -- Waiting for the tree should not throw an exception+  mapM_ waitForTree rts++  fixedTree <- atomically $ mapM fixRunTree rts+  let results = fmap statusToResult $ concatMap getStatuses fixedTree++  results `mustBe` [Failure (GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq $ SomeAsyncException AsyncCancelled))+                   , Success]++sleepForever :: MonadUnliftIO m => m ()+sleepForever = threadDelay 999999999999999

@@ -4,6 +4,7 @@ module TestUtil where  import Control.Concurrent.STM+import qualified Data.ByteString.Char8 as BS8 import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Trans.Writer@@ -44,8 +45,8 @@  -- * Helpers -run :: (HasCallStack, MonadIO m) => IO () -> WriterT [SomeException] m ()-run test = (liftIO $ tryAny test) >>= \case+run :: (MonadIO m) => IO () -> WriterT [SomeException] m ()+run test = liftIO (tryAny test) >>= \case   Left err -> tell [err]   Right () -> return () @@ -58,7 +59,7 @@   fixedTree <- atomically $ mapM fixRunTree finalTree   return $ fmap statusToResult $ concatMap getStatuses fixedTree -runAndGetResultsAndLogs :: (HasCallStack) => CoreSpec -> IO ([Result], [[LogStr]])+runAndGetResultsAndLogs :: (HasCallStack) => CoreSpec -> IO ([Result], [[BS8.ByteString]]) runAndGetResultsAndLogs spec = do   finalTree <- runSandwichTree defaultOptions spec   getResultsAndMessages <$> fixTree finalTree@@ -66,13 +67,13 @@ fixTree :: [RunNode context] -> IO [RunNodeFixed context] fixTree rts = atomically $ mapM fixRunTree rts -getResultsAndMessages :: (HasCallStack) => [RunNodeFixed context] -> ([Result], [[LogStr]])+getResultsAndMessages :: (HasCallStack) => [RunNodeFixed context] -> ([Result], [[BS8.ByteString]]) getResultsAndMessages fixedTree = (results, msgs)   where     results = fmap statusToResult $ concatMap getStatuses fixedTree     msgs = getMessages fixedTree -getMessages :: (HasCallStack) => [RunNodeFixed context] -> [[LogStr]]+getMessages :: [RunNodeFixed context] -> [[BS8.ByteString]] getMessages fixedTree = fmap (toList . (fmap logEntryStr)) $ concatMap getLogs fixedTree  getStatuses :: RunNodeWithStatus context s l t -> [(String, s)]