sandwich 0.1.0.3 → 0.1.0.4

raw patch · 23 files changed

+141/−35 lines, 23 filesnew-component:exe:sandwich-demoPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• README.md +0/−1
• app/Main.hs +1/−1
• sandwich.cabal +9/−9
• src/Test/Sandwich.hs +4/−0
• src/Test/Sandwich/ArgParsing.hs +9/−3
• src/Test/Sandwich/Formatters/FailureReport.hs +22/−10
• src/Test/Sandwich/Formatters/LogSaver.hs +9/−0
• src/Test/Sandwich/Formatters/Print.hs +7/−0
• src/Test/Sandwich/Formatters/Print/FailureReason.hs +2/−0
• src/Test/Sandwich/Formatters/Print/Types.hs +6/−1
• src/Test/Sandwich/Formatters/Silent.hs +42/−0
• src/Test/Sandwich/Formatters/TerminalUI.hs +5/−1
• src/Test/Sandwich/Formatters/TerminalUI/Draw.hs +1/−1
• src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs +3/−0
• src/Test/Sandwich/Formatters/TerminalUI/Types.hs +3/−1
• src/Test/Sandwich/Internal.hs +7/−0
• src/Test/Sandwich/Interpreters/StartTree.hs +2/−2
• src/Test/Sandwich/Types/ArgParsing.hs +2/−1
• src/Test/Sandwich/Types/RunTree.hs +4/−1
• src/Test/Sandwich/Types/Spec.hs +2/−0
• test/Describe.hs +1/−1
• test/Introduce.hs +0/−1
• test/TestUtil.hs +0/−1

@@ -1,1 +0,0 @@-# sandwich

@@ -200,7 +200,7 @@   where     options = defaultOptions {       optionsTestArtifactsDirectory = TestArtifactsGeneratedDirectory "test_runs" (show <$> getCurrentTime)-      , optionsFormatters = [SomeFormatter defaultLogSaverFormatter, SomeFormatter defaultFailureReportFormatter]+      , optionsFormatters = [SomeFormatter defaultLogSaverFormatter]       , optionsProjectRoot = Just "sandwich"       } 

@@ -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 <https://codedownio.github.io/sandwich documentation>. 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

@@ -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

@@ -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

@@ -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

@@ -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 _ = "<LogSaverFormatter>"  -- | A path under which to save logs. data LogPath =

@@ -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 <https://codedownio.github.io/sandwich/docs/formatters/print here>.+ module Test.Sandwich.Formatters.Print (   defaultPrintFormatter++  -- * Options   , printFormatterUseColor   , printFormatterLogLevel   , printFormatterIncludeCallStacks   , printFormatterIndentSize+  , printFormatterVisibilityThreshold   ) where  import Control.Concurrent.STM

@@ -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

@@ -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 {

@@ -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 ()

@@ -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

@@ -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       ] 

@@ -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 $

@@ -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 {}) = "<TerminalUIFormatter>"  data InitialFolding =   InitialFoldingAllOpen

@@ -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

@@ -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

@@ -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"

@@ -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 

@@ -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

@@ -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

@@ -19,7 +19,6 @@ import GHC.Stack import Test.Sandwich import Test.Sandwich.Internal-import Test.Sandwich.Internal.Running  import TestUtil 

@@ -19,7 +19,6 @@ import System.Exit import Test.Sandwich import Test.Sandwich.Internal-import Test.Sandwich.Internal.Running  -- * Main function