diff --git a/README.md b/README.md deleted file mode 100644 --- a/README.md +++ /dev/null @@ -1,1 +0,0 @@ -# sandwich diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -200,7 +200,7 @@ where options = defaultOptions { optionsTestArtifactsDirectory = TestArtifactsGeneratedDirectory "test_runs" (show <$> getCurrentTime) - , optionsFormatters = [SomeFormatter defaultLogSaverFormatter, SomeFormatter defaultFailureReportFormatter] + , optionsFormatters = [SomeFormatter defaultLogSaverFormatter] , optionsProjectRoot = Just "sandwich" } diff --git a/sandwich.cabal b/sandwich.cabal --- a/sandwich.cabal +++ b/sandwich.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: dafc0d430b62985e6470bd64597adb7947665b8d43fc94fc965d785b8d6d64bf +-- hash: c62375ea166e8c3dbfd6a334d0b931122503e76c6515910590a24530dca64d42 name: sandwich -version: 0.1.0.3 +version: 0.1.0.4 synopsis: Yet another test framework for Haskell description: Please see the . category: Testing @@ -20,7 +20,6 @@ license-file: LICENSE build-type: Simple extra-source-files: - README.md CHANGELOG.md source-repository head @@ -41,8 +40,6 @@ Test.Sandwich.Formatters.Print Test.Sandwich.Formatters.TerminalUI Test.Sandwich.Internal - Test.Sandwich.Internal.Formatters - Test.Sandwich.Internal.Running Test.Sandwich.TH other-modules: Test.Sandwich.ArgParsing @@ -57,6 +54,7 @@ Test.Sandwich.Formatters.Print.PrintPretty Test.Sandwich.Formatters.Print.Types Test.Sandwich.Formatters.Print.Util + Test.Sandwich.Formatters.Silent Test.Sandwich.Formatters.TerminalUI.AttrMap Test.Sandwich.Formatters.TerminalUI.CrossPlatform Test.Sandwich.Formatters.TerminalUI.Draw @@ -68,6 +66,8 @@ Test.Sandwich.Formatters.TerminalUI.Keys Test.Sandwich.Formatters.TerminalUI.OpenInEditor Test.Sandwich.Formatters.TerminalUI.Types + Test.Sandwich.Internal.Formatters + Test.Sandwich.Internal.Running Test.Sandwich.Interpreters.FilterTree Test.Sandwich.Interpreters.FilterTreeModule Test.Sandwich.Interpreters.PrettyShow @@ -129,12 +129,12 @@ , vty default-language: Haskell2010 -executable sandwich-discover +executable sandwich-demo main-is: Main.hs other-modules: Paths_sandwich hs-source-dirs: - discover + app ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: aeson @@ -176,12 +176,12 @@ , vty default-language: Haskell2010 -executable sandwich-exe +executable sandwich-discover main-is: Main.hs other-modules: Paths_sandwich hs-source-dirs: - app + discover ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: aeson diff --git a/src/Test/Sandwich.hs b/src/Test/Sandwich.hs --- a/src/Test/Sandwich.hs +++ b/src/Test/Sandwich.hs @@ -95,6 +95,7 @@ import Test.Sandwich.Internal.Running import Test.Sandwich.Interpreters.FilterTreeModule import Test.Sandwich.Interpreters.RunTree +import Test.Sandwich.Interpreters.RunTree.Util import Test.Sandwich.Logging import Test.Sandwich.Misc import Test.Sandwich.Nodes @@ -203,6 +204,9 @@ forM_ rts cancelNode _ <- installHandler sigINT (Catch shutdown) Nothing + + -- Wait for the tree to finish + mapM_ waitForTree rts -- Wait for all formatters to finish finalResults :: [Either E.SomeException ()] <- forM formatterAsyncs $ E.try . wait 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 @@ -16,8 +16,11 @@ import Options.Applicative import qualified Options.Applicative as OA import System.IO +import Test.Sandwich.Formatters.FailureReport import Test.Sandwich.Formatters.Print.Types +import Test.Sandwich.Formatters.Silent import Test.Sandwich.Formatters.TerminalUI +import Test.Sandwich.Formatters.TerminalUI.Types import Test.Sandwich.Options import Test.Sandwich.Types.ArgParsing @@ -54,7 +57,6 @@ mainCommandLineOptions :: Parser a -> Parser (Maybe IndividualTestModule) -> Parser (CommandLineOptions a) mainCommandLineOptions userOptionsParser individualTestParser = CommandLineOptions - -- sandwich <$> formatter <*> logLevel <*> optional (strOption (long "filter" <> short 'f' <> help "Filter test tree by string matching text example labels" <> metavar "STRING")) @@ -75,8 +77,9 @@ formatter :: Parser FormatterType formatter = flag' Print (long "print" <> help "Print to stdout") + <|> flag' PrintFailures (long "print-failures" <> help "Print failures only to stdout") <|> flag' TUI (long "tui" <> help "Open terminal UI app") - <|> flag' Silent (long "silent" <> help "Run silently (no main formatter)") + <|> flag' Silent (long "silent" <> help "Run silently (print the run root only)") <|> flag Auto Auto (long "auto" <> help "Automatically decide which formatter to use") logLevel :: Parser (Maybe LogLevel) @@ -125,7 +128,9 @@ addOptionsFromArgs :: Options -> CommandLineOptions a -> IO (Options, Int) addOptionsFromArgs baseOptions (CommandLineOptions {..}) = do let printFormatter = SomeFormatter $ defaultPrintFormatter { printFormatterLogLevel = optLogLevel } + let failureReportFormatter = SomeFormatter $ defaultFailureReportFormatter { failureReportLogLevel = optLogLevel } let tuiFormatter = SomeFormatter $ defaultTerminalUIFormatter { terminalUILogLevel = optLogLevel } + let silentFormatter = SomeFormatter defaultSilentFormatter maybeMainFormatter <- case (optRepeatCount, optFormatter) of (x, _) | x /= 1 -> return $ Just printFormatter @@ -134,7 +139,8 @@ False -> return $ Just tuiFormatter (_, TUI) -> return $ Just tuiFormatter (_, Print) -> return $ Just printFormatter - (_, Silent) -> return Nothing + (_, PrintFailures) -> return $ Just failureReportFormatter + (_, Silent) -> return $ Just silentFormatter -- Strip out any "main" formatters since the options control that let baseFormatters = optionsFormatters baseOptions 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 @@ -8,12 +8,17 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} +-- | The failure report formatter is like the print formatter, but it only shows failures. + module Test.Sandwich.Formatters.FailureReport ( defaultFailureReportFormatter + + -- * Options , failureReportUseColor , failureReportLogLevel , failureReportIncludeCallStacks , failureReportIndentSize + , failureReportVisibilityThreshold ) where import Control.Monad @@ -22,8 +27,10 @@ import Control.Monad.Logger import Control.Monad.Reader import Data.Foldable +import Data.Function import qualified Data.Map as M import Data.Maybe +import qualified Data.Sequence as Seq import Data.String.Interpolate import qualified Data.Text as T import System.IO @@ -43,7 +50,8 @@ , failureReportLogLevel :: Maybe LogLevel , failureReportIncludeCallStacks :: Bool , failureReportIndentSize :: Int - } + , failureReportVisibilityThreshold :: Int + } deriving (Show) defaultFailureReportFormatter :: FailureReportFormatter defaultFailureReportFormatter = FailureReportFormatter { @@ -51,6 +59,7 @@ , failureReportLogLevel = Just LevelWarn , failureReportIncludeCallStacks = True , failureReportIndentSize = 4 + , failureReportVisibilityThreshold = 50 } instance Formatter FailureReportFormatter where @@ -59,7 +68,7 @@ finalizeFormatter = printFailureReport printFailureReport :: (MonadIO m, MonadLogger m, MonadCatch m) => FailureReportFormatter -> [RunNode BaseContext] -> BaseContext -> m () -printFailureReport (FailureReportFormatter {..}) rts _bc = do +printFailureReport frf@(FailureReportFormatter {..}) rts _bc = do liftIO $ putStrLn [i|\n\nFailure report:|] let pf = PrintFormatter { @@ -70,31 +79,34 @@ , printFormatterIndentSize = failureReportIndentSize } - let extractFromNode node = let RunNodeCommonWithStatus {..} = runNodeCommon node in (runTreeId, T.pack runTreeLabel) + let extractFromNode node = let RunNodeCommonWithStatus {..} = runNodeCommon node in (runTreeId, (T.pack runTreeLabel, runTreeVisibilityLevel)) let idToLabel = M.fromList $ mconcat [extractValues extractFromNode node | node <- rts] - liftIO $ runReaderT (mapM_ (runWithIndentation idToLabel) rts) (pf, 0, stdout) + liftIO $ runReaderT (mapM_ (runWithIndentation frf idToLabel) rts) (pf, 0, stdout) -runWithIndentation :: M.Map Int T.Text -> RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO () -runWithIndentation idToLabel node = do +runWithIndentation :: FailureReportFormatter -> M.Map Int (T.Text, Int) -> RunNode context -> ReaderT (PrintFormatter, Int, Handle) IO () +runWithIndentation frf@(FailureReportFormatter {..}) idToLabel node = do let common@(RunNodeCommonWithStatus {..}) = runNodeCommon node case node of RunNodeIt {} -> return () - RunNodeIntroduce {..} -> forM_ runNodeChildrenAugmented (runWithIndentation idToLabel) - RunNodeIntroduceWith {..} -> forM_ runNodeChildrenAugmented (runWithIndentation idToLabel) - _ -> forM_ (runNodeChildren node) (runWithIndentation idToLabel) + RunNodeIntroduce {..} -> forM_ runNodeChildrenAugmented (runWithIndentation frf idToLabel) + RunNodeIntroduceWith {..} -> forM_ runNodeChildrenAugmented (runWithIndentation frf idToLabel) + _ -> forM_ (runNodeChildren node) (runWithIndentation frf idToLabel) result <- liftIO $ waitForTree node -- Print the failure reason case result of Success -> return () + Failure (ChildrenFailed {}) -> return () Failure reason -> do p "\n" let ancestorIds = runTreeAncestors - let ancestorNames = fmap (\k -> fromMaybe "?" $ M.lookup k idToLabel) ancestorIds + let ancestorNames = fmap (\k -> fromMaybe ("?", 0) $ M.lookup k idToLabel) ancestorIds + & Seq.filter (\(_, visibilityLevel) -> visibilityLevel <= failureReportVisibilityThreshold) + & fmap fst let label = T.unpack $ T.intercalate ", " (toList ancestorNames) case reason of 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 @@ -1,13 +1,19 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} + -- | A simple formatter that saves all logs from the test to a file. +-- +-- This is a "secondary formatter," i.e. one that can run in the background while a "primary formatter" (such as the TerminalUI or Print formatters) monopolize the foreground. module Test.Sandwich.Formatters.LogSaver ( defaultLogSaverFormatter + + -- * Options , logSaverPath , logSaverLogLevel + -- * Auxiliary types , LogPath(..) ) where @@ -35,6 +41,9 @@ , logSaverFormatter :: LogEntryFormatter -- ^ Formatter function for log entries. } + +instance Show LogSaverFormatter where + show _ = "" -- | A path under which to save logs. data LogPath = 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 @@ -7,12 +7,19 @@ {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE MultiWayIf #-} +-- | The print formatter prints all results from the test tree from top to bottom, as they become available. +-- +-- Documentation can be found . + module Test.Sandwich.Formatters.Print ( defaultPrintFormatter + + -- * Options , printFormatterUseColor , printFormatterLogLevel , printFormatterIncludeCallStacks , printFormatterIndentSize + , printFormatterVisibilityThreshold ) where import Control.Concurrent.STM 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 @@ -25,6 +25,8 @@ printFailureReason :: FailureReason -> ReaderT (PrintFormatter, Int, Handle) IO () printFailureReason (Reason _ s) = do printShowBoxPrettyWithTitle "Reason: " (SEB s) +printFailureReason (ChildrenFailed _ n) = do + picn midWhite ([i|#{n} #{if n == 1 then ("child" :: String) else "children"} failed|] :: String) printFailureReason (ExpectedButGot _ seb1 seb2) = do printShowBoxPrettyWithTitle "Expected: " seb1 printShowBoxPrettyWithTitle "But got: " seb2 diff --git a/src/Test/Sandwich/Formatters/Print/Types.hs b/src/Test/Sandwich/Formatters/Print/Types.hs --- a/src/Test/Sandwich/Formatters/Print/Types.hs +++ b/src/Test/Sandwich/Formatters/Print/Types.hs @@ -5,11 +5,16 @@ data PrintFormatter = PrintFormatter { printFormatterUseColor :: Bool + -- ^ Whether to use color in output. Defaults to 'True'. , printFormatterLogLevel :: Maybe LogLevel + -- ^ Log level to show in output. Defaults to 'LevelWarn'. , printFormatterVisibilityThreshold :: Int + -- ^ Visibility threshold. Nodes above this threshold will not be shown. , printFormatterIncludeCallStacks :: Bool + -- ^ Whether to include callstacks with failures. , printFormatterIndentSize :: Int - } + -- ^ The indentation unit in spaces. Defaults to 4. + } deriving (Show) defaultPrintFormatter :: PrintFormatter defaultPrintFormatter = PrintFormatter { diff --git a/src/Test/Sandwich/Formatters/Silent.hs b/src/Test/Sandwich/Formatters/Silent.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandwich/Formatters/Silent.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | The silent formatter does nothing except print the test root folder path, if present. +-- +-- This is provided as an explicit formatter so it can print that single line. If you don't want anything at all to be printed, you can just run with no formatters. + +module Test.Sandwich.Formatters.Silent ( + defaultSilentFormatter + + -- * Options + , silentFormatterPrintRunRoot + ) where + +import Control.Monad.IO.Class +import Data.String.Interpolate +import Test.Sandwich.Types.RunTree +import Test.Sandwich.Util + + +data SilentFormatter = SilentFormatter { + silentFormatterPrintRunRoot :: Bool + } deriving (Show) + +defaultSilentFormatter :: SilentFormatter +defaultSilentFormatter = SilentFormatter { + silentFormatterPrintRunRoot = True + } + +instance Formatter SilentFormatter where + formatterName _ = "silent-formatter" + runFormatter _ _ _ bc = + whenJust (baseContextRunRoot bc) $ \runRoot -> + liftIO $ putStrLn [i|Run root: #{runRoot}\n|] + finalizeFormatter _ _ _ = return () 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 @@ -10,7 +10,10 @@ {-# LANGUAGE ViewPatterns #-} module Test.Sandwich.Formatters.TerminalUI ( + -- | The terminal UI formatter produces an interactive UI for running tests and inspecting their results. defaultTerminalUIFormatter + + -- * Options , terminalUIVisibilityThreshold , terminalUIShowRunTimes , terminalUIShowVisibilityThresholds @@ -18,8 +21,9 @@ , terminalUIInitialFolding , terminalUIDefaultEditor , terminalUIOpenInEditor + + -- * Auxiliary types , InitialFolding(..) - , TerminalUIFormatter ) where import Brick as B 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 @@ -53,7 +53,7 @@ let infoWidgets = getInfoWidgets x guard (not $ L.null infoWidgets) return $ padLeft (Pad 4) $ - fixedHeightOrViewportPercent (InnerViewport [i|viewport_#{ident}|]) 30 $ + fixedHeightOrViewportPercent (InnerViewport [i|viewport_#{ident}|]) 33 $ vBox infoWidgets ] 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 @@ -19,6 +19,7 @@ import Test.Sandwich.Types.Spec import Text.Show.Pretty as P + class ToBrickWidget a where toBrickWidget :: a -> Widget n @@ -54,6 +55,7 @@ Just msg -> hBox [withAttr pendingAttr $ str "Pending" , str (": " <> msg)] toBrickWidget (Reason _ msg) = boxWithTitle "Failure reason:" (strWrap msg) + toBrickWidget (ChildrenFailed _ n) = boxWithTitle [i|Reason: #{n} #{if n == 1 then ("child" :: String) else "children"} failed|] (strWrap "") toBrickWidget (GotException _ maybeMessage e@(SomeExceptionWithEq baseException)) = case fromException baseException of Just (fr :: FailureReason) -> boxWithTitle heading (toBrickWidget fr) _ -> boxWithTitle heading (reifyWidget e) @@ -69,6 +71,7 @@ _ -> boxWithTitle "Get context exception:" (reifyWidget e) +boxWithTitle :: String -> Widget n -> Widget n boxWithTitle heading inside = hBox [ border $ padAll 1 $ diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Types.hs b/src/Test/Sandwich/Formatters/TerminalUI/Types.hs --- a/src/Test/Sandwich/Formatters/TerminalUI/Types.hs +++ b/src/Test/Sandwich/Formatters/TerminalUI/Types.hs @@ -17,7 +17,6 @@ import Test.Sandwich.Types.RunTree --- | Initial settings for the TUI interface. All of these settings can be changed interactively. data TerminalUIFormatter = TerminalUIFormatter { terminalUIVisibilityThreshold :: Int -- ^ The initial visibility threshold to use when the formatter starts. @@ -48,6 +47,9 @@ -- If FILE is not found in the string, it will be appended to the command after a space. -- It's also passed a debug callback that accepts a 'T.Text'; messages logged with this function will go into the formatter logs. } + +instance Show TerminalUIFormatter where + show (TerminalUIFormatter {}) = "" data InitialFolding = InitialFoldingAllOpen 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 @@ -3,6 +3,7 @@ module Test.Sandwich.Internal ( Spec , SpecFree + , SpecCommand , HasBaseContext , HasLabel , LabelValue(..) @@ -24,6 +25,9 @@ , waitForTree , SomeAsyncExceptionWithEq(..) , logEntryStr + + , module Test.Sandwich.Internal.Formatters + , module Test.Sandwich.Internal.Running ) where import Test.Sandwich.Interpreters.RunTree.Util @@ -31,3 +35,6 @@ import Test.Sandwich.Shutdown import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec + +import Test.Sandwich.Internal.Formatters +import Test.Sandwich.Internal.Running 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 @@ -148,13 +148,13 @@ runInAsync node ctx $ do ((L.length . L.filter isFailure) <$> runNodesSequentially runNodeChildren ctx) >>= \case 0 -> return Success - n -> return $ Failure (Reason Nothing [i|#{n} #{if n == 1 then ("child" :: T.Text) else "children"} failed|]) + n -> return $ Failure (ChildrenFailed Nothing n) startTree node@(RunNodeParallel {..}) ctx' = do let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon runInAsync node ctx $ do ((L.length . L.filter isFailure) <$> runNodesConcurrently runNodeChildren ctx) >>= \case 0 -> return Success - n -> return $ Failure (Reason Nothing [i|#{n} #{if n == 1 then ("child" :: T.Text) else "children"} failed|]) + n -> return $ Failure (ChildrenFailed Nothing n) startTree node@(RunNodeIt {..}) ctx' = do let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon runInAsync node ctx $ do diff --git a/src/Test/Sandwich/Types/ArgParsing.hs b/src/Test/Sandwich/Types/ArgParsing.hs --- a/src/Test/Sandwich/Types/ArgParsing.hs +++ b/src/Test/Sandwich/Types/ArgParsing.hs @@ -10,10 +10,11 @@ -- * FormatterType -data FormatterType = Print | TUI | Auto | Silent +data FormatterType = Print | PrintFailures | TUI | Auto | Silent instance Show FormatterType where show Print = "print" + show PrintFailures = "print-failures" show TUI = "tui" show Auto = "auto" show Silent = "silent" 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 @@ -7,6 +7,7 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE StandaloneDeriving #-} module Test.Sandwich.Types.RunTree where @@ -184,7 +185,9 @@ -- ^ Called after the test tree is completed, can be used to print final results -- | An existential wrapper around 'Formatter's -data SomeFormatter = forall f. (Formatter f, Typeable f) => SomeFormatter f +data SomeFormatter = forall f. (Formatter f, Show f, Typeable f) => SomeFormatter f + +deriving instance Show SomeFormatter -- * Options 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 @@ -92,6 +92,8 @@ | GotAsyncException { failureCallStack :: Maybe CallStack , failureMessage :: Maybe String , failureAsyncException :: SomeAsyncExceptionWithEq } + | ChildrenFailed { failureCallStack :: Maybe CallStack + , failureNumChildren :: Int } deriving (Show, Typeable, Eq) instance Exception FailureReason diff --git a/test/Describe.hs b/test/Describe.hs --- a/test/Describe.hs +++ b/test/Describe.hs @@ -31,7 +31,7 @@ it "does thing 1" $ throwSomeUserError it "does thing 2" $ return () - (results !! 0) `mustBe` (Failure (Reason {failureCallStack = Nothing, failureReason = "1 child failed"})) + (results !! 0) `mustBe` (Failure (ChildrenFailed {failureCallStack = Nothing, failureNumChildren = 1})) case results !! 1 of Failure (GotException {..}) -> do failureException `mustBe` someUserErrorWrapped diff --git a/test/Introduce.hs b/test/Introduce.hs --- a/test/Introduce.hs +++ b/test/Introduce.hs @@ -19,7 +19,6 @@ import GHC.Stack import Test.Sandwich import Test.Sandwich.Internal -import Test.Sandwich.Internal.Running import TestUtil diff --git a/test/TestUtil.hs b/test/TestUtil.hs --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -19,7 +19,6 @@ import System.Exit import Test.Sandwich import Test.Sandwich.Internal -import Test.Sandwich.Internal.Running -- * Main function