sandwich 0.2.2.0 → 0.3.0.0

raw patch · 56 files changed

+668/−311 lines, 56 filesdep +unliftiodep −lifted-asyncdep −safe-exceptionsPVP ok

version bump matches the API change (PVP)

Dependencies added: unliftio

Dependencies removed: lifted-async, safe-exceptions

API changes (from Hackage documentation)

Files

• CHANGELOG.md +13/−1
• LICENSE +1/−1
• app/Main.hs +1/−1
• sandwich.cabal +11/−14
• src/Test/Sandwich.hs +15/−8
• src/Test/Sandwich/ArgParsing.hs +7/−4
• src/Test/Sandwich/Contexts.hs +20/−9
• src/Test/Sandwich/Expectations.hs +32/−24
• src/Test/Sandwich/Formatters/Common/Count.hs +7/−7
• src/Test/Sandwich/Formatters/Common/Util.hs +6/−6
• src/Test/Sandwich/Formatters/FailureReport.hs +1/−2
• src/Test/Sandwich/Formatters/LogSaver.hs +1/−1
• src/Test/Sandwich/Formatters/MarkdownSummary.hs +1/−3
• src/Test/Sandwich/Formatters/Print.hs +3/−3
• src/Test/Sandwich/Formatters/Print/CallStacks.hs +11/−0
• src/Test/Sandwich/Formatters/Print/Color.hs +1/−0
• src/Test/Sandwich/Formatters/Print/FailureReason.hs +1/−1
• src/Test/Sandwich/Formatters/Print/Logs.hs +4/−0
• src/Test/Sandwich/Formatters/Print/PrintPretty.hs +10/−3
• src/Test/Sandwich/Formatters/Print/Printing.hs +1/−0
• src/Test/Sandwich/Formatters/Print/Util.hs +3/−1
• src/Test/Sandwich/Formatters/TerminalUI.hs +16/−11
• src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs +2/−4
• src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs +16/−2
• src/Test/Sandwich/Formatters/TerminalUI/Draw.hs +3/−1
• src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs +5/−3
• src/Test/Sandwich/Formatters/TerminalUI/Draw/RunTimes.hs +4/−2
• src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs +1/−1
• src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs +1/−1
• src/Test/Sandwich/Formatters/TerminalUI/Filter.hs +1/−1
• src/Test/Sandwich/Formatters/TerminalUI/Keys.hs +1/−0
• src/Test/Sandwich/Golden.hs +4/−2
• src/Test/Sandwich/Golden/Update.hs +4/−2
• src/Test/Sandwich/Internal.hs +10/−2
• src/Test/Sandwich/Internal/Inspection.hs +42/−0
• src/Test/Sandwich/Internal/Running.hs +4/−4
• src/Test/Sandwich/Interpreters/RunTree.hs +91/−57
• src/Test/Sandwich/Interpreters/RunTree/Util.hs +9/−14
• src/Test/Sandwich/Interpreters/StartTree.hs +11/−11
• src/Test/Sandwich/Logging.hs +31/−31
• src/Test/Sandwich/Misc.hs +3/−0
• src/Test/Sandwich/ParallelN.hs +31/−14
• src/Test/Sandwich/RunTree.hs +2/−2
• src/Test/Sandwich/TH.hs +1/−0
• src/Test/Sandwich/TH/HasMainFunction.hs +4/−3
• src/Test/Sandwich/TH/ModuleMap.hs +3/−1
• src/Test/Sandwich/TestTimer.hs +29/−10
• src/Test/Sandwich/Types/RunTree.hs +30/−16
• src/Test/Sandwich/Types/Spec.hs +78/−19
• src/Test/Sandwich/Types/TestTimer.hs +2/−0
• src/Test/Sandwich/Waits.hs +70/−0
• test/Around.hs +1/−1
• test/Before.hs +1/−1
• test/Describe.hs +1/−1
• test/Introduce.hs +1/−1
• test/TestUtil.hs +5/−4

@@ -1,6 +1,18 @@ # Changelog for sandwich -## Unreleased changes+## 0.3.0.0++* Make createProcessWithLogging, readCreateProcessWithLogging etc. log with the callstack from the line where they're called (and not an internal line).+* Support GHC 9.8+* BREAKING CHANGE: switch most monads away from using `MonadBaseControl IO` and switch to `MonadUnliftIO`. We also remove `MonadThrow` constraints, relying only on `MonadIO` for throwing exceptions.+* Add support for `sandwich-contexts`, which is released with this version.+* Add more `HasCallStack` to introduce nodes.+* Add `getContextMaybe`, an optional version of `getContext`.+* Fix an issue with name collisions of test tree folders.+* Add `shouldBeSet` to `Test.Sandwich.Expectations`, for testing that lists are equal as sets.+* Tweak some default visibility thresholds.+* Improve openFileExplorerFolderPortable on Windows.+* Add `waitUntil` function in `Test.Sandwich.Waits`.  ## 0.2.2.0 

@@ -1,4 +1,4 @@-Copyright Tom McLaughlin (c) 2023+Copyright Tom McLaughlin (c) 2024  All rights reserved. 

@@ -5,7 +5,7 @@ module Main where  import Control.Concurrent-import Control.Exception.Safe+import UnliftIO.Exception import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger (LogLevel(..))

@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0.+-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack  name:           sandwich-version:        0.2.2.0+version:        0.3.0.0 synopsis:       Yet another test framework for Haskell description:    Please see the <https://codedownio.github.io/sandwich documentation>. category:       Testing@@ -13,7 +13,7 @@ bug-reports:    https://github.com/codedownio/sandwich/issues author:         Tom McLaughlin maintainer:     tom@codedown.io-copyright:      2023 Tom McLaughlin+copyright:      2024 Tom McLaughlin license:        BSD3 license-file:   LICENSE build-type:     Simple@@ -42,6 +42,7 @@       Test.Sandwich.Internal       Test.Sandwich.TH       Test.Sandwich.Util.Process+      Test.Sandwich.Waits   other-modules:       Test.Sandwich.ArgParsing       Test.Sandwich.Formatters.Common.Count@@ -70,6 +71,7 @@       Test.Sandwich.Formatters.TerminalUI.Types       Test.Sandwich.Golden.Update       Test.Sandwich.Internal.Formatters+      Test.Sandwich.Internal.Inspection       Test.Sandwich.Internal.Running       Test.Sandwich.Interpreters.FilterTree       Test.Sandwich.Interpreters.FilterTreeModule@@ -107,7 +109,7 @@       RecordWildCards       ScopedTypeVariables       ViewPatterns-  ghc-options: -W+  ghc-options: -Wall   build-depends:       aeson     , ansi-terminal@@ -123,7 +125,6 @@     , filepath     , free     , haskell-src-exts-    , lifted-async     , microlens     , microlens-th     , monad-control@@ -134,7 +135,6 @@     , process     , retry     , safe-    , safe-exceptions     , stm     , string-interpolate     , template-haskell@@ -142,6 +142,7 @@     , time     , transformers     , transformers-base+    , unliftio     , unliftio-core     , vector     , vty >=6@@ -187,7 +188,6 @@     , filepath     , free     , haskell-src-exts-    , lifted-async     , microlens     , microlens-th     , monad-control@@ -198,7 +198,6 @@     , process     , retry     , safe-    , safe-exceptions     , sandwich     , stm     , string-interpolate@@ -207,6 +206,7 @@     , time     , transformers     , transformers-base+    , unliftio     , unliftio-core     , vector     , vty >=6@@ -249,7 +249,6 @@     , filepath     , free     , haskell-src-exts-    , lifted-async     , microlens     , microlens-th     , monad-control@@ -260,7 +259,6 @@     , process     , retry     , safe-    , safe-exceptions     , sandwich     , stm     , string-interpolate@@ -269,6 +267,7 @@     , time     , transformers     , transformers-base+    , unliftio     , unliftio-core     , vector     , vty >=6@@ -316,7 +315,6 @@     , filepath     , free     , haskell-src-exts-    , lifted-async     , microlens     , microlens-th     , monad-control@@ -327,7 +325,6 @@     , process     , retry     , safe-    , safe-exceptions     , sandwich     , stm     , string-interpolate@@ -336,6 +333,7 @@     , time     , transformers     , transformers-base+    , unliftio     , unliftio-core     , vector     , vty >=6@@ -384,7 +382,6 @@     , filepath     , free     , haskell-src-exts-    , lifted-async     , microlens     , microlens-th     , monad-control@@ -395,7 +392,6 @@     , process     , retry     , safe-    , safe-exceptions     , sandwich     , stm     , string-interpolate@@ -404,6 +400,7 @@     , time     , transformers     , transformers-base+    , unliftio     , unliftio-core     , vector     , vty >=6

@@ -45,6 +45,9 @@   , around   , aroundEach +  -- * Parallel nodes+  , module Test.Sandwich.ParallelN+   -- * Timing   --   -- | For timing actions within your tests. Test tree nodes are timed by default.@@ -60,14 +63,12 @@   , module Test.Sandwich.Misc   , module Test.Sandwich.Nodes   , module Test.Sandwich.Options-  , module Test.Sandwich.ParallelN   , module Test.Sandwich.TH   ) where  import Control.Concurrent.Async import Control.Concurrent.STM import qualified Control.Exception as E-import Control.Exception.Safe import Control.Monad import Control.Monad.Free import Control.Monad.IO.Class@@ -108,9 +109,10 @@ import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec import Test.Sandwich.Types.TestTimer+import UnliftIO.Exception  #ifdef mingw32_HOST_OS-import System.Win32.Console+import System.Win32.Console (setConsoleOutputCP) #endif  @@ -153,16 +155,21 @@          updateGolden (optGoldenDir (optGoldenOptions clo))      | otherwise -> do          -- Awkward, but we need a specific context type to call countItNodes-         let totalTests = countItNodes (spec :: SpecFree (LabelValue "commandLineOptions" (CommandLineOptions a) :> BaseContext) IO ())+         let totalTests = countItNodes (spec :: SpecFree (LabelValue "someCommandLineOptions" SomeCommandLineOptions :> LabelValue "commandLineOptions" (CommandLineOptions a) :> BaseContext) IO ()) +         let cliNodeOptions = defaultNodeOptions { nodeOptionsVisibilityThreshold = systemVisibilityThreshold+                                                 , nodeOptionsCreateFolder = False }+          runWithRepeat repeatCount totalTests $            case optIndividualTestModule clo of              Nothing -> runSandwich' (Just $ clo { optUserOptions = () }) options $-               introduce' (defaultNodeOptions { nodeOptionsVisibilityThreshold = systemVisibilityThreshold-                                              , nodeOptionsCreateFolder = False }) "command line options" commandLineOptions (pure clo) (const $ return ()) spec+               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' (defaultNodeOptions { nodeOptionsVisibilityThreshold = systemVisibilityThreshold-                                              , nodeOptionsCreateFolder = False }) "command line options" commandLineOptions (pure clo) (const $ return ()) spec+               introduce' cliNodeOptions "some command line options" someCommandLineOptions (pure (SomeCommandLineOptions clo)) (const $ return ())+                 $ introduce' cliNodeOptions "command line options" commandLineOptions (pure clo) (const $ return ())+                 $ spec              Just (IndividualTestMainFn x) -> do                let individualTestFlagStrings = [[ Just ("--" <> shorthand), const ("--" <> shorthand <> "-main") <$> nodeModuleInfoFn ]                                                | (NodeModuleInfo {..}, shorthand) <- modulesAndShorthands]

@@ -10,6 +10,7 @@ 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@@ -29,8 +30,10 @@  #if MIN_VERSION_time(1,9,0) import Data.Time.Format.ISO8601+formatTime :: UTCTime -> String formatTime = T.unpack . T.replace ":" "_" . T.pack . iso8601Show #else+formatTime :: UTCTime -> String formatTime = show #endif @@ -75,7 +78,7 @@ webDriverOptionsWithInfo = OA.info (commandLineWebdriverOptions mempty <**> helper)   (     fullDesc-    <> progDesc "Special options passed to the WebDriver formatter, if present.\n\nIf a flag is passed, it will override the value in the WdOptions configured in the code."+    <> progDesc "Special options passed to the WebDriver integration, if present.\n\nIf a flag is passed, it will override the value in the WdOptions configured in the code."     <> header "WebDriver flags"   ) @@ -188,18 +191,18 @@  -- * Parse command line args -parseCommandLineArgs :: forall a. (Typeable a) => Parser a -> TopSpecWithOptions' a -> IO (CommandLineOptions a)+parseCommandLineArgs :: forall a. Typeable a => Parser a -> TopSpecWithOptions' a -> IO (CommandLineOptions a) parseCommandLineArgs parser spec = do   (clo, _, _) <- parseCommandLineArgs' parser spec   return clo -parseCommandLineArgs' :: forall a. (Typeable a) => Parser a -> TopSpecWithOptions' a -> IO (+parseCommandLineArgs' :: forall a. Typeable a => Parser a -> TopSpecWithOptions' a -> IO (   CommandLineOptions a   , Mod FlagFields (Maybe IndividualTestModule) -> Parser (Maybe IndividualTestModule)   , [(NodeModuleInfo, T.Text)]   ) parseCommandLineArgs' userOptionsParser spec = do-  let modulesAndShorthands = gatherMainFunctions (spec :: SpecFree (LabelValue "commandLineOptions" (CommandLineOptions a) :> BaseContext) IO ())+  let modulesAndShorthands = gatherMainFunctions (spec :: SpecFree (LabelValue "someCommandLineOptions" SomeCommandLineOptions :> LabelValue "commandLineOptions" (CommandLineOptions a) :> BaseContext) IO ())                            & L.sortOn nodeModuleInfoModuleName                            & gatherShorthands   let individualTestFlags maybeInternal =

@@ -6,46 +6,57 @@ module Test.Sandwich.Contexts where  import Control.Monad.Reader-import GHC.Stack+import Data.Typeable+import GHC.TypeLits (KnownSymbol) import Test.Sandwich.Types.ArgParsing import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec   -- | Get a context by its label.-getContext :: (Monad m, HasLabel context l a, HasCallStack, MonadReader context m) => Label l a -> m a+getContext :: (HasLabel context l a, MonadReader context m) => Label l a -> m a getContext = asks . getLabelValue +-- | Try to get a context by its label. If not is in scope, returns 'Nothing'.+getContextMaybe :: (MonadReader context m, KnownSymbol l, Typeable context, Typeable a) => Label l a -> m (Maybe a)+getContextMaybe = asks . getLabelValueMaybe+ -- | Get the root folder of the on-disk test tree for the current run. -- Will be 'Nothing' if the run isn't configured to use the disk.-getRunRoot :: (Monad m, HasBaseContext context, MonadReader context m) => m (Maybe FilePath)+getRunRoot :: (HasBaseContextMonad context m) => m (Maybe FilePath) getRunRoot = asks (baseContextRunRoot . getBaseContext)  -- | Get the on-disk folder corresponding to the current node. -- Will be 'Nothing' if the run isn't configured to use the disk, or if the current node is configured -- not to create a folder.-getCurrentFolder :: (HasBaseContext context, MonadReader context m, MonadIO m) => m (Maybe FilePath)+getCurrentFolder :: (HasBaseContextMonad context m) => m (Maybe FilePath) getCurrentFolder = asks (baseContextPath . getBaseContext)  -- | Get the command line options, if configured. -- Using the 'runSandwichWithCommandLineArgs' family of main functions will introduce these, or you can--- introduce them manually-getCommandLineOptions :: forall a context m. (HasCommandLineOptions context a, MonadReader context m, MonadIO m) => m (CommandLineOptions a)+-- introduce them manually.+getCommandLineOptions :: forall a context m. (HasCommandLineOptions context a, MonadReader context m) => m (CommandLineOptions a) getCommandLineOptions = getContext commandLineOptions +-- | Get existentially wrapped command line options, if configured.+-- Using the 'runSandwichWithCommandLineArgs' family of main functions will introduce these, or you can+-- introduce them manually.+getSomeCommandLineOptions :: forall context m. (HasSomeCommandLineOptions context, MonadReader context m) => m SomeCommandLineOptions+getSomeCommandLineOptions = getContext someCommandLineOptions+ -- | Get the user command line options, if configured. -- This just calls 'getCommandLineOptions' and pulls out the user options.-getUserCommandLineOptions :: (HasCommandLineOptions context a, MonadReader context m, MonadIO m) => m a+getUserCommandLineOptions :: (HasCommandLineOptions context a, MonadReader context m) => m a getUserCommandLineOptions = optUserOptions <$> getContext commandLineOptions  -- * Low-level context management helpers  -- | Push a label to the context.-pushContext :: forall m l a intro context. (Monad m) => Label l intro -> intro -> ExampleT (LabelValue l intro :> context) m a -> ExampleT context m a+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  -- | Remove a label from the context.-popContext :: forall m l a intro context. (Monad m) => Label l intro -> ExampleT context m a -> ExampleT (LabelValue l intro :> context) m a+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

@@ -4,52 +4,54 @@  module Test.Sandwich.Expectations where -import Control.Exception.Safe import Control.Monad.IO.Class+import Control.Monad.IO.Unlift import qualified Data.List as L+import qualified Data.Set as Set import Data.String.Interpolate import qualified Data.Text as T import GHC.Stack import Test.Sandwich.Types.Spec+import UnliftIO.Exception  -- * Manually fail a test or mark as pending  -- | General-purpose function to throw a test exception with a 'String'.-expectationFailure :: (HasCallStack, MonadThrow m) => String -> m a+expectationFailure :: (HasCallStack, MonadIO m) => String -> m a expectationFailure = throwIO . Reason (Just callStack)  -- | Throws a 'Pending' exception, which will cause the test to be marked as pending.-pending :: (HasCallStack, MonadThrow m) => m a+pending :: (HasCallStack, MonadIO m) => m a pending = throwIO $ Pending (Just callStack) Nothing  -- | Throws a 'Pending' exception with a message to add additional details.-pendingWith :: (HasCallStack, MonadThrow m) => String -> m a+pendingWith :: (HasCallStack, MonadIO m) => String -> m a pendingWith msg = throwIO $ Pending (Just callStack) (Just msg)  -- | Shorthand for a pending test example. You can quickly mark an 'it' node as pending by putting an "x" in front of it.-xit :: (HasCallStack, Monad m, MonadThrow m) => String -> ExampleT context m1 () -> SpecFree context m ()+xit :: (HasCallStack, MonadIO m) => String -> ExampleT context m1 () -> SpecFree context m () xit name _ex = it name (throwIO $ Pending (Just callStack) Nothing)  -- * Expecting failures  -- | Assert that a given action should fail with some 'FailureReason'.-shouldFail :: (HasCallStack, MonadCatch m, MonadThrow m) => m () -> m ()+shouldFail :: (HasCallStack, MonadUnliftIO m) => m () -> m () shouldFail action = do   try action >>= \case     Left (_ :: FailureReason) -> return ()     Right () -> expectationFailure [i|Expected test to fail|]  -- | Assert that a given action should fail with some 'FailureReason' matching a predicate.-shouldFailPredicate :: (HasCallStack, MonadCatch m, MonadThrow m) => (FailureReason -> Bool) -> m () -> m ()-shouldFailPredicate pred action = do+shouldFailPredicate :: (HasCallStack, MonadUnliftIO m) => (FailureReason -> Bool) -> m () -> m ()+shouldFailPredicate p action = do   try action >>= \case-    Left (err :: FailureReason) -> case pred err of+    Left (err :: FailureReason) -> case p err of       True -> return ()       False -> expectationFailure [i|Expected test to fail with a failure matching the predicate, but got a different failure: '#{err}'|]     Right () -> expectationFailure [i|Expected test to fail, but it succeeded|]  -- | Asserts that an action should throw an exception. Accepts a predicate to determine if the exception matches.-shouldThrow :: (HasCallStack, MonadThrow m, MonadCatch m, MonadIO m, Exception e) =>+shouldThrow :: (HasCallStack, MonadUnliftIO m, Exception e) =>   m a   -- ^ The action to run.   -> (e -> Bool)@@ -64,65 +66,71 @@ -- * Assertions  -- | Asserts that two things are equal.-shouldBe :: (HasCallStack, MonadThrow m, Eq a, Show a) => a -> a -> m ()+shouldBe :: (HasCallStack, MonadIO m, Eq a, Show a) => a -> a -> m () shouldBe x y   | x == y = return ()   | otherwise = throwIO (ExpectedButGot (Just callStack) (SEB y) (SEB x))  -- | Asserts that two things are not equal.-shouldNotBe :: (HasCallStack, MonadThrow m, Eq a, Show a) => a -> a -> m ()+shouldNotBe :: (HasCallStack, MonadIO m, Eq a, Show a) => a -> a -> m () shouldNotBe x y   | x /= y = return ()   | otherwise = throwIO (DidNotExpectButGot (Just callStack) (SEB y))  -- | Asserts that the given list contains a subsequence.-shouldContain :: (HasCallStack, MonadThrow m, Eq a, Show a) => [a] -> [a] -> m ()+shouldContain :: (HasCallStack, MonadIO m, Eq a, Show a) => [a] -> [a] -> m () shouldContain haystack needle = case needle `L.isInfixOf` haystack of   True -> return ()   False -> expectationFailure [i|Expected #{show haystack} to contain #{show needle}|] -- TODO: custom exception type  -- | Asserts that the given list contains an item matching a predicate.-shouldContainPredicate :: (HasCallStack, MonadThrow m, Eq a, Show a) => [a] -> (a -> Bool) -> m ()-shouldContainPredicate haystack pred = case L.find pred haystack of+shouldContainPredicate :: (HasCallStack, MonadIO m, Show a) => [a] -> (a -> Bool) -> m ()+shouldContainPredicate haystack p = case L.find p haystack of   Just _ -> return ()   Nothing -> expectationFailure [i|Expected #{show haystack} to contain an item matching the predicate|]  -- | Asserts that the given list does not contain a subsequence.-shouldNotContain :: (HasCallStack, MonadThrow m, Eq a, Show a) => [a] -> [a] -> m ()+shouldNotContain :: (HasCallStack, MonadIO m, Eq a, Show a) => [a] -> [a] -> m () shouldNotContain haystack needle = case needle `L.isInfixOf` haystack of   True -> expectationFailure [i|Expected #{show haystack} not to contain #{show needle}|]   False -> return () +-- | Asserts that the given lists are equal as sets.+shouldBeSet :: (HasCallStack, MonadIO m, Ord a, Show a) => [a] -> [a] -> m ()+shouldBeSet haystack needle = case Set.fromList needle == Set.fromList haystack of+  True -> return ()+  False -> expectationFailure [i|Expected #{show haystack} to equal as a set #{show needle}|]+ -- | Asserts that the given list contains an item matching a predicate.-shouldNotContainPredicate :: (HasCallStack, MonadThrow m, Eq a, Show a) => [a] -> (a -> Bool) -> m ()-shouldNotContainPredicate haystack pred = case L.find pred haystack of+shouldNotContainPredicate :: (HasCallStack, MonadIO m, Show a) => [a] -> (a -> Bool) -> m ()+shouldNotContainPredicate haystack p = case L.find p haystack of   Nothing -> return ()   Just _ -> expectationFailure [i|Expected #{show haystack} not to contain an item matching the predicate|]  -- | Asserts that the given 'Maybe' is 'Nothing'.-shouldBeNothing :: (HasCallStack, MonadThrow m, Show a) => Maybe a -> m ()+shouldBeNothing :: (HasCallStack, MonadIO m, Show a) => Maybe a -> m () shouldBeNothing Nothing = return () shouldBeNothing x = expectationFailure [i|Expected Nothing but got #{x}|]  -- | Asserts that the given 'Maybe' is 'Just'.-shouldBeJust :: (HasCallStack, MonadThrow m, Show a) => Maybe a -> m ()+shouldBeJust :: (HasCallStack, MonadIO m) => Maybe a -> m () shouldBeJust (Just _) = return () shouldBeJust Nothing = expectationFailure [i|Expected Just but got Nothing.|]  -- | Asserts that the given 'Either' is 'Left'.-shouldBeLeft :: (HasCallStack, MonadThrow m, Show a, Show b) => Either a b -> m ()+shouldBeLeft :: (HasCallStack, MonadIO m, Show a, Show b) => Either a b -> m () shouldBeLeft (Left _) = return () shouldBeLeft x = expectationFailure [i|Expected Left but got #{x}|]  -- | Asserts that the given 'Either' is 'Right'.-shouldBeRight :: (HasCallStack, MonadThrow m, Show a, Show b) => Either a b -> m ()+shouldBeRight :: (HasCallStack, MonadIO m, Show a, Show b) => Either a b -> m () shouldBeRight (Right _) = return () shouldBeRight x = expectationFailure [i|Expected Right but got #{x}.|]  -- | Asserts that the given text contains a substring.-textShouldContain :: (HasCallStack, MonadThrow m) => T.Text -> T.Text -> m ()+textShouldContain :: (HasCallStack, MonadIO m) => T.Text -> T.Text -> m () t `textShouldContain` txt = ((T.unpack t) :: String) `shouldContain` (T.unpack txt)  -- | Asserts that the given text does not contain a substring.-textShouldNotContain :: (HasCallStack, MonadThrow m) => T.Text -> T.Text -> m ()+textShouldNotContain :: (HasCallStack, MonadIO m) => T.Text -> T.Text -> m () t `textShouldNotContain` txt = ((T.unpack t) :: String) `shouldNotContain` (T.unpack txt)

@@ -1,19 +1,19 @@ {-# LANGUAGE RankNTypes #-}--- |+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}  module Test.Sandwich.Formatters.Common.Count where  import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec -countWhere :: (forall context. RunNodeWithStatus context s l t -> Bool) -> [RunNodeWithStatus context s l t] -> Int+countWhere :: (forall ctx. RunNodeWithStatus ctx s l t -> Bool) -> [RunNodeWithStatus context s l t] -> Int countWhere p rts = sum $ fmap (countWhere' p) rts   where-    countWhere' :: (forall context. RunNodeWithStatus context s l t -> Bool) -> RunNodeWithStatus context s l t -> Int-    countWhere' p rt@(RunNodeIt {..}) = if p rt then 1 else 0-    countWhere' p rt@(RunNodeIntroduce {..}) = (if p rt then 1 else 0) + countWhere p runNodeChildrenAugmented-    countWhere' p rt@(RunNodeIntroduceWith {..}) = (if p rt then 1 else 0) + countWhere p runNodeChildrenAugmented-    countWhere' p rt = (if p rt then 1 else 0) + countWhere p (runNodeChildren rt)+    countWhere' :: (forall ctx. RunNodeWithStatus ctx s l t -> Bool) -> RunNodeWithStatus context s l t -> Int+    countWhere' p' rt@(RunNodeIt {}) = if p' rt then 1 else 0+    countWhere' p' rt@(RunNodeIntroduce {..}) = (if p' rt then 1 else 0) + countWhere p' runNodeChildrenAugmented+    countWhere' p' rt@(RunNodeIntroduceWith {..}) = (if p' rt then 1 else 0) + countWhere p' runNodeChildrenAugmented+    countWhere' p' rt = (if p' rt then 1 else 0) + countWhere p' (runNodeChildren rt)  isItBlock (RunNodeIt {}) = True isItBlock _ = False

@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}--- |  module Test.Sandwich.Formatters.Common.Util (   formatNominalDiffTime@@ -10,13 +9,14 @@ import Text.Printf  formatNominalDiffTime :: NominalDiffTime -> String-formatNominalDiffTime diff | diff < ps = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^15)) <> "ps"-formatNominalDiffTime diff | diff < ns = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^12)) <> "ns"-formatNominalDiffTime diff | diff < us = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^9)) <> "ns"-formatNominalDiffTime diff | diff < ms = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^6)) <> "us"-formatNominalDiffTime diff | diff < second = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^3)) <> "ms"+formatNominalDiffTime diff | diff < ps = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^(15 :: Integer))) <> "ps"+formatNominalDiffTime diff | diff < ns = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^(12 :: Integer))) <> "ns"+formatNominalDiffTime diff | diff < us = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^(9 :: Integer))) <> "ns"+formatNominalDiffTime diff | diff < ms = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^(6 :: Integer))) <> "us"+formatNominalDiffTime diff | diff < second = (roundFixed ((nominalDiffTimeToSeconds diff) * 10^(3 :: Integer))) <> "ms" formatNominalDiffTime diff = (roundFixed (nominalDiffTimeToSeconds diff)) <> "s" +second, ms, us, ns, ps :: NominalDiffTime second = secondsToNominalDiffTime 1 ms = secondsToNominalDiffTime 0.001 us = secondsToNominalDiffTime 0.000001

@@ -17,7 +17,6 @@   ) where  import Control.Monad-import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Reader@@ -64,7 +63,7 @@   runFormatter _ _ _ _ = return ()   finalizeFormatter = printFailureReport -printFailureReport :: (MonadIO m, MonadLogger m, MonadCatch m) => FailureReportFormatter -> [RunNode BaseContext] -> BaseContext -> m ()+printFailureReport :: (MonadIO m) => FailureReportFormatter -> [RunNode BaseContext] -> BaseContext -> m () printFailureReport frf@(FailureReportFormatter {..}) rts _bc = do   liftIO $ putStrLn [i|\n\nFailure report:|] 

@@ -65,7 +65,7 @@   runFormatter = runApp   finalizeFormatter _ _ _ = return () -runApp :: (MonadIO m, MonadLogger m) => LogSaverFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()+runApp :: (MonadIO m) => LogSaverFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m () runApp lsf@(LogSaverFormatter {..}) rts _maybeCommandLineOptions bc = do   let maybePath = case logSaverPath of         LogPathAbsolute p -> Just p

@@ -17,9 +17,7 @@   ) where  import Control.Concurrent.STM-import Control.Monad.Catch import Control.Monad.IO.Class-import Control.Monad.Logger import Data.String.Interpolate import Data.Text as T import Data.Time@@ -51,7 +49,7 @@   runFormatter = run   finalizeFormatter _ _ _ = return () -run :: (MonadIO m, MonadLogger m, MonadCatch m) => MarkdownSummaryFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()+run :: (MonadIO m) => MarkdownSummaryFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m () run (MarkdownSummaryFormatter {..}) rts _ _bc = do   let total = countWhere isItBlock rts 

@@ -1,4 +1,5 @@ {-# LANGUAGE MultiWayIf #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  -- | The print formatter prints all results from the test tree from top to bottom, as they become available. --@@ -18,7 +19,6 @@ import Control.Concurrent.STM import Control.Monad import Control.Monad.IO.Class-import Control.Monad.Logger import Control.Monad.Reader import Data.String.Interpolate import Data.Time.Clock@@ -43,8 +43,8 @@   runFormatter = runApp   finalizeFormatter _ _ _ = return () -runApp :: (MonadIO m, MonadLogger m) => PrintFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()-runApp pf@(PrintFormatter {..}) rts _maybeCommandLineOptions bc = liftIO $ do+runApp :: (MonadIO m) => PrintFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()+runApp pf rts _maybeCommandLineOptions bc = liftIO $ do   let total = countWhere isItBlock rts    startTime <- getCurrentTime

@@ -1,14 +1,25 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}  module Test.Sandwich.Formatters.Print.CallStacks where  import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.Reader import GHC.Stack+import System.IO (Handle) import Test.Sandwich.Formatters.Print.Color import Test.Sandwich.Formatters.Print.Printing+import Test.Sandwich.Formatters.Print.Types  +printCallStack :: (+  MonadReader (PrintFormatter, Int, Handle) m, MonadIO m+  ) => CallStack -> m () printCallStack cs = forM_ (getCallStack cs) printCallStackLine +printCallStackLine :: (+  MonadReader (PrintFormatter, Int, Handle) m, MonadIO m+  ) => (String, SrcLoc) -> m () printCallStackLine (f, (SrcLoc {..})) = do   pic logFunctionColor f 

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}  module Test.Sandwich.Formatters.Print.Color where 

@@ -6,7 +6,7 @@   printFailureReason   ) where -import Control.Exception.Safe+import UnliftIO.Exception import Control.Monad.Reader import qualified Data.List as L import Data.String.Interpolate

@@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}  module Test.Sandwich.Formatters.Print.Logs where @@ -30,6 +31,9 @@           when (logEntryLevel entry >= logLevel) $ printLogEntry entry  +printLogEntry :: (+  MonadReader (PrintFormatter, Int, Handle) m, MonadIO m+  ) => LogEntry -> m () printLogEntry (LogEntry {..}) = do   pic logTimestampColor (show logEntryTime) 

@@ -7,6 +7,7 @@ import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader+import Data.Colour import qualified Data.List as L import System.IO import Test.Sandwich.Formatters.Print.Color@@ -39,10 +40,10 @@   (if indentFirst then pic else pc) recordNameColor name   pcn braceColor " {"   withBumpIndent $-    forM_ tuples $ \(name, val) -> do-      pic fieldNameColor name+    forM_ tuples $ \(name', val) -> do+      pic fieldNameColor name'       p " = "-      withBumpIndent' (L.length name + L.length (" = " :: String)) $ do+      withBumpIndent' (L.length name' + L.length (" = " :: String)) $ do         printPretty False val         p "\n"   pic braceColor "}"@@ -67,6 +68,9 @@     printPretty False s  +printListWrappedIn :: (+  MonadReader (PrintFormatter, Int, Handle) m, MonadIO m+  ) => (String, String) -> Bool -> [Value] -> m () printListWrappedIn (begin, end) (getPrintFn -> f) values | all isSingleLine values = do   f listBracketColor begin   sequence_ (L.intercalate [p ", "] [[printPretty False v] | v <- values])@@ -80,5 +84,8 @@       p "\n"   pic listBracketColor end +getPrintFn :: (+  MonadReader (PrintFormatter, Int, Handle) m, MonadIO m+  ) => Bool -> Colour Float -> String -> m () getPrintFn True = pic getPrintFn False = pc

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}  -- | Utility functions for printing 

@@ -24,11 +24,13 @@  isSingleLine _ = True +withBumpIndent :: MonadReader (PrintFormatter, Int, c) m => m b -> m b withBumpIndent action = do   (PrintFormatter {..}, _, _) <- ask   withBumpIndent' printFormatterIndentSize action +withBumpIndent' :: (MonadReader (a, Int, c) m) => Int -> m b -> m b withBumpIndent' n = local (\(pf, indent, h) -> (pf, indent + n, h)) -+fst3 :: (a, b, c) -> a fst3 (x, _, _) = x

@@ -1,6 +1,7 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Test.Sandwich.Formatters.TerminalUI (   -- | The terminal UI formatter produces an interactive UI for running tests and inspecting their results.@@ -30,10 +31,9 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM-import Control.Exception.Safe+import UnliftIO.Exception import Control.Monad import Control.Monad.IO.Class-import Control.Monad.IO.Unlift import Control.Monad.Logger hiding (logError) import Control.Monad.Trans import Control.Monad.Trans.State hiding (get, put)@@ -77,7 +77,7 @@ isTuiFormatterSupported :: IO Bool isTuiFormatterSupported = isRight <$> tryAny (V.mkVty V.defaultConfig) -runApp :: (MonadLoggerIO m, MonadUnliftIO m) => TerminalUIFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()+runApp :: (MonadLoggerIO m) => TerminalUIFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m () runApp (TerminalUIFormatter {..}) rts _maybeCommandLineOptions baseContext = do   startTime <- liftIO getCurrentTime @@ -165,11 +165,13 @@ continueNoChange :: AppState -> EventM ClickableName AppState () continueNoChange _ = return () +doHalt :: p -> EventM n s () doHalt _ = halt #else continueNoChange :: AppState -> EventM ClickableName (Next AppState) continueNoChange = continue +doHalt :: p -> EventM n s doHalt = halt #endif @@ -209,8 +211,8 @@ appEvent s (MouseDown (ListRow _i) V.BScrollDown _ _) = do   vScrollBy (viewportScroll MainList) 1   continueNoChange s-appEvent s (MouseDown (ListRow i) V.BLeft _ _) = do-  continue (s & appMainList %~ (listMoveTo i))+appEvent s (MouseDown (ListRow n) V.BLeft _ _) = do+  continue (s & appMainList %~ (listMoveTo n)) appEvent s (VtyEvent e) =   case e of     -- Column 1@@ -219,7 +221,7 @@     V.EvKey c [] | c == nextFailureKey -> do       let ls = Vec.toList $ listElements (s ^. appMainList)       let listToSearch = case listSelectedElement (s ^. appMainList) of-            Just (i, MainListElem {}) -> let (front, back) = L.splitAt (i + 1) (zip [0..] ls) in back <> front+            Just (n, MainListElem {}) -> let (front, back) = L.splitAt (n + 1) (zip [0..] ls) in back <> front             Nothing -> zip [0..] ls       case L.find (isFailureStatus . status . snd) listToSearch of         Nothing -> continue s@@ -227,7 +229,7 @@     V.EvKey c [] | c == previousFailureKey -> do       let ls = Vec.toList $ listElements (s ^. appMainList)       let listToSearch = case listSelectedElement (s ^. appMainList) of-            Just (i, MainListElem {}) -> let (front, back) = L.splitAt i (zip [0..] ls) in (L.reverse front) <> (L.reverse back)+            Just (n, MainListElem {}) -> let (front, back) = L.splitAt n (zip [0..] ls) in (L.reverse front) <> (L.reverse back)             Nothing -> L.reverse (zip [0..] ls)       case L.find (isFailureStatus . status . snd) listToSearch of         Nothing -> continue s@@ -325,7 +327,7 @@      -- Column 3     V.EvKey c [] | c == cycleVisibilityThresholdKey -> do-      let newVisibilityThreshold =  case [(i, x) | (i, x) <- zip [0..] (s ^. appVisibilityThresholdSteps)+      let newVisibilityThreshold =  case [(n, x) | (n, x) <- zip [(0 :: Integer)..] (s ^. appVisibilityThresholdSteps)                                                  , x > s ^. appVisibilityThreshold] of             [] -> 0             xs -> minimum $ fmap snd xs@@ -354,19 +356,21 @@     ev -> handleEventLensed s appMainList handleListEvent ev >>= continue #endif -  where withContinueS s action = action >> continue s+  where withContinueS s' action = action >> continue s' #if MIN_VERSION_brick(1,0,0) appEvent _ _ = return () #else appEvent s _ = continue s #endif +modifyToggled :: AppState -> (Bool -> Bool) -> EventM ClickableName AppState () modifyToggled s f = case listSelectedElement (s ^. appMainList) of   Nothing -> continue s   Just (_i, MainListElem {..}) -> do     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@@ -455,6 +459,7 @@   continue s #endif +openSrcLoc :: Ord n => AppState -> SrcLoc -> EventM n AppState () openSrcLoc s loc' = do   -- Try to make the file path in the SrcLoc absolute   loc <- case isRelative (srcLocFile loc') of

@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# OPTIONS_GHC -fno-warn-type-defaults #-}  module Test.Sandwich.Formatters.TerminalUI.AttrMap where @@ -141,7 +143,6 @@  -- * Logging and callstacks -debugAttr, infoAttr, warnAttr, errorAttr, otherAttr :: AttrName debugAttr = attrName"log_debug" infoAttr = attrName"log_info" warnAttr = attrName"log_warn"@@ -151,7 +152,6 @@ logTimestampAttr :: AttrName logTimestampAttr = mkAttrName "log_timestamp" -logFilenameAttr, logModuleAttr, logPackageAttr, logLineAttr, logChAttr :: AttrName logFilenameAttr = mkAttrName "logFilename" logModuleAttr = mkAttrName "logModule" logPackageAttr = mkAttrName "logPackage"@@ -165,8 +165,6 @@ expectedAttr = mkAttrName "expected" sawAttr = mkAttrName "saw" -integerAttr, timeAttr, dateAttr, stringAttr, charAttr, floatAttr, quoteAttr, slashAttr, negAttr :: AttrName-listBracketAttr, tupleBracketAttr, braceAttr, ellipsesAttr, recordNameAttr, fieldNameAttr, constructorNameAttr :: AttrName integerAttr = mkAttrName "integer" floatAttr = mkAttrName "float" charAttr = mkAttrName "char"

@@ -1,4 +1,5 @@--- |+{-# LANGUAGE CPP #-}+{-# LANGUAGE QuasiQuotes #-}  module Test.Sandwich.Formatters.TerminalUI.CrossPlatform (   openFileExplorerFolderPortable@@ -7,6 +8,19 @@ import Control.Monad import System.Process --- | TODO: report exceptions here++-- | TODO: report exceptions from this++#ifdef mingw32_HOST_OS+import System.Directory++openFileExplorerFolderPortable :: String -> IO () openFileExplorerFolderPortable folder = do+  findExecutable "explorer.exe" >>= \case+    Just p -> void $ readCreateProcessWithExitCode (proc p [folder]) ""+    Nothing -> return ()+#else+openFileExplorerFolderPortable :: String -> IO ()+openFileExplorerFolderPortable folder =   void $ readCreateProcessWithExitCode (proc "xdg-open" [folder]) ""+#endif

@@ -18,7 +18,7 @@ import qualified Data.Text.Encoding as E import Data.Time.Clock import GHC.Stack-import Lens.Micro+import Lens.Micro hiding (ix) import Safe import Test.Sandwich.Formatters.Common.Count import Test.Sandwich.Formatters.Common.Util@@ -43,6 +43,7 @@       , clickable ColorBar $ bottomProgressBarColored app       ] +mainList :: AppState -> Widget ClickableName mainList app = hCenter $ padAll 1 $ L.renderListWithIndex listDrawElement True (app ^. appMainList)   where     listDrawElement ix isSelected x@(MainListElem {..}) = clickable (ListRow ix) $ padLeft (Pad (4 * depth)) $ (if isSelected then border else id) $ vBox $ catMaybes [@@ -121,6 +122,7 @@     logLevelWidget (LevelOther x) = withAttr infoAttr $ str [i|#{x}|]  +borderWithCounts :: AppState -> Widget n borderWithCounts app = hBorderWithLabel $ padLeftRight 1 $ hBox (L.intercalate [str ", "] countWidgets <> [str [i| of |]                                                                                                           , withAttr totalAttr $ str $ show totalNumTests                                                                                                           , str [i| in |]

@@ -1,5 +1,5 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE TemplateHaskell #-}  module Test.Sandwich.Formatters.TerminalUI.Draw.ColorProgressBar (   bottomProgressBarColored@@ -9,7 +9,6 @@ import Data.Foldable import Data.Ord (comparing) import Data.String.Interpolate-import GHC.Stack import Lens.Micro import Lens.Micro.TH import Test.Sandwich.Formatters.TerminalUI.AttrMap@@ -82,14 +81,17 @@ -- two_eighth = "▎" -- one_eighth = "▏" +full_five_eighth_height :: String full_five_eighth_height = "▆"  -- * Exports +bottomProgressBarColored :: AppState -> Widget n bottomProgressBarColored app = Widget Greedy Fixed $ do   c <- getContext   render $ bottomProgressBarColoredWidth app (c ^. availWidthL) +bottomProgressBarColoredWidth :: Integral p => AppState -> p -> Widget n bottomProgressBarColoredWidth app width = hBox [getCharForChunk chunk | chunk <- chunks]   where     statuses = concatMap getStatuses (app ^. appRunTree)@@ -99,5 +101,5 @@      testsPerChar :: Rational = fromIntegral width / fromIntegral (length statuses) -    getStatuses :: (HasCallStack) => RunNodeWithStatus context a l t -> [a]+    getStatuses :: RunNodeWithStatus context a l t -> [a]     getStatuses = extractValues (runTreeStatus . runNodeCommon)

@@ -12,9 +12,11 @@ import Test.Sandwich.Formatters.TerminalUI.Types  -minGray :: Int = 50-maxGray :: Int = 255+minGray, maxGray :: Int+minGray = 50+maxGray = 255 +getRunTimes :: AppState -> UTCTime -> UTCTime -> Maybe NominalDiffTime -> Maybe NominalDiffTime -> Bool -> Widget n getRunTimes app startTime endTime statusSetupTime statusTeardownTime showEllipses = raw setupWork <+> raw actualWork <+> raw teardownWork   where     totalElapsed = diffUTCTime (app ^. appCurrentTime) (app ^. appStartTime)

@@ -5,7 +5,7 @@  import Brick import Brick.Widgets.Border-import Control.Exception.Safe+import UnliftIO.Exception import Control.Monad.Reader import qualified Data.List as L import Data.Maybe

@@ -1,5 +1,5 @@ {-# LANGUAGE MultiWayIf #-}--- |+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}  module Test.Sandwich.Formatters.TerminalUI.Draw.TopBox (   topBox

@@ -39,7 +39,7 @@                          }  markClosed :: RunNodeCommonWithStatus s l Bool -> RunNodeCommonWithStatus s l Bool-markClosed node@(RunNodeCommonWithStatus {..}) = node { runTreeVisible = False }+markClosed node@(RunNodeCommonWithStatus {}) = node { runTreeVisible = False }  hideClosed :: RunNodeWithStatus context s l Bool -> RunNodeWithStatus context s l Bool hideClosed node@(RunNodeIt {}) = node

@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}  module Test.Sandwich.Formatters.TerminalUI.Keys where 

@@ -2,6 +2,8 @@  -- This module is based on Test.Hspec.Golden from hspec-golden-0.2.0.0, which is MIT licensed. +-- | Functions for [golden testing](https://ro-che.info/articles/2017-12-04-golden-tests).+ module Test.Sandwich.Golden (   -- * Main test function   golden@@ -22,7 +24,6 @@   , goldenFailFirstTime   ) where -import Control.Exception.Safe import Control.Monad import Control.Monad.Free import Control.Monad.IO.Class@@ -37,6 +38,7 @@ import Test.Sandwich import Test.Sandwich.Golden.Update import Test.Sandwich.Types.Spec+import UnliftIO.Exception   data Golden a = Golden {@@ -90,7 +92,7 @@  -- | Runs a Golden test. -golden :: (MonadIO m, MonadThrow m, Eq str, Show str) => Golden str -> Free (SpecCommand context m) ()+golden :: (MonadIO m, Eq str, Show str) => Golden str -> Free (SpecCommand context m) () golden (Golden {..}) = it goldenName $ do   let goldenTestDir = takeDirectory goldenFile   liftIO $ createDirectoryIfMissing True goldenTestDir

@@ -6,13 +6,13 @@   , defaultDirGoldenTest   ) where -import Control.Exception.Safe import Control.Monad import Data.Maybe import Data.String.Interpolate import System.Console.ANSI import System.Directory import System.Environment+import UnliftIO.Exception   defaultDirGoldenTest :: FilePath@@ -29,7 +29,7 @@   putStrLnColor enableColor green "Done!"    where-    go enableColor dir = listDirectory dir >>= mapM_ (processEntry enableColor)+    go enableColor dir' = listDirectory dir' >>= mapM_ (processEntry enableColor)      processEntry enableColor (((dir ++ "/") ++) -> entryInDir) = do       isDir <- doesDirectoryExist entryInDir@@ -55,9 +55,11 @@ red = SetColor Foreground Dull Red magenta = SetColor Foreground Dull Magenta +putStrColor :: EnableColor -> SGR -> String -> IO () putStrColor EnableColor color s = bracket_ (setSGR [color]) (setSGR [Reset]) (putStr s) putStrColor DisableColor _ s = putStr s +putStrLnColor :: EnableColor -> SGR -> String -> IO () putStrLnColor EnableColor color s = bracket_ (setSGR [color]) (setSGR [Reset]) (putStrLn s) putStrLnColor DisableColor _ s = putStrLn s 

@@ -1,4 +1,4 @@--- | Internal functionality exposed for sibling libraries such as sandwich-webdriver to use. Should not be used otherwise.+-- | Internal functionality exposed for debugging or for sibling libraries such as sandwich-webdriver to use. Should not be used otherwise.  module Test.Sandwich.Internal (   Spec@@ -11,7 +11,7 @@   , ExampleM   , ExampleT(..) -  -- For tests+  -- * For tests   , RunNodeWithStatus(..)   , RunNodeFixed   , RunNode@@ -26,6 +26,13 @@   , SomeAsyncExceptionWithEq(..)   , logEntryStr +  -- * For debugging+  , getRunTree+  , getRunTree'+  , printRunTree++  , commandLineOptions+   , module Test.Sandwich.Internal.Formatters   , module Test.Sandwich.Internal.Running   ) where@@ -37,4 +44,5 @@ import Test.Sandwich.Types.Spec  import Test.Sandwich.Internal.Formatters+import Test.Sandwich.Internal.Inspection import Test.Sandwich.Internal.Running

@@ -0,0 +1,42 @@++module Test.Sandwich.Internal.Inspection where++import Control.Monad+import Control.Monad.Logger+import Data.Function+import qualified Data.List as L+import Data.String.Interpolate+import Test.Sandwich.Internal.Running+import Test.Sandwich.Interpreters.FilterTree+import Test.Sandwich.Interpreters.PruneTree+import Test.Sandwich.Interpreters.RunTree+import Test.Sandwich.Types.RunTree+++getRunTree :: Options -> CoreSpec -> IO [RunNodeFixed BaseContext]+getRunTree options spec = do+  baseContext' <- baseContextFromOptions options+  let baseContext = baseContext' { baseContextPath = Just "/path", baseContextRunRoot = Just "/root" }+  runStderrLoggingT $ getRunTree' baseContext options spec++getRunTree' :: MonadLogger m => BaseContext -> Options -> CoreSpec -> m [RunNodeFixed BaseContext]+getRunTree' baseContext (Options {optionsPruneTree=(unwrapTreeFilter -> pruneOpts), optionsFilterTree=(unwrapTreeFilter -> filterOpts)}) spec =+  spec+    & (\tree -> L.foldl' pruneTree tree pruneOpts)+    & (\tree -> L.foldl' filterTree tree filterOpts)+    & specToRunTreeM baseContext++printRunTree :: [RunNodeFixed ctx] -> IO ()+printRunTree = go 0+  where+    go :: Int -> [RunNodeFixed ctx] -> IO ()+    go depth nodes = do+      forM_ nodes $ \node@(runNodeCommon -> RunNodeCommonWithStatus {..}) -> do+        let spaces = L.replicate (depth * 2) ' '+        putStrLn [i|#{spaces}#{runTreeLabel}, \##{runTreeId} with ancestors #{runTreeAncestors}. Folder: #{runTreeFolder}|]++        case node of+          RunNodeIntroduce {..} -> go (depth + 1) runNodeChildrenAugmented+          RunNodeIntroduceWith {..} -> go (depth + 1) runNodeChildrenAugmented+          RunNodeIt {} -> return ()+          _ -> go (depth + 1) (runNodeChildren node)

@@ -65,13 +65,13 @@      | 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+  (successes, total) <- (flip execStateT (0 :: Int, 0 :: Int)) $ flip fix (n - 1) $ \loop n' -> do     (exitReason, numFailures) <- liftIO action      modify $ \(successes, total) -> (successes + (if numFailures == 0 then 1 else 0), total + 1)      if | exitReason == SignalExit -> return ()-       | n > 0 -> loop (n - 1)+       | n' > 0 -> loop (n' - 1)        | otherwise -> return ()    putStrLn [i|#{successes} runs succeeded out of #{total} repeat#{if n > 1 then ("s" :: String) else ""} (#{totalTests} tests)|]@@ -98,8 +98,8 @@           here <- getCurrentDirectory           return $ here </> base' -      name <- f-      let dir = base </> name+      name' <- f+      let dir = base </> name'       createDirectoryIfMissing True dir       return $ Just dir 

@@ -1,29 +1,51 @@-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}  module Test.Sandwich.Interpreters.RunTree (   specToRunTree   , specToRunTreeVariable+  , specToRunTreeM   , isEmptySpec   ) where  import Control.Concurrent.STM import Control.Monad.Free+import Control.Monad.Logger import Control.Monad.Trans.RWS+import Data.Foldable (toList) import Data.Functor.Identity import qualified Data.List as L-import Data.Sequence+import qualified Data.Map as M+import Data.Sequence as Seq import GHC.Stack+import Lens.Micro+import Lens.Micro.TH+import Safe (headMay) import System.FilePath import Test.Sandwich.Interpreters.RunTree.Util-import Test.Sandwich.RunTree+import Test.Sandwich.RunTree (unFixRunTree) import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec  +data CreatedNode = CreatedNode {+  _createdNodeFolder :: Maybe (FilePath, Int, Int)+  } deriving (Show)+makeLenses ''CreatedNode++data ConvertState = ConvertState {+  _convertStateIdCounter :: Int+  , _convertStateCreatedNodes :: M.Map Int CreatedNode+  , _convertStateRootNextChildIndex :: Int+  }+emptyConvertState :: ConvertState+emptyConvertState = ConvertState 0 mempty 0+makeLenses ''ConvertState+ specToRunTree :: BaseContext -> Free (SpecCommand BaseContext IO) () -> [RunNodeFixed BaseContext]-specToRunTree baseContext spec = runIdentity $ specToRunTreeM baseContext spec+specToRunTree baseContext spec = runIdentity $ runNoLoggingT $ specToRunTreeM baseContext spec  specToRunTreeVariable :: BaseContext -> Free (SpecCommand BaseContext IO) () -> STM [RunNode BaseContext] specToRunTreeVariable bc spec = mapM unFixRunTree $ specToRunTree bc spec@@ -31,65 +53,90 @@ isEmptySpec :: forall context. Free (SpecCommand context IO) () -> Bool isEmptySpec spec = L.null ret   where context = RunTreeContext {-          runTreeIndexInParent = 0-          , runTreeNumSiblings = 0-          , runTreeCurrentAncestors = mempty-          , runTreeCurrentFolder = Nothing+          runTreeCurrentAncestors = mempty+          , runTreeRootFolderAndNumChildren = Nothing           }-        (ret, _, _) = runIdentity $ runRWST (specToRunTree' spec) context 0+        (ret, _, _) = runIdentity $ runNoLoggingT $ runRWST (specToRunTree' spec) context emptyConvertState -specToRunTreeM :: (Monad m) => BaseContext -> Free (SpecCommand BaseContext IO) () -> m [RunNodeFixed BaseContext]+specToRunTreeM :: (MonadLogger m) => BaseContext -> Free (SpecCommand BaseContext IO) () -> m [RunNodeFixed BaseContext] specToRunTreeM baseContext spec = do   let context = RunTreeContext {-        runTreeIndexInParent = 0-        , runTreeNumSiblings = countChildren spec-        , runTreeCurrentAncestors = mempty-        , runTreeCurrentFolder = (</> "results") <$> baseContextRunRoot baseContext+        runTreeCurrentAncestors = mempty+        , runTreeRootFolderAndNumChildren = case baseContextRunRoot baseContext of+            Nothing -> Nothing+            Just root -> Just (root </> "results", countImmediateFolderChildren spec)         }-  (ret, _, _) <- runRWST (specToRunTree' spec) context 0+  (ret, _, _) <- runRWST (specToRunTree' spec) context emptyConvertState   return ret  -- | Convert a spec to a run tree-specToRunTree' :: (Monad m) => Free (SpecCommand context IO) r -> ConvertM m [RunNodeFixed context]-specToRunTree' (Free (Before'' loc no l f subspec next)) = do-  common <- getCommon l loc no+specToRunTree' :: (MonadLogger m) => Free (SpecCommand context IO) r -> ConvertM m [RunNodeFixed context]+specToRunTree' node@(Free (Before'' loc no l f subspec next)) = do+  common <- getCommon l loc node no   continueWith next =<< RunNodeBefore common <$> recurse l no common subspec <*> pure f-specToRunTree' (Free (After'' loc no l f subspec next)) = do-  common <- getCommon l loc no+specToRunTree' node@(Free (After'' loc no l f subspec next)) = do+  common <- getCommon l loc node no   continueWith next =<< RunNodeAfter common <$> recurse l no common subspec <*> pure f-specToRunTree' (Free (Introduce'' loc no l _cl alloc cleanup subspec next)) = do-  common <- getCommon l loc no+specToRunTree' node@(Free (Introduce'' loc no l _cl alloc cleanup subspec next)) = do+  common <- getCommon l loc node no   continueWith next =<< RunNodeIntroduce common <$> recurse l no common subspec <*> pure alloc <*> pure cleanup-specToRunTree' (Free (IntroduceWith'' loc no l _cl action subspec next)) = do-  common <- getCommon l loc no+specToRunTree' node@(Free (IntroduceWith'' loc no l _cl action subspec next)) = do+  common <- getCommon l loc node no   continueWith next =<< RunNodeIntroduceWith common <$> recurse l no common subspec <*> pure action-specToRunTree' (Free (Around'' loc no l actionWith subspec next)) = do-  common <- getCommon l loc no+specToRunTree' node@(Free (Around'' loc no l actionWith subspec next)) = do+  common <- getCommon l loc node no   continueWith next =<< RunNodeAround common <$> recurse l no common subspec <*> pure actionWith-specToRunTree' (Free (Describe'' loc no l subspec next)) = do-  common <- getCommon l loc no+specToRunTree' node@(Free (Describe'' loc no l subspec next)) = do+  common <- getCommon l loc node no   continueWith next =<< RunNodeDescribe common <$> recurse l no common subspec-specToRunTree' (Free (Parallel'' loc no subspec next)) = do-  common <- getCommon "Parallel" loc no+specToRunTree' node@(Free (Parallel'' loc no subspec next)) = do+  common <- getCommon "Parallel" loc node no   continueWith next =<< RunNodeParallel common <$> recurse "Parallel" no common subspec-specToRunTree' (Free (It'' loc no l example next)) = do-  common <- getCommon l loc no+specToRunTree' node@(Free (It'' loc no l example next)) = do+  common <- getCommon l loc node no   continueWith next =<< RunNodeIt common <$> pure example specToRunTree' (Pure _) = return []   -- * Util -type ConvertM m = RWST RunTreeContext () Int m+type ConvertM m = RWST RunTreeContext () ConvertState m -getCommon :: (Monad m) => String -> Maybe SrcLoc -> NodeOptions -> ConvertM m RunNodeCommonFixed-getCommon l srcLoc (NodeOptions {..}) = do+getCommon :: (MonadLogger m) => String -> Maybe SrcLoc -> Free (SpecCommand context n) a -> NodeOptions -> ConvertM m RunNodeCommonFixed+getCommon l srcLoc node (NodeOptions {..}) = do   RunTreeContext {..} <- ask    -- Get a unique ID for this node-  ident <- get-  modify (+1)+  ident <- _convertStateIdCounter <$> get+  modify (over convertStateIdCounter (+1)) +  -- Determine the folder for the node+  folder <- case nodeOptionsCreateFolder of+    False -> pure Nothing+    True -> do+      createdNodes <- _convertStateCreatedNodes <$> get+      -- Look up the first ancestor that has a folder+      case headMay [(ancestor, folder) | ancestor@(flip M.lookup createdNodes -> Just (CreatedNode (Just folder)))+                                         <- (toList $ Seq.reverse runTreeCurrentAncestors)] of+        Nothing -> do+          -- No ancestor has a folder, so we have to put this folder under the root+          case runTreeRootFolderAndNumChildren of+            Just (rootFolder, numRootChildren) -> do+              nextRootChild <- _convertStateRootNextChildIndex <$> get+              modify (over convertStateRootNextChildIndex (+1))+              pure $ Just (rootFolder </> nodeToFolderName l numRootChildren nextRootChild)+            Nothing -> pure Nothing+        Just (ancestor, (folder, totalChildren, nextChildIndex)) -> do+          let bumpAncestorNextChildIndex :: M.Map Int CreatedNode -> M.Map Int CreatedNode+              bumpAncestorNextChildIndex = M.adjust (over (createdNodeFolder . _Just . _3) (+1)) ancestor+          modify (over convertStateCreatedNodes bumpAncestorNextChildIndex)+          pure $ Just (folder </> nodeToFolderName l totalChildren nextChildIndex)++  -- Insert this node into the ConvertState+  modify $ over convertStateCreatedNodes $ M.insert ident $ CreatedNode $ case folder of+    Nothing -> Nothing+    Just f -> Just (f, countSubspecFolderChildren node, 0)+   return $ RunNodeCommonWithStatus {     runTreeLabel = l     , runTreeId = ident@@ -98,32 +145,19 @@     , runTreeOpen = True     , runTreeStatus = NotStarted     , runTreeVisible = True-    , runTreeFolder = case (nodeOptionsCreateFolder, runTreeCurrentFolder) of-        (True, Just f) -> Just (f </> (nodeToFolderName l runTreeNumSiblings runTreeIndexInParent))-        _ -> Nothing+    , runTreeFolder = folder     , runTreeVisibilityLevel = nodeOptionsVisibilityThreshold     , runTreeRecordTime = nodeOptionsRecordTime     , runTreeLogs = mempty     , runTreeLoc = srcLoc     } -continueWith :: (Monad m) => Free (SpecCommand context IO) r -> RunNodeFixed context -> ConvertM m [RunNodeFixed context]+continueWith :: (MonadLogger m) => Free (SpecCommand context IO) r -> RunNodeFixed context -> ConvertM m [RunNodeFixed context] continueWith next node = do-  rest <- local (\rtc -> rtc { runTreeIndexInParent = (runTreeIndexInParent rtc) + 1 }) $ specToRunTree' next+  rest <- specToRunTree' next   return (node : rest) -recurse :: (Monad m) => String -> NodeOptions -> RunNodeCommonFixed -> Free (SpecCommand context IO) r -> ConvertM m [RunNodeFixed context]-recurse l (NodeOptions {..}) (RunNodeCommonWithStatus {..}) subspec = local-  (\rtc ->-     if | nodeOptionsCreateFolder ->-          rtc { runTreeCurrentFolder = case runTreeCurrentFolder rtc of-                  Nothing -> Nothing-                  Just f -> Just (f </> (nodeToFolderName l (runTreeNumSiblings rtc) (runTreeIndexInParent rtc)))-              , runTreeIndexInParent = 0-              , runTreeNumSiblings = countImmediateFolderChildren subspec-              , runTreeCurrentAncestors = runTreeAncestors-              }-        | otherwise ->-          rtc { runTreeCurrentAncestors = runTreeAncestors }-  )+recurse :: (MonadLogger m) => String -> NodeOptions -> RunNodeCommonFixed -> Free (SpecCommand context IO) r -> ConvertM m [RunNodeFixed context]+recurse _ (NodeOptions {}) (RunNodeCommonWithStatus {..}) subspec = local+  (\rtc -> rtc { runTreeCurrentAncestors = runTreeAncestors })   (specToRunTree' subspec)

@@ -30,20 +30,7 @@   ts <- getCurrentTime   atomically $ modifyTVar logs (|> LogEntry ts (Loc "" "" "" (0, 0) (0, 0)) "manual" LevelDebug (toLogStr msg)) -getImmediateChildren :: Free (SpecCommand context m) () -> [Free (SpecCommand context m) ()]-getImmediateChildren (Free (It'' loc no l ex next)) = (Free (It'' loc no l ex (Pure ()))) : getImmediateChildren next-getImmediateChildren (Free (Before'' loc no l f subspec next)) = (Free (Before'' loc no l f subspec (Pure ()))) : getImmediateChildren next-getImmediateChildren (Free (After'' loc no l f subspec next)) = (Free (After'' loc no l f subspec (Pure ()))) : getImmediateChildren next-getImmediateChildren (Free (Introduce'' loc no l cl alloc cleanup subspec next)) = (Free (Introduce'' loc no l cl alloc cleanup subspec (Pure ()))) : getImmediateChildren next-getImmediateChildren (Free (IntroduceWith'' loc no l cl action subspec next)) = (Free (IntroduceWith'' loc no l cl action subspec (Pure ()))) : getImmediateChildren next-getImmediateChildren (Free (Around'' loc no l f subspec next)) = (Free (Around'' loc no l f subspec (Pure ()))) : getImmediateChildren next-getImmediateChildren (Free (Describe'' loc no l subspec next)) = (Free (Describe'' loc no l subspec (Pure ()))) : getImmediateChildren next-getImmediateChildren (Free (Parallel'' loc no subspec next)) = (Free (Parallel'' loc no subspec (Pure ()))) : getImmediateChildren next-getImmediateChildren (Pure ()) = [Pure ()]--countChildren :: Free (SpecCommand context m) () -> Int-countChildren = L.length . getImmediateChildren-+-- | Count how many folder children are present as children or siblings of the given node. countImmediateFolderChildren :: Free (SpecCommand context m) a -> Int countImmediateFolderChildren (Free (It'' _loc no _l _ex next))   | nodeOptionsCreateFolder no = 1 + countImmediateFolderChildren next@@ -58,6 +45,14 @@   | nodeOptionsCreateFolder (nodeOptions node) = 1 + countImmediateFolderChildren (next node)   | otherwise = countImmediateFolderChildren (subspec node) + countImmediateFolderChildren (next node) countImmediateFolderChildren (Pure _) = 0++-- | Count how many folder children are present as children of the given node.+countSubspecFolderChildren :: Free (SpecCommand context m) a -> Int+countSubspecFolderChildren (Free (It'' {})) = 0+countSubspecFolderChildren (Free (Introduce'' {subspecAugmented})) = countImmediateFolderChildren subspecAugmented+countSubspecFolderChildren (Free (IntroduceWith'' {subspecAugmented})) = countImmediateFolderChildren subspecAugmented+countSubspecFolderChildren (Free node) = countImmediateFolderChildren (subspec node)+countSubspecFolderChildren (Pure _) = 0  maxFileNameLength :: Int maxFileNameLength = 150

@@ -11,7 +11,6 @@ import Control.Concurrent.Async import Control.Concurrent.MVar import Control.Concurrent.STM-import Control.Exception.Safe import Control.Monad import Control.Monad.IO.Class import Control.Monad.Logger@@ -41,6 +40,7 @@ import Test.Sandwich.Types.Spec import Test.Sandwich.Types.TestTimer import Test.Sandwich.Util+import UnliftIO.Exception   baseContextFromCommon :: RunNodeCommonWithStatus s l t -> BaseContext -> BaseContext@@ -53,7 +53,7 @@   let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon   runInAsync node ctx $ do     (timed (runExampleM runNodeBefore ctx runTreeLogs (Just [i|Exception in before '#{runTreeLabel}' handler|]))) >>= \case-      (result@(Failure fr@(Pending {..})), setupTime) -> do+      (result@(Failure fr@(Pending {})), setupTime) -> do         markAllChildrenWithResult runNodeChildren ctx (Failure fr)         return (result, mkSetupTimingInfo setupTime)       (result@(Failure fr), setupTime) -> do@@ -90,8 +90,8 @@             (\(ret, setupTime) -> case ret of                 Left failureReason -> writeIORef result (Failure failureReason, mkSetupTimingInfo setupTime)                 Right intro -> do-                  (ret, teardownTime) <- timed $ runExampleM (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|])-                  writeIORef result (ret, ExtraTimingInfo (Just setupTime) (Just teardownTime))+                  (ret', teardownTime) <- timed $ runExampleM (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|])+                  writeIORef result (ret', ExtraTimingInfo (Just setupTime) (Just teardownTime))             )             (\(ret, _setupTime) -> case ret of                 Left failureReason@(Pending {}) -> do@@ -220,11 +220,6 @@             whenJust baseContextErrorSymlinksDir $ \errorsDir ->               whenJust baseContextPath $ \dir -> do                 whenJust baseContextRunRoot $ \runRoot -> do-                  -- Get a relative path from the error dir to the results dir. System.FilePath doesn't want to-                  -- introduce ".." components, so we have to do it ourselves-                  let errorDirDepth = L.length $ splitPath $ makeRelative runRoot errorsDir-                  let relativePath = joinPath (L.replicate errorDirDepth "..") </> (makeRelative runRoot dir)-                   let symlinkBaseName = case runTreeLoc of                         Nothing -> takeFileName dir                         Just loc -> [i|#{srcLocFile loc}:#{srcLocStartLine loc}_#{takeFileName dir}|]@@ -236,9 +231,14 @@                   when exists $ removePathForcibly symlinkPath  #ifndef mingw32_HOST_OS+                  -- Get a relative path from the error dir to the results dir. System.FilePath doesn't want to+                  -- introduce ".." components, so we have to do it ourselves+                  let errorDirDepth = L.length $ splitPath $ makeRelative runRoot errorsDir+                   -- Don't do createDirectoryLink on Windows, as creating symlinks is generally not allowed for users.                   -- See https://security.stackexchange.com/questions/10194/why-do-you-have-to-be-an-admin-to-create-a-symlink-in-windows                   -- TODO: could we detect if this permission is available?+                  let relativePath = joinPath (L.replicate errorDirDepth "..") </> (makeRelative runRoot dir)                   liftIO $ createDirectoryLink relativePath symlinkPath #endif @@ -340,7 +340,7 @@     wrapInFailureReasonIfNecessary msg e = return $ Left $ case fromException e of       Just (x :: FailureReason) -> x       _ -> case fromException e of-        Just (SomeExceptionWithCallStack e cs) -> GotException (Just cs) msg (SomeExceptionWithEq (SomeException e))+        Just (SomeExceptionWithCallStack e' cs) -> GotException (Just cs) msg (SomeExceptionWithEq (SomeException e'))         _ -> GotException Nothing msg (SomeExceptionWithEq e)  recordExceptionInStatus :: (MonadIO m) => TVar Status -> SomeException -> m ()@@ -355,7 +355,7 @@     Running {statusStartTime, statusSetupTime} -> Done statusStartTime endTime statusSetupTime Nothing ret     _ -> Done endTime endTime Nothing Nothing ret -timed :: (MonadMask m, MonadIO m) => m a -> m (a, NominalDiffTime)+timed :: (MonadIO m) => m a -> m (a, NominalDiffTime) timed action = do   startTime <- liftIO getCurrentTime   ret <- action

@@ -22,22 +22,22 @@   ) where  import Control.Concurrent-import Control.Concurrent.Async.Lifted import Control.DeepSeq (rnf) import qualified Control.Exception as C-import Control.Exception.Safe import Control.Monad import Control.Monad.IO.Class+import Control.Monad.IO.Unlift import Control.Monad.Logger hiding (logOther)-import Control.Monad.Trans.Control (MonadBaseControl) import Data.String.Interpolate-import Data.Text+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@@ -74,11 +74,11 @@  -- | Spawn a process with its stdout and stderr connected to the logging system. -- Every line output by the process will be fed to a 'debug' call.-createProcessWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => CreateProcess -> m ProcessHandle-createProcessWithLogging = createProcessWithLogging' LevelDebug+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' :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => LogLevel -> CreateProcess -> m ProcessHandle+createProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => LogLevel -> CreateProcess -> m ProcessHandle createProcessWithLogging' logLevel cp = do   (hRead, hWrite) <- liftIO createPipe @@ -88,18 +88,18 @@    _ <- async $ forever $ do     line <- liftIO $ hGetLine hRead-    logOther logLevel [i|#{name}: #{line}|]+    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 :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => CreateProcess -> String -> m String-readCreateProcessWithLogging = readCreateProcessWithLogging' LevelDebug+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' :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => LogLevel -> CreateProcess -> String -> m String+readCreateProcessWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m String readCreateProcessWithLogging' logLevel cp input = do   (hReadErr, hWriteErr) <- liftIO createPipe @@ -109,12 +109,12 @@    _ <- async $ forever $ do     line <- liftIO $ hGetLine hReadErr-    logOther logLevel [i|#{name}: #{line}|]+    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+  (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@@ -131,8 +131,8 @@         -- wait on the process         ex <- waitForProcess p         return (ex, output)-      (Nothing, _) -> liftIO $ throw $ userError "readCreateProcessWithStderrLogging: Failed to get a stdin handle."-      (_, Nothing) -> liftIO $ throw $ userError "readCreateProcessWithStderrLogging: Failed to get a stdout handle."+      (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@@ -149,11 +149,11 @@  -- | Spawn a process with its stdout and stderr connected to the logging system. -- Every line output by the process will be fed to a 'debug' call.-createProcessWithLoggingAndStdin :: (MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => CreateProcess -> String -> m ProcessHandle-createProcessWithLoggingAndStdin = createProcessWithLoggingAndStdin' LevelDebug+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' :: (MonadIO m, MonadFail m, MonadBaseControl IO m, MonadLogger m, HasCallStack) => LogLevel -> CreateProcess -> String -> m ProcessHandle+createProcessWithLoggingAndStdin' :: (HasCallStack, MonadUnliftIO m, MonadFail m, MonadLogger m) => LogLevel -> CreateProcess -> String -> m ProcessHandle createProcessWithLoggingAndStdin' logLevel cp input = do   (hRead, hWrite) <- liftIO createPipe @@ -163,7 +163,7 @@    _ <- async $ forever $ do     line <- liftIO $ hGetLine hRead-    logOther logLevel [i|#{name}: #{line}|]+    logOtherCS callStack logLevel [i|#{name}: #{line}|]    (Just inh, _, _, p) <- liftIO $ createProcess (     cp { std_out = UseHandle hWrite@@ -179,11 +179,11 @@   return p  -- | Higher level version of 'createProcessWithLogging', accepting a shell command.-callCommandWithLogging :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => String -> m ()-callCommandWithLogging = callCommandWithLogging' LevelDebug+callCommandWithLogging :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => String -> m ()+callCommandWithLogging = withFrozenCallStack (callCommandWithLogging' LevelDebug)  -- | Higher level version of 'createProcessWithLogging'', accepting a shell command.-callCommandWithLogging' :: (MonadIO m, MonadBaseControl IO m, MonadLogger m) => LogLevel -> String -> m ()+callCommandWithLogging' :: (HasCallStack, MonadUnliftIO m, MonadLogger m) => LogLevel -> String -> m () callCommandWithLogging' logLevel cmd = do   (hRead, hWrite) <- liftIO createPipe @@ -195,21 +195,21 @@    _ <- async $ forever $ do     line <- liftIO $ hGetLine hRead-    logOther logLevel [i|#{cmd}: #{line}|]+    logOtherCS callStack logLevel [i|#{cmd}: #{line}|]    liftIO (waitForProcess p) >>= \case     ExitSuccess -> return ()-    ExitFailure r -> liftIO $ throw $ userError [i|callCommandWithLogging failed for '#{cmd}': '#{r}'|]+    ExitFailure r -> liftIO $ throwIO $ userError [i|callCommandWithLogging failed for '#{cmd}': '#{r}'|]   -- * Util  -- Copied from System.Process withForkWait :: IO () -> (IO () ->  IO a) -> IO a-withForkWait async body = do+withForkWait asy body = do   waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))   mask $ \restore -> do-    tid <- forkIO $ try (restore async) >>= putMVar waitVar+    tid <- forkIO $ try (restore asy) >>= putMVar waitVar     let wait = takeMVar waitVar >>= either throwIO return     restore (body wait) `C.onException` killThread tid @@ -222,7 +222,7 @@ -- 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)+  ioError (mkIOError OtherError (fun ++ ": " ++ cmd +++                                 Prelude.concatMap ((' ':) . show) args +++                                 " (exit " ++ show exit_code ++ ")")+            Nothing Nothing)

@@ -35,7 +35,10 @@   -- * Context classes   , BaseContext   , HasBaseContext+  , HasBaseContextMonad   , HasCommandLineOptions+  , SomeCommandLineOptions(..)+  , HasSomeCommandLineOptions    -- * Result types   , Result(..)

@@ -1,8 +1,8 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE TypeApplications #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}  -- | Wrapper around 'parallel' for limiting the threads using a semaphore. @@ -13,33 +13,40 @@   , parallelNFromArgs   , parallelNFromArgs' +  , defaultParallelNodeOptions++  -- * Types   , parallelSemaphore   , HasParallelSemaphore--  , defaultParallelNodeOptions   ) where  import Control.Concurrent.QSem-import Control.Exception.Safe import Control.Monad import Control.Monad.IO.Class-import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.IO.Unlift import Test.Sandwich.Contexts import Test.Sandwich.Types.ArgParsing import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec+import UnliftIO.Exception    -- | Wrapper around 'parallel'. Introduces a semaphore to limit the parallelism to N threads. parallelN :: (-  MonadBaseControl IO m, MonadIO m, MonadMask m+  MonadUnliftIO m   ) => Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m () parallelN = parallelN' defaultParallelNodeOptions  parallelN' :: (-  MonadBaseControl IO m, MonadIO m, MonadMask m-  ) => NodeOptions -> Int -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()+  MonadUnliftIO m+  )+  -- | Node options+  => NodeOptions+  -- | Number of threads+  -> Int+  -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m ()+  -> SpecFree context m () parallelN' nodeOptions n children = introduce "Introduce parallel semaphore" parallelSemaphore (liftIO $ newQSem n) (const $ return ()) $   parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children   where claimRunSlot f = do@@ -48,13 +55,23 @@  -- | Same as 'parallelN', but extracts the semaphore size from the command line options. parallelNFromArgs :: forall context a m. (-  MonadBaseControl IO m, MonadIO m, MonadMask m, HasCommandLineOptions context a-  ) => (CommandLineOptions a -> Int) -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()+  MonadUnliftIO m, HasCommandLineOptions context a+  )+  -- | Callback to extract the semaphore size+  => (CommandLineOptions a -> Int)+  -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m ()+  -> SpecFree context m () parallelNFromArgs = parallelNFromArgs' @context @a defaultParallelNodeOptions  parallelNFromArgs' :: forall context a m. (-  MonadBaseControl IO m, MonadIO m, MonadMask m, HasCommandLineOptions context a-  ) => NodeOptions -> (CommandLineOptions a -> Int) -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m () -> SpecFree context m ()+  MonadUnliftIO m, HasCommandLineOptions context a+  )+  -- | Node options+  => NodeOptions+  -- | Callback to extract the semaphore size+  -> (CommandLineOptions a -> Int)+  -> SpecFree (LabelValue "parallelSemaphore" QSem :> context) m ()+  -> SpecFree context m () parallelNFromArgs' nodeOptions getParallelism children = introduce "Introduce parallel semaphore" parallelSemaphore getQSem (const $ return ()) $   parallel' nodeOptions $ aroundEach "Take parallel semaphore" claimRunSlot children   where

@@ -24,13 +24,13 @@ import Test.Sandwich.Types.Spec  -extractValues :: (forall context. RunNodeWithStatus context s l t -> a) -> RunNodeWithStatus context s l t -> [a]+extractValues :: (forall ctx. RunNodeWithStatus ctx s l t -> a) -> RunNodeWithStatus context s l t -> [a] extractValues f node@(RunNodeIt {}) = [f node] extractValues f node@(RunNodeIntroduce {runNodeChildrenAugmented}) = (f node) : (concatMap (extractValues f) runNodeChildrenAugmented) extractValues f node@(RunNodeIntroduceWith {runNodeChildrenAugmented}) = (f node) : (concatMap (extractValues f) runNodeChildrenAugmented) extractValues f node = (f node) : (concatMap (extractValues f) (runNodeChildren node)) -extractValuesControlRecurse :: (forall context. RunNodeWithStatus context s l t -> (Bool, a)) -> RunNodeWithStatus context s l t -> [a]+extractValuesControlRecurse :: (forall ctx. RunNodeWithStatus ctx s l t -> (Bool, a)) -> RunNodeWithStatus context s l t -> [a] extractValuesControlRecurse f node@(RunNodeIt {}) = [snd $ f node] extractValuesControlRecurse f node@(RunNodeIntroduce {runNodeChildrenAugmented}) = case f node of   (True, x) -> x : (concatMap (extractValuesControlRecurse f) runNodeChildrenAugmented)

@@ -32,6 +32,7 @@ import Test.Sandwich.Types.Spec hiding (location)  +constId :: b -> a -> a constId = const id  data GetSpecFromFolderOptions = GetSpecFromFolderOptions {

@@ -8,8 +8,8 @@  import Control.Monad import Data.String.Interpolate-import Language.Haskell.Exts-import Language.Haskell.TH (runIO, reportWarning)+import Language.Haskell.Exts hiding (name)+import Language.Haskell.TH (Q, runIO, reportWarning)  -- import Debug.Trace @@ -19,6 +19,7 @@  -- | Use haskell-src-exts to determine if a give Haskell file has an exported main function -- Parse with all extensions enabled, which will hopefully parse anything+fileHasMainFunction :: FilePath -> ShouldWarnOnParseError -> Q Bool fileHasMainFunction path shouldWarnOnParseError = runIO (parseFileWithExts [x | x@(EnableExtension _) <- knownExtensions] path) >>= \case   x@(ParseFailed {}) -> do     when (shouldWarnOnParseError == WarnOnParseError) $@@ -52,7 +53,7 @@ isMainFunctionName (Symbol _ "main") = True isMainFunctionName _ = False -isMainDecl :: (Show l) => Decl l -> Bool+isMainDecl :: Decl l -> Bool isMainDecl (PatBind _ (PVar _ (Ident _ "main")) _ _) = True -- isMainDecl decl = trace [i|Looking at decl: #{decl}|] False isMainDecl _ = False

@@ -24,7 +24,9 @@     relativePath = (takeFileName relativeTo) </> (makeRelative relativeTo path)     pathParts = splitDirectories $ dropExtension relativePath     baseModuleName = last pathParts-    moduleName = head $ filter doesNotExist (baseModuleName : [baseModuleName <> show n | n <- [1..]])+    moduleName = case filter doesNotExist (baseModuleName : [baseModuleName <> show n | n <- [(1 :: Integer)..]]) of+      (x:_) -> x+      _ -> error "Impossible"     doesNotExist x = isNothing (M.lookup x mm) addModuleToMap _ _ mm _ = mm 

@@ -1,13 +1,13 @@-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE MonoLocalBinds #-}+{-# LANGUAGE TypeOperators #-}  module Test.Sandwich.TestTimer where  import Control.Concurrent-import Control.Exception.Safe import Control.Monad.IO.Class+import Control.Monad.IO.Unlift import Control.Monad.Reader import Control.Monad.Trans.State import qualified Data.Aeson as A@@ -26,6 +26,7 @@ import Test.Sandwich.Types.Spec import Test.Sandwich.Types.TestTimer import Test.Sandwich.Util (whenJust)+import UnliftIO.Exception   type EventName = T.Text@@ -34,24 +35,42 @@ -- * 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.-timeAction :: (MonadMask m, MonadIO m, MonadReader context m, HasBaseContext context, HasTestTimer context) => EventName -> m a -> m a+timeAction :: (MonadUnliftIO m, HasBaseContextMonad context m, HasTestTimer context)+  -- | Event name+  => EventName+  -> m a+  -> m a timeAction eventName action = do   tt <- asks getTestTimer   BaseContext {baseContextTestTimerProfile} <- asks getBaseContext   timeAction' tt baseContextTestTimerProfile eventName action  -- | Time a given action with a given profile name and event name. Use when you want to manually specify the profile name.-timeActionByProfile :: (MonadMask m, MonadIO m, MonadReader context m, HasTestTimer context) => ProfileName -> EventName -> m a -> m a+timeActionByProfile :: (MonadUnliftIO m, MonadReader context m, HasTestTimer context)+  -- | Profile name+  => ProfileName+  -- | Event name+  -> EventName+  -> m a+  -> m a timeActionByProfile profileName eventName action = do   tt <- asks getTestTimer   timeAction' tt profileName eventName action  -- | Introduce a new timing profile name.-withTimingProfile :: (Monad m) => ProfileName -> SpecFree (LabelValue "testTimerProfile" TestTimerProfile :> context) m () -> SpecFree context m ()-withTimingProfile name = introduce' timingNodeOptions [i|Switch test timer profile to '#{name}'|] testTimerProfile (pure $ TestTimerProfile name) (\_ -> return ())+withTimingProfile :: (Monad m)+  -- | Profile name+  => ProfileName+  -> SpecFree (LabelValue "testTimerProfile" TestTimerProfile :> context) m ()+  -> SpecFree context m ()+withTimingProfile pn = introduce' timingNodeOptions [i|Switch test timer profile to '#{pn}'|] testTimerProfile (pure $ TestTimerProfile pn) (\_ -> return ())  -- | Introduce a new timing profile name dynamically. The given 'ExampleT' should come up with the name and return it.-withTimingProfile' :: (Monad m) => ExampleT context m ProfileName -> SpecFree (LabelValue "testTimerProfile" TestTimerProfile :> context) m () -> SpecFree context m ()+withTimingProfile' :: (Monad m)+  -- | Callback to generate the profile name+  => ExampleT context m ProfileName+  -> SpecFree (LabelValue "testTimerProfile" TestTimerProfile :> context) m ()+  -> SpecFree context m () withTimingProfile' getName = introduce' timingNodeOptions [i|Switch test timer profile to dynamic value|] testTimerProfile (TestTimerProfile <$> getName) (\_ -> return ())  -- * Core@@ -81,7 +100,7 @@   whenJust testTimerHandle hClose   readMVar testTimerSpeedScopeFile >>= BL.writeFile (testTimerBasePath </> "speedscope.json") . A.encode -timeAction' :: (MonadMask m, MonadIO m) => TestTimer -> T.Text -> T.Text -> m a -> m a+timeAction' :: (MonadUnliftIO m) => TestTimer -> T.Text -> T.Text -> m a -> m a timeAction' NullTestTimer _ _ = id timeAction' (SpeedScopeTestTimer {..}) profileName eventName = bracket_   (liftIO $ modifyMVar_ testTimerSpeedScopeFile $ \file -> do@@ -104,7 +123,7 @@     -- | 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 -> SpeedScopeEventType -> SpeedScopeFile-    handleSpeedScopeEvent initialFile time typ = flip execState initialFile $ do+    handleSpeedScopeEvent initialFile time eventType = flip execState initialFile $ do       frameID <- get >>= \f -> case S.findIndexL (== SpeedScopeFrame eventName) (f ^. shared . frames) of         Just j -> return j         Nothing -> do@@ -117,5 +136,5 @@           modify' $ over profiles (\x -> x <> [newProfile profileName time])           return $ L.length (f ^. profiles) -      modify' $ over (profiles . ix profileIndex . events) (S.|> (SpeedScopeEvent typ frameID time))+      modify' $ over (profiles . ix profileIndex . events) (S.|> (SpeedScopeEvent eventType frameID time))               . over (profiles . ix profileIndex . endValue) (max time)

@@ -1,10 +1,11 @@-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module Test.Sandwich.Types.RunTree where @@ -14,6 +15,7 @@ import Control.Monad.IO.Class import Control.Monad.IO.Unlift import Control.Monad.Logger+import Control.Monad.Reader import qualified Data.ByteString.Char8 as BS8 import Data.Sequence hiding ((:>)) import qualified Data.Set as S@@ -117,10 +119,8 @@  -- | Context passed around through the evaluation of a RunTree data RunTreeContext = RunTreeContext {-  runTreeCurrentFolder :: Maybe FilePath-  , runTreeCurrentAncestors :: Seq Int-  , runTreeIndexInParent :: Int-  , runTreeNumSiblings :: Int+  runTreeCurrentAncestors :: Seq Int+  , runTreeRootFolderAndNumChildren :: Maybe (FilePath, Int)   }  -- * Base context@@ -156,23 +156,37 @@  type CoreSpec = Spec BaseContext IO -type TopSpec = forall context. HasBaseContext context => SpecFree context IO ()+type TopSpec = forall context. (HasBaseContext context, Typeable context) => SpecFree context IO () +type HasBaseContextMonad context m = (HasBaseContext context, MonadReader context m)+ -- * Specs with command line options provided +commandLineOptions :: Label "commandLineOptions" (CommandLineOptions a) commandLineOptions = Label :: Label "commandLineOptions" (CommandLineOptions a)  -- | Has-* class for asserting a 'CommandLineOptions a' is available. type HasCommandLineOptions context a = HasLabel context "commandLineOptions" (CommandLineOptions a) +-- | Existential wrapper for 'CommandLineOptions a'.+someCommandLineOptions :: Label "someCommandLineOptions" SomeCommandLineOptions+someCommandLineOptions = Label :: Label "someCommandLineOptions" SomeCommandLineOptions+data SomeCommandLineOptions where+  SomeCommandLineOptions :: CommandLineOptions a -> SomeCommandLineOptions+type HasSomeCommandLineOptions context = HasLabel context "someCommandLineOptions" SomeCommandLineOptions+ type TopSpecWithOptions = forall context. (-  HasBaseContext context+  Typeable context+  , HasBaseContext context   , HasCommandLineOptions context ()+  , HasSomeCommandLineOptions context   ) => SpecFree context IO ()  type TopSpecWithOptions' a = forall context. (-  HasBaseContext context+  Typeable context+  , HasBaseContext context   , HasCommandLineOptions context a+  , HasSomeCommandLineOptions context   ) => SpecFree context IO ()  -- * Formatter@@ -224,21 +238,21 @@   <> "] ("   <> toLogStr src   <> ") "-  <> (if isDefaultLoc loc then "" else "@(" <> toLogStr (BS8.pack $ fileLocStr loc) <> ") ")+  <> (if isDefaultLoc loc then "" else "@(" <> toLogStr (BS8.pack fileLocStr) <> ") ")   <> msg   <> "\n"    where     defaultLogLevelStr :: LogLevel -> LogStr-    defaultLogLevelStr level = case level of+    defaultLogLevelStr lev = case lev of       LevelOther t -> toLogStr t-      _ -> toLogStr $ BS8.pack $ Prelude.drop 5 $ show level+      _ -> toLogStr $ BS8.pack $ Prelude.drop 5 $ show lev      isDefaultLoc :: Loc -> Bool     isDefaultLoc (Loc "<unknown>" "<unknown>" "<unknown>" (0,0) (0,0)) = True     isDefaultLoc _ = False -    fileLocStr loc = (loc_package loc) ++ ':' : (loc_module loc) +++    fileLocStr = (loc_package loc) ++ ':' : (loc_module loc) ++       ' ' : (loc_filename loc) ++ ':' : (line loc) ++ ':' : (char loc)       where         line = show . fst . loc_start

@@ -1,25 +1,28 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# OPTIONS_GHC -fno-warn-redundant-constraints #-}  -- | The core Spec/SpecCommand types, used to define the test free monad.  module Test.Sandwich.Types.Spec where  import Control.Applicative-import Control.Exception.Safe import Control.Monad.Base+import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow) import Control.Monad.Free import Control.Monad.Free.TH import Control.Monad.IO.Unlift@@ -35,11 +38,14 @@ import GHC.TypeLits import Graphics.Vty.Image (Image) import Safe+import Type.Reflection+import UnliftIO.Exception  #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail #endif +#define GHC_9_0_X (__GLASGOW_HASKELL__ >= 900 && __GLASGOW_HASKELL__ < 902)  -- * ExampleM monad @@ -68,7 +74,7 @@   liftBaseWith = defaultLiftBaseWith   restoreM = defaultRestoreM -instance (Monad m, MonadThrow m) => MonadFail (ExampleT context m) where+instance (MonadIO m) => MonadFail (ExampleT context m) where   fail :: (HasCallStack) => String -> ExampleT context m a   fail = throwIO . Reason (Just callStack) @@ -84,8 +90,14 @@   setupTime :: Maybe NominalDiffTime   , teardownTime :: Maybe NominalDiffTime   }++emptyExtraTimingInfo :: ExtraTimingInfo emptyExtraTimingInfo = ExtraTimingInfo Nothing Nothing++mkSetupTimingInfo :: NominalDiffTime -> ExtraTimingInfo mkSetupTimingInfo dt = ExtraTimingInfo (Just dt) Nothing++mkTeardownTimingInfo :: NominalDiffTime -> ExtraTimingInfo mkTeardownTimingInfo dt = ExtraTimingInfo Nothing (Just dt)  data ShowEqBox = forall s. (Show s, Eq s) => SEB s@@ -136,7 +148,7 @@  data Label (l :: Symbol) a = Label -data LabelValue (l :: Symbol) a = LabelValue a+data 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@@ -149,7 +161,38 @@ instance {-# OVERLAPPING #-} HasLabel context l a => HasLabel (intro :> context) l a where   getLabelValue l (_ :> ctx) = getLabelValue l ctx +getLabelValueMaybe :: forall context l a. (KnownSymbol l, Typeable a, Typeable context) => Label l a -> context -> Maybe a+getLabelValueMaybe _ ctx = unLabelValue <$> decomposeContext @(LabelValue l a) ctx+  where+    -- | https://stackoverflow.com/questions/78224748/extract-a-maybe-from-a-heterogeneous-collection+    decomposeContext :: forall needle haystack. (+      Typeable needle, Typeable haystack+      ) => haystack -> Maybe needle+    decomposeContext haystack = case typeOf haystack of+      (eqTypeRep (typeRep @needle) -> Just HRefl) -> Just haystack+      App (App (eqTypeRep (typeRep @(:>)) -> Just HRefl) a) b -> let+        part1 :> part2 = haystack+        in+        withTypeable a (decomposeContext part1) <|> withTypeable b (decomposeContext part2)+      _ -> Nothing +-- | https://stackoverflow.com/questions/78224748/extract-a-maybe-from-a-heterogeneous-collection+-- extractContext :: forall c a b. (Typeable a, Typeable b, Typeable c) => a :> b -> Maybe c+-- extractContext (a :> b)+--   -- handle `Int :> a`+--   | Just x <- cast a = Just x+--   -- handle `x :> (y :> z)`+--   --   extract type (of right-hand side) as:  c `op` d+--   | App (App op c) d <- typeOf b+--   --   check op ~ (:>)+--   , Just HRefl <- eqTypeRep op (TypeRep @(:>))+--   --   extract Typeable c, Typeable d, and recurse+--     = withTypeable c $ withTypeable d $ extractContext b+--   -- handle `x :> Int`+--   | Just x <- cast b = Just x+--   -- handle remaining cases+--   | otherwise = Nothing+ -- * Free monad language  data (a :: Type) :> (b :: Type) = a :> b@@ -366,7 +409,7 @@   -- ^ 'Label' under which to introduce the value   -> ExampleT context m intro   -- ^ Action to produce the new value (of type 'intro')-  -> (intro -> ExampleT context m ())+  -> ((HasCallStack) => intro -> ExampleT context m ())   -- ^ Action to clean up the new value   -> SpecFree (LabelValue l intro :> context) m ()   -- ^ Child spec tree@@ -383,7 +426,7 @@   -- ^ 'Label' under which to introduce the value   -> ExampleT context m intro   -- ^ Action to produce the new value (of type 'intro')-  -> (intro -> ExampleT context m ())+  -> ((HasCallStack) => intro -> ExampleT context m ())   -- ^ Action to clean up the new value   -> SpecFree (LabelValue l intro :> context) m ()   -- ^ Child spec tree@@ -402,7 +445,7 @@   -- ^ 'Label' under which to introduce the value   -> ExampleT context m intro   -- ^ Action to produce the new value (of type 'intro')-  -> (intro -> ExampleT context m ())+  -> ((HasCallStack) => intro -> ExampleT context m ())   -- ^ Action to clean up the new value   -> SpecFree (LabelValue l intro :> context) m ()   -- ^ Child spec tree@@ -416,7 +459,11 @@   -- ^ String label for this node   -> Label l intro   -- ^ 'Label' under which to introduce the value+#if GHC_9_0_X   -> ((intro -> ExampleT context m [Result]) -> ExampleT context m ())+#else+  -> (((HasCallStack) => intro -> ExampleT context m [Result]) -> ExampleT context m ())+#endif   -- ^ Callback to receive the new value and the child tree.   -> SpecFree (LabelValue l intro :> context) m ()   -- ^ Child spec tree@@ -431,7 +478,11 @@   -- ^ String label for this node   -> Label l intro   -- ^ 'Label' under which to introduce the value+#if GHC_9_0_X   -> ((intro -> ExampleT context m [Result]) -> ExampleT context m ())+#else+  -> (((HasCallStack) => intro -> ExampleT context m [Result]) -> ExampleT context m ())+#endif   -- ^ Callback to receive the new value and the child tree.   -> SpecFree (LabelValue l intro :> context) m ()   -- ^ Child spec tree@@ -448,7 +499,11 @@   -- ^ String label for this node   -> Label l intro   -- ^ 'Label' under which to introduce the value+#if GHC_9_0_X   -> ((intro -> ExampleT context m [Result]) -> ExampleT context m ())+#else+  -> (((HasCallStack) => intro -> ExampleT context m [Result]) -> ExampleT context m ())+#endif   -- ^ Callback to receive the new value and the child tree.   -> SpecFree (LabelValue l intro :> context) m ()   -- ^ Child spec tree@@ -703,10 +758,14 @@  -- * ---------------------------------------------------------- -unwrapContext :: forall m introduce context. (Monad m) => (ExampleT context m [Result] -> ExampleT context m ()) -> ExampleT (introduce :> context) m [Result] -> ExampleT (introduce :> context) m ()+unwrapContext :: forall m introduce context. (+  Monad m+  ) => (ExampleT context m [Result] -> ExampleT context m ())+    -> ExampleT (introduce :> context) m [Result]+    -> ExampleT (introduce :> context) m () unwrapContext f (ExampleT action) = do-  i :> _ <- ask-  ExampleT $ withReaderT (\(_ :> context) -> context) $ unExampleT $ f $ ExampleT (withReaderT (i :>) action)+  i' :> _ <- ask+  ExampleT $ withReaderT (\(_ :> context) -> context) $ unExampleT $ f $ ExampleT (withReaderT (i' :>) action)   -- | Convert a spec to a run tree@@ -716,4 +775,4 @@ alterTopLevelNodeOptions _ x@(Pure _) = x  systemVisibilityThreshold :: Int-systemVisibilityThreshold = 150+systemVisibilityThreshold = 200

@@ -93,6 +93,7 @@                  }) ''SpeedScopeFile) $(makeLensesWith testTimerLensRules ''SpeedScopeFile) +emptySpeedScopeFile :: SpeedScopeFile emptySpeedScopeFile =   SpeedScopeFile {     _exporter = "sandwich-test-exporter"@@ -131,6 +132,7 @@ class HasTestTimer context where   getTestTimer :: context -> TestTimer +testTimerProfile :: Label "testTimerProfile" TestTimerProfile testTimerProfile = Label :: Label "testTimerProfile" TestTimerProfile  newtype TestTimerProfile = TestTimerProfile T.Text

@@ -0,0 +1,70 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE RankNTypes #-}++{-|++This module contains helper functions for waiting.++It can be very useful in tests to retry something, with a reasonable backoff policy to prevent the test from consuming lots of CPU while waiting.++-}+++module Test.Sandwich.Waits (+  -- * General waits+  waitUntil+  , waitUntil'+  , defaultRetryPolicy+  ) where++import Control.Monad.IO.Unlift+import Data.String.Interpolate+import Data.Time+import Data.Typeable+import GHC.Stack+import System.Timeout (Timeout)+import Test.Sandwich+import UnliftIO.Exception+import UnliftIO.Retry+import UnliftIO.Timeout+++-- | Keep trying an action up to a timeout while it fails with a 'FailureReason'.+-- Use exponential backoff, with delays capped at 1 second.+waitUntil :: forall m a. (HasCallStack, MonadUnliftIO m) => Double -> m a -> m a+waitUntil = waitUntil' defaultRetryPolicy++-- | The default retry policy.+defaultRetryPolicy :: RetryPolicy+defaultRetryPolicy = capDelay 1_000_000 $ exponentialBackoff 1_000++-- | Same as 'waitUntil', but with a configurable retry policy.+waitUntil' :: forall m a. (HasCallStack, MonadUnliftIO m) => RetryPolicy -> Double -> m a -> m a+waitUntil' policy timeInSeconds action = do+  startTime <- liftIO getCurrentTime++  recoveringDynamic policy [handleFailureReasonException startTime] $ \_status ->+    rethrowTimeoutExceptionWithCallStack $+      timeout (round (timeInSeconds * 1_000_000)) action >>= \case+        Nothing -> expectationFailure [i|Action timed out in waitUntil|]+        Just x -> return x++  where+    handleFailureReasonException startTime _status = Handler $ \(_ :: FailureReason) ->+      retryUnlessTimedOut startTime++    retryUnlessTimedOut :: UTCTime -> m RetryAction+    retryUnlessTimedOut startTime = do+      now <- liftIO getCurrentTime+      let thresh = secondsToNominalDiffTime (realToFrac timeInSeconds)+      if | (diffUTCTime now startTime) > thresh -> return DontRetry+         | otherwise -> return ConsultPolicy++    rethrowTimeoutExceptionWithCallStack :: (HasCallStack) => m a -> m a+    rethrowTimeoutExceptionWithCallStack = handleSyncOrAsync $ \(e@(SomeException inner)) ->+      if | Just (_ :: Timeout) <- fromExceptionUnwrap e -> do+             throwIO $ Reason (Just (popCallStack 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"+         | otherwise -> do+             throwIO e

@@ -4,7 +4,7 @@   import Control.Concurrent-import Control.Exception.Safe+import UnliftIO.Exception import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans.Writer

@@ -2,7 +2,7 @@  module Before where -import Control.Exception.Safe+import UnliftIO.Exception import Control.Monad.IO.Class import Control.Monad.Trans.Writer import qualified Data.List as L

@@ -2,7 +2,7 @@  module Describe where -import Control.Exception.Safe+import UnliftIO.Exception import Control.Monad.IO.Class import Control.Monad.Trans.Writer import Data.String.Interpolate

@@ -6,7 +6,7 @@ import Control.Concurrent import Control.Concurrent.Async import Control.Concurrent.STM-import Control.Exception.Safe+import UnliftIO.Exception import Control.Monad.IO.Class import Control.Monad.Trans.Writer import Data.Foldable

@@ -1,9 +1,9 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE RankNTypes #-}  module TestUtil where  import Control.Concurrent.STM-import Control.Exception.Safe import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Trans.Writer@@ -13,10 +13,11 @@ import System.Exit import Test.Sandwich import Test.Sandwich.Internal+import UnliftIO.Exception  -- * Main function -mainWith :: (HasCallStack) => WriterT [SomeException] IO () -> IO ()+mainWith :: (HasCallStack) => (HasCallStack => WriterT [SomeException] IO ()) -> IO () mainWith tests = do   results <- execWriterT tests @@ -67,10 +68,10 @@  getMessages fixedTree = fmap (toList . (fmap logEntryStr)) $ concatMap getLogs fixedTree -getStatuses :: (HasCallStack) => RunNodeWithStatus context s l t -> [(String, s)]+getStatuses :: RunNodeWithStatus context s l t -> [(String, s)] getStatuses = extractValues $ \node -> (runTreeLabel $ runNodeCommon node, runTreeStatus $ runNodeCommon node) -getLogs :: (HasCallStack) => RunNodeWithStatus context s l t -> [l]+getLogs :: RunNodeWithStatus context s l t -> [l] getLogs = extractValues $ \node -> runTreeLogs $ runNodeCommon node  statusToResult :: (HasCallStack) => (String, Status) -> Result