diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Tom McLaughlin (c) 2023 +Copyright Tom McLaughlin (c) 2024 All rights reserved. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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(..)) diff --git a/sandwich.cabal b/sandwich.cabal --- a/sandwich.cabal +++ b/sandwich.cabal @@ -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 . 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 diff --git a/src/Test/Sandwich.hs b/src/Test/Sandwich.hs --- a/src/Test/Sandwich.hs +++ b/src/Test/Sandwich.hs @@ -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] diff --git a/src/Test/Sandwich/ArgParsing.hs b/src/Test/Sandwich/ArgParsing.hs --- a/src/Test/Sandwich/ArgParsing.hs +++ b/src/Test/Sandwich/ArgParsing.hs @@ -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 = diff --git a/src/Test/Sandwich/Contexts.hs b/src/Test/Sandwich/Contexts.hs --- a/src/Test/Sandwich/Contexts.hs +++ b/src/Test/Sandwich/Contexts.hs @@ -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 diff --git a/src/Test/Sandwich/Expectations.hs b/src/Test/Sandwich/Expectations.hs --- a/src/Test/Sandwich/Expectations.hs +++ b/src/Test/Sandwich/Expectations.hs @@ -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) diff --git a/src/Test/Sandwich/Formatters/Common/Count.hs b/src/Test/Sandwich/Formatters/Common/Count.hs --- a/src/Test/Sandwich/Formatters/Common/Count.hs +++ b/src/Test/Sandwich/Formatters/Common/Count.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/Common/Util.hs b/src/Test/Sandwich/Formatters/Common/Util.hs --- a/src/Test/Sandwich/Formatters/Common/Util.hs +++ b/src/Test/Sandwich/Formatters/Common/Util.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/FailureReport.hs b/src/Test/Sandwich/Formatters/FailureReport.hs --- a/src/Test/Sandwich/Formatters/FailureReport.hs +++ b/src/Test/Sandwich/Formatters/FailureReport.hs @@ -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:|] diff --git a/src/Test/Sandwich/Formatters/LogSaver.hs b/src/Test/Sandwich/Formatters/LogSaver.hs --- a/src/Test/Sandwich/Formatters/LogSaver.hs +++ b/src/Test/Sandwich/Formatters/LogSaver.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/MarkdownSummary.hs b/src/Test/Sandwich/Formatters/MarkdownSummary.hs --- a/src/Test/Sandwich/Formatters/MarkdownSummary.hs +++ b/src/Test/Sandwich/Formatters/MarkdownSummary.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/Print.hs b/src/Test/Sandwich/Formatters/Print.hs --- a/src/Test/Sandwich/Formatters/Print.hs +++ b/src/Test/Sandwich/Formatters/Print.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/Print/CallStacks.hs b/src/Test/Sandwich/Formatters/Print/CallStacks.hs --- a/src/Test/Sandwich/Formatters/Print/CallStacks.hs +++ b/src/Test/Sandwich/Formatters/Print/CallStacks.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/Print/Color.hs b/src/Test/Sandwich/Formatters/Print/Color.hs --- a/src/Test/Sandwich/Formatters/Print/Color.hs +++ b/src/Test/Sandwich/Formatters/Print/Color.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Test.Sandwich.Formatters.Print.Color where diff --git a/src/Test/Sandwich/Formatters/Print/FailureReason.hs b/src/Test/Sandwich/Formatters/Print/FailureReason.hs --- a/src/Test/Sandwich/Formatters/Print/FailureReason.hs +++ b/src/Test/Sandwich/Formatters/Print/FailureReason.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/Print/Logs.hs b/src/Test/Sandwich/Formatters/Print/Logs.hs --- a/src/Test/Sandwich/Formatters/Print/Logs.hs +++ b/src/Test/Sandwich/Formatters/Print/Logs.hs @@ -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) diff --git a/src/Test/Sandwich/Formatters/Print/PrintPretty.hs b/src/Test/Sandwich/Formatters/Print/PrintPretty.hs --- a/src/Test/Sandwich/Formatters/Print/PrintPretty.hs +++ b/src/Test/Sandwich/Formatters/Print/PrintPretty.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/Print/Printing.hs b/src/Test/Sandwich/Formatters/Print/Printing.hs --- a/src/Test/Sandwich/Formatters/Print/Printing.hs +++ b/src/Test/Sandwich/Formatters/Print/Printing.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -- | Utility functions for printing diff --git a/src/Test/Sandwich/Formatters/Print/Util.hs b/src/Test/Sandwich/Formatters/Print/Util.hs --- a/src/Test/Sandwich/Formatters/Print/Util.hs +++ b/src/Test/Sandwich/Formatters/Print/Util.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/TerminalUI.hs b/src/Test/Sandwich/Formatters/TerminalUI.hs --- a/src/Test/Sandwich/Formatters/TerminalUI.hs +++ b/src/Test/Sandwich/Formatters/TerminalUI.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs b/src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs --- a/src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs +++ b/src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs @@ -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" diff --git a/src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs b/src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs --- a/src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs +++ b/src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs b/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs --- a/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs +++ b/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs @@ -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 |] diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs b/src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs --- a/src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs +++ b/src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs @@ -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) diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Draw/RunTimes.hs b/src/Test/Sandwich/Formatters/TerminalUI/Draw/RunTimes.hs --- a/src/Test/Sandwich/Formatters/TerminalUI/Draw/RunTimes.hs +++ b/src/Test/Sandwich/Formatters/TerminalUI/Draw/RunTimes.hs @@ -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) diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs b/src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs --- a/src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs +++ b/src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs b/src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs --- a/src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs +++ b/src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs @@ -1,5 +1,5 @@ {-# LANGUAGE MultiWayIf #-} --- | +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Test.Sandwich.Formatters.TerminalUI.Draw.TopBox ( topBox diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Filter.hs b/src/Test/Sandwich/Formatters/TerminalUI/Filter.hs --- a/src/Test/Sandwich/Formatters/TerminalUI/Filter.hs +++ b/src/Test/Sandwich/Formatters/TerminalUI/Filter.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Keys.hs b/src/Test/Sandwich/Formatters/TerminalUI/Keys.hs --- a/src/Test/Sandwich/Formatters/TerminalUI/Keys.hs +++ b/src/Test/Sandwich/Formatters/TerminalUI/Keys.hs @@ -1,3 +1,4 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} module Test.Sandwich.Formatters.TerminalUI.Keys where diff --git a/src/Test/Sandwich/Golden.hs b/src/Test/Sandwich/Golden.hs --- a/src/Test/Sandwich/Golden.hs +++ b/src/Test/Sandwich/Golden.hs @@ -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 diff --git a/src/Test/Sandwich/Golden/Update.hs b/src/Test/Sandwich/Golden/Update.hs --- a/src/Test/Sandwich/Golden/Update.hs +++ b/src/Test/Sandwich/Golden/Update.hs @@ -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 diff --git a/src/Test/Sandwich/Internal.hs b/src/Test/Sandwich/Internal.hs --- a/src/Test/Sandwich/Internal.hs +++ b/src/Test/Sandwich/Internal.hs @@ -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 diff --git a/src/Test/Sandwich/Internal/Inspection.hs b/src/Test/Sandwich/Internal/Inspection.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandwich/Internal/Inspection.hs @@ -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) diff --git a/src/Test/Sandwich/Internal/Running.hs b/src/Test/Sandwich/Internal/Running.hs --- a/src/Test/Sandwich/Internal/Running.hs +++ b/src/Test/Sandwich/Internal/Running.hs @@ -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 diff --git a/src/Test/Sandwich/Interpreters/RunTree.hs b/src/Test/Sandwich/Interpreters/RunTree.hs --- a/src/Test/Sandwich/Interpreters/RunTree.hs +++ b/src/Test/Sandwich/Interpreters/RunTree.hs @@ -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) diff --git a/src/Test/Sandwich/Interpreters/RunTree/Util.hs b/src/Test/Sandwich/Interpreters/RunTree/Util.hs --- a/src/Test/Sandwich/Interpreters/RunTree/Util.hs +++ b/src/Test/Sandwich/Interpreters/RunTree/Util.hs @@ -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 diff --git a/src/Test/Sandwich/Interpreters/StartTree.hs b/src/Test/Sandwich/Interpreters/StartTree.hs --- a/src/Test/Sandwich/Interpreters/StartTree.hs +++ b/src/Test/Sandwich/Interpreters/StartTree.hs @@ -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 diff --git a/src/Test/Sandwich/Logging.hs b/src/Test/Sandwich/Logging.hs --- a/src/Test/Sandwich/Logging.hs +++ b/src/Test/Sandwich/Logging.hs @@ -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) diff --git a/src/Test/Sandwich/Misc.hs b/src/Test/Sandwich/Misc.hs --- a/src/Test/Sandwich/Misc.hs +++ b/src/Test/Sandwich/Misc.hs @@ -35,7 +35,10 @@ -- * Context classes , BaseContext , HasBaseContext + , HasBaseContextMonad , HasCommandLineOptions + , SomeCommandLineOptions(..) + , HasSomeCommandLineOptions -- * Result types , Result(..) diff --git a/src/Test/Sandwich/ParallelN.hs b/src/Test/Sandwich/ParallelN.hs --- a/src/Test/Sandwich/ParallelN.hs +++ b/src/Test/Sandwich/ParallelN.hs @@ -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 diff --git a/src/Test/Sandwich/RunTree.hs b/src/Test/Sandwich/RunTree.hs --- a/src/Test/Sandwich/RunTree.hs +++ b/src/Test/Sandwich/RunTree.hs @@ -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) diff --git a/src/Test/Sandwich/TH.hs b/src/Test/Sandwich/TH.hs --- a/src/Test/Sandwich/TH.hs +++ b/src/Test/Sandwich/TH.hs @@ -32,6 +32,7 @@ import Test.Sandwich.Types.Spec hiding (location) +constId :: b -> a -> a constId = const id data GetSpecFromFolderOptions = GetSpecFromFolderOptions { diff --git a/src/Test/Sandwich/TH/HasMainFunction.hs b/src/Test/Sandwich/TH/HasMainFunction.hs --- a/src/Test/Sandwich/TH/HasMainFunction.hs +++ b/src/Test/Sandwich/TH/HasMainFunction.hs @@ -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 diff --git a/src/Test/Sandwich/TH/ModuleMap.hs b/src/Test/Sandwich/TH/ModuleMap.hs --- a/src/Test/Sandwich/TH/ModuleMap.hs +++ b/src/Test/Sandwich/TH/ModuleMap.hs @@ -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 diff --git a/src/Test/Sandwich/TestTimer.hs b/src/Test/Sandwich/TestTimer.hs --- a/src/Test/Sandwich/TestTimer.hs +++ b/src/Test/Sandwich/TestTimer.hs @@ -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) diff --git a/src/Test/Sandwich/Types/RunTree.hs b/src/Test/Sandwich/Types/RunTree.hs --- a/src/Test/Sandwich/Types/RunTree.hs +++ b/src/Test/Sandwich/Types/RunTree.hs @@ -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 "" "" "" (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 diff --git a/src/Test/Sandwich/Types/Spec.hs b/src/Test/Sandwich/Types/Spec.hs --- a/src/Test/Sandwich/Types/Spec.hs +++ b/src/Test/Sandwich/Types/Spec.hs @@ -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 diff --git a/src/Test/Sandwich/Types/TestTimer.hs b/src/Test/Sandwich/Types/TestTimer.hs --- a/src/Test/Sandwich/Types/TestTimer.hs +++ b/src/Test/Sandwich/Types/TestTimer.hs @@ -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 diff --git a/src/Test/Sandwich/Waits.hs b/src/Test/Sandwich/Waits.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandwich/Waits.hs @@ -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 diff --git a/test/Around.hs b/test/Around.hs --- a/test/Around.hs +++ b/test/Around.hs @@ -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 diff --git a/test/Before.hs b/test/Before.hs --- a/test/Before.hs +++ b/test/Before.hs @@ -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 diff --git a/test/Describe.hs b/test/Describe.hs --- a/test/Describe.hs +++ b/test/Describe.hs @@ -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 diff --git a/test/Introduce.hs b/test/Introduce.hs --- a/test/Introduce.hs +++ b/test/Introduce.hs @@ -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 diff --git a/test/TestUtil.hs b/test/TestUtil.hs --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -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