sandwich 0.1.0.6 → 0.1.0.7

raw patch · 9 files changed

+155/−110 lines, 9 filesdep ~basePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• CHANGELOG.md +5/−1
• sandwich.cabal +7/−7
• src/Test/Sandwich/Contexts.hs +2/−1
• src/Test/Sandwich/Formatters/TerminalUI.hs +3/−0
• src/Test/Sandwich/Formatters/TerminalUI/Draw.hs +14/−4
• src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs +107/−91
• src/Test/Sandwich/Formatters/TerminalUI/Types.hs +12/−1
• src/Test/Sandwich/RunTree.hs +0/−5
• src/Test/Sandwich/Types/Spec.hs +5/−0

@@ -2,6 +2,10 @@  ## Unreleased changes -## 0.1.0.5+## 0.1.0.7++* Add `terminalUICustomExceptionFormatters`.++## 0.1.0.6  * Add `parallelN` for limiting the number of threads in a `parallel`.

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: aa45aa821e6aa80865e26cf2911cf666e76b4e5ce6ba1a0ef5b08a4ff626640d+-- hash: eaa7784b529c488c051e94777fd56a24706b8f3c93b51160ed979973d59b361b  name:           sandwich-version:        0.1.0.6+version:        0.1.0.7 synopsis:       Yet another test framework for Haskell description:    Please see the <https://codedownio.github.io/sandwich documentation>. category:       Testing@@ -95,7 +95,7 @@       aeson     , ansi-terminal     , async-    , base <4.15+    , base <5     , brick     , bytestring     , colour@@ -141,7 +141,7 @@       aeson     , ansi-terminal     , async-    , base <4.15+    , base <5     , brick     , bytestring     , colour@@ -188,7 +188,7 @@       aeson     , ansi-terminal     , async-    , base <4.15+    , base <5     , brick     , bytestring     , colour@@ -240,7 +240,7 @@       aeson     , ansi-terminal     , async-    , base <4.15+    , base <5     , brick     , bytestring     , colour@@ -293,7 +293,7 @@       aeson     , ansi-terminal     , async-    , base <4.15+    , base <5     , brick     , bytestring     , colour

@@ -1,5 +1,6 @@ {-# LANGUAGE MonoLocalBinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE ScopedTypeVariables #-}  -- | Functions for retrieving context information from within tests. @@ -30,7 +31,7 @@ -- | Get the command line options, if configured. -- Using the 'runSandwichWithCommandLineArgs' family of main functions will introduce these, or you can -- introduce them manually-getCommandLineOptions :: (HasCommandLineOptions context a, MonadReader context m, MonadIO m) => m (CommandLineOptions a)+getCommandLineOptions :: forall a context m. (HasCommandLineOptions context a, MonadReader context m, MonadIO m) => m (CommandLineOptions a) getCommandLineOptions = getContext commandLineOptions  -- | Get the user command line options, if configured.

@@ -20,9 +20,11 @@   , terminalUIInitialFolding   , terminalUIDefaultEditor   , terminalUIOpenInEditor+  , terminalUICustomExceptionFormatters    -- * Auxiliary types   , InitialFolding(..)+  , CustomTUIException(..)   ) where  import Brick as B@@ -98,6 +100,7 @@            , _appOpenInEditor = terminalUIOpenInEditor terminalUIDefaultEditor (const $ return ())           , _appDebug = (const $ return ())+          , _appCustomExceptionFormatters = terminalUICustomExceptionFormatters         }    eventChan <- newBChan 10

@@ -12,6 +12,7 @@ import qualified Brick.Widgets.List as L import Control.Monad import Control.Monad.Logger+import Control.Monad.Reader import Data.Foldable import qualified Data.List as L import Data.Maybe@@ -22,6 +23,7 @@ import GHC.Stack import qualified Graphics.Vty as V import Lens.Micro+import Safe import Test.Sandwich.Formatters.Common.Count import Test.Sandwich.Formatters.Common.Util import Test.Sandwich.Formatters.TerminalUI.AttrMap@@ -30,8 +32,8 @@ import Test.Sandwich.Formatters.TerminalUI.Draw.TopBox import Test.Sandwich.Formatters.TerminalUI.Draw.Util import Test.Sandwich.Formatters.TerminalUI.Types-import Test.Sandwich.RunTree import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec   drawUI :: AppState -> [Widget ClickableName]@@ -93,11 +95,11 @@           _ -> Nothing       ] -    getInfoWidgets mle@(MainListElem {..}) = catMaybes [Just $ toBrickWidget status, callStackWidget mle, logWidget mle]+    getInfoWidgets mle@(MainListElem {..}) = catMaybes [Just $ runReader (toBrickWidget status) (app ^. appCustomExceptionFormatters), callStackWidget mle, logWidget mle]      callStackWidget (MainListElem {..}) = do-      cs <- getCallStackFromStatus status-      return $ borderWithLabel (padLeftRight 1 $ str "Callstack") $ toBrickWidget cs+      cs <- getCallStackFromStatus (app ^. appCustomExceptionFormatters) status+      return $ borderWithLabel (padLeftRight 1 $ str "Callstack") $ runReader (toBrickWidget cs) (app ^. appCustomExceptionFormatters)      logWidget (MainListElem {..}) = do       let filteredLogs = case app ^. appLogLevel of@@ -152,3 +154,11 @@     totalFailedTests = countWhere isFailedItBlock (app ^. appRunTree)     totalRunningTests = countWhere isRunningItBlock (app ^. appRunTree)     totalNotStartedTests = countWhere isNotStartedItBlock (app ^. appRunTree)++getCallStackFromStatus :: CustomExceptionFormatters -> Status -> Maybe CallStack+getCallStackFromStatus cef (Done {statusResult=(Failure reason@(GotException _ _ (SomeExceptionWithEq baseException)))}) =+  case headMay $ catMaybes [x baseException | x <- cef] of+    Just (CustomTUIExceptionMessageAndCallStack _ maybeCs) -> maybeCs+    _ -> failureCallStack reason+getCallStackFromStatus _ (Done {statusResult=(Failure reason)}) = failureCallStack reason+getCallStackFromStatus _ _ = Nothing

@@ -3,72 +3,84 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE MultiWayIf #-}  module Test.Sandwich.Formatters.TerminalUI.Draw.ToBrickWidget where  import Brick import Brick.Widgets.Border import Control.Exception.Safe+import Control.Monad.Reader import qualified Data.List as L+import Data.Maybe import Data.String.Interpolate+import qualified Data.Text as T import Data.Time.Clock import GHC.Stack+import Safe import Test.Sandwich.Formatters.Common.Util import Test.Sandwich.Formatters.TerminalUI.AttrMap+import Test.Sandwich.Formatters.TerminalUI.Types import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec import Text.Show.Pretty as P   class ToBrickWidget a where-  toBrickWidget :: a -> Widget n+  toBrickWidget :: a -> Reader CustomExceptionFormatters (Widget n)  instance ToBrickWidget Status where-  toBrickWidget (NotStarted {}) = strWrap "Not started"-  toBrickWidget (Running {statusStartTime}) = strWrap [i|Started at #{statusStartTime}|]-  toBrickWidget (Done startTime endTime Success) = strWrap [i|Succeeded in #{formatNominalDiffTime (diffUTCTime endTime startTime)}|]+  toBrickWidget (NotStarted {}) = return $ strWrap "Not started"+  toBrickWidget (Running {statusStartTime}) = return $ strWrap [i|Started at #{statusStartTime}|]+  toBrickWidget (Done startTime endTime Success) = return $ strWrap [i|Succeeded in #{formatNominalDiffTime (diffUTCTime endTime startTime)}|]   toBrickWidget (Done {statusResult=(Failure failureReason)}) = toBrickWidget failureReason  instance ToBrickWidget FailureReason where-  toBrickWidget (ExpectedButGot _ (SEB x1) (SEB x2)) = hBox [-    hLimitPercent 50 $-      border $-        padAll 1 $-          (padBottom (Pad 1) (withAttr expectedAttr $ str "Expected:"))-          <=>-          widget1-    , padLeft (Pad 1) $-        hLimitPercent 50 $-          border $-            padAll 1 $-              (padBottom (Pad 1) (withAttr sawAttr $ str "Saw:"))-              <=>-              widget2-    ]-    where-      (widget1, widget2) = case (P.reify x1, P.reify x2) of-        (Just v1, Just v2) -> (toBrickWidget v1, toBrickWidget v2)-        _ -> (str (show x1), str (show x2))-  toBrickWidget (DidNotExpectButGot _ x) = boxWithTitle "Did not expect:" (reifyWidget x)-  toBrickWidget (Pending _ maybeMessage) = case maybeMessage of+  toBrickWidget (ExpectedButGot _ (SEB x1) (SEB x2)) = do+    (widget1, widget2) <- case (P.reify x1, P.reify x2) of+      (Just v1, Just v2) -> (, ) <$> toBrickWidget v1 <*> toBrickWidget v2+      _ -> return (str (show x1), str (show x2))++    return $ hBox [+      hLimitPercent 50 $+        border $+          padAll 1 $+            (padBottom (Pad 1) (withAttr expectedAttr $ str "Expected:"))+            <=>+            widget1+      , padLeft (Pad 1) $+          hLimitPercent 50 $+            border $+              padAll 1 $+                (padBottom (Pad 1) (withAttr sawAttr $ str "Saw:"))+                <=>+                widget2+      ]+  toBrickWidget (DidNotExpectButGot _ x) = boxWithTitle "Did not expect:" <$> (reifyWidget x)+  toBrickWidget (Pending _ maybeMessage) = return $ case maybeMessage of     Nothing -> withAttr pendingAttr $ str "Pending"     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 (Reason _ msg) = return $ boxWithTitle "Failure reason:" (strWrap msg)+  toBrickWidget (ChildrenFailed _ n) = return $ 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)+    Just (fr :: FailureReason) -> boxWithTitle heading <$> (toBrickWidget fr)+    Nothing -> do+      customExceptionFormatters <- ask+      case headMay $ catMaybes [x baseException | x <- customExceptionFormatters] of+        Just (CustomTUIExceptionMessageAndCallStack msg _) -> return $ strWrap $ T.unpack msg+        Just (CustomTUIExceptionBrick widget) -> return $ boxWithTitle heading widget+        Nothing -> boxWithTitle heading <$> (reifyWidget e)     where heading = case maybeMessage of             Nothing -> "Got exception: "             Just msg -> [i|Got exception (#{msg}):|]-  toBrickWidget (GotAsyncException _ maybeMessage e) = boxWithTitle heading (reifyWidget e)+  toBrickWidget (GotAsyncException _ maybeMessage e) = boxWithTitle heading <$> (reifyWidget e)     where heading = case maybeMessage of             Nothing -> "Got async exception: "             Just msg -> [i|Got async exception (#{msg}):|]   toBrickWidget (GetContextException _ e@(SomeExceptionWithEq baseException)) = case fromException baseException of-    Just (fr :: FailureReason) -> boxWithTitle "Get context exception:" (toBrickWidget fr)-    _ -> boxWithTitle "Get context exception:" (reifyWidget e)+    Just (fr :: FailureReason) -> boxWithTitle "Get context exception:" <$> (toBrickWidget fr)+    _ -> boxWithTitle "Get context exception:" <$> (reifyWidget e)   boxWithTitle :: String -> Widget n -> Widget n@@ -80,81 +92,85 @@       inside   ] +reifyWidget :: Show a => a -> Reader CustomExceptionFormatters (Widget n) reifyWidget x = case P.reify x of   Just v -> toBrickWidget v-  _ -> strWrap (show x)+  _ -> return $ strWrap (show x)  instance ToBrickWidget P.Value where-  toBrickWidget (Integer s) = withAttr integerAttr $ strWrap s-  toBrickWidget (Float s) = withAttr floatAttr $ strWrap s-  toBrickWidget (Char s) = withAttr charAttr $ strWrap s-  toBrickWidget (String s) = withAttr stringAttr $ strWrap s+  toBrickWidget (Integer s) = return $ withAttr integerAttr $ strWrap s+  toBrickWidget (Float s) = return $ withAttr floatAttr $ strWrap s+  toBrickWidget (Char s) = return $ withAttr charAttr $ strWrap s+  toBrickWidget (String s) = return $ withAttr stringAttr $ strWrap s #if MIN_VERSION_pretty_show(1,10,0)-  toBrickWidget (Date s) = withAttr dateAttr $ strWrap s-  toBrickWidget (Time s) = withAttr timeAttr $ strWrap s-  toBrickWidget (Quote s) = withAttr quoteAttr $ strWrap s+  toBrickWidget (Date s) = return $ withAttr dateAttr $ strWrap s+  toBrickWidget (Time s) = return $ withAttr timeAttr $ strWrap s+  toBrickWidget (Quote s) = return $ withAttr quoteAttr $ strWrap s #endif-  toBrickWidget (Ratio v1 v2) = hBox [toBrickWidget v1, withAttr slashAttr $ str "/", toBrickWidget v2]-  toBrickWidget (Neg v) = hBox [withAttr negAttr $ str "-"-                               , toBrickWidget v]-  toBrickWidget (List vs) = vBox ((withAttr listBracketAttr $ str "[")-                                  : (fmap (padLeft (Pad 4)) listRows)-                                  <> [withAttr listBracketAttr $ str "]"])-    where listRows-            | length vs < 10 = fmap toBrickWidget vs-            | otherwise = (fmap toBrickWidget (L.take 3 vs))-                          <> [withAttr ellipsesAttr $ str "..."]-                          <> (fmap toBrickWidget (takeEnd 3 vs))-  toBrickWidget (Tuple vs) = vBox ((withAttr tupleBracketAttr $ str "(")-                                   : (fmap (padLeft (Pad 4)) tupleRows)-                                   <> [withAttr tupleBracketAttr $ str ")"])-    where tupleRows-            | length vs < 10 = fmap toBrickWidget vs-            | otherwise = (fmap toBrickWidget (L.take 3 vs))-                          <> [withAttr ellipsesAttr $ str "..."]-                          <> (fmap toBrickWidget (takeEnd 3 vs))-  toBrickWidget (Rec recordName tuples) = vBox (hBox [withAttr recordNameAttr $ str recordName, withAttr braceAttr $ str " {"]-                                                 : (fmap (padLeft (Pad 4)) recordRows)-                                                 <> [withAttr braceAttr $ str "}"])-    where recordRows-            | length tuples < 10 = fmap tupleToWidget tuples-            | otherwise = (fmap tupleToWidget (L.take 3 tuples))-                          <> [withAttr ellipsesAttr $ str "..."]-                          <> (fmap tupleToWidget (takeEnd 3 tuples))--          tupleToWidget (name, v) = hBox [withAttr fieldNameAttr $ str name-                                         , str " = "-                                         , toBrickWidget v]-  toBrickWidget (Con conName vs) = vBox ((withAttr constructorNameAttr $ str conName)-                                          : (fmap (padLeft (Pad 4)) constructorRows))-    where constructorRows-            | length vs < 10 = fmap toBrickWidget vs-            | otherwise = (fmap toBrickWidget (L.take 3 vs))-                          <> [withAttr ellipsesAttr $ str "..."]-                          <> (fmap toBrickWidget (takeEnd 3 vs))+  toBrickWidget (Ratio v1 v2) = do+    w1 <- toBrickWidget v1+    w2 <- toBrickWidget v2+    return $ hBox [w1, withAttr slashAttr $ str "/", w2]+  toBrickWidget (Neg v) = do+    w <- toBrickWidget v+    return $ hBox [withAttr negAttr $ str "-", w]+  toBrickWidget (List vs) = do+    listRows <- abbreviateList vs+    return $ vBox ((withAttr listBracketAttr $ str "[")+                   : (fmap (padLeft (Pad 4)) listRows)+                   <> [withAttr listBracketAttr $ str "]"])+  toBrickWidget (Tuple vs) = do+    tupleRows <- abbreviateList vs+    return $ vBox ((withAttr tupleBracketAttr $ str "(")+                   : (fmap (padLeft (Pad 4)) tupleRows)+                   <> [withAttr tupleBracketAttr $ str ")"])+  toBrickWidget (Rec recordName tuples) = do+    recordRows <- abbreviateList' tupleToWidget tuples+    return $ vBox (hBox [withAttr recordNameAttr $ str recordName, withAttr braceAttr $ str " {"]+                        : (fmap (padLeft (Pad 4)) recordRows)+                        <> [withAttr braceAttr $ str "}"])+    where+      tupleToWidget (name, v) = toBrickWidget v >>= \w -> return $ hBox [+        withAttr fieldNameAttr $ str name+        , str " = "+        , w+        ]+  toBrickWidget (Con conName vs) = do+   constructorRows <- abbreviateList vs+   return $ vBox ((withAttr constructorNameAttr $ str conName)+                  : (fmap (padLeft (Pad 4)) constructorRows))+  toBrickWidget (InfixCons opValue tuples) = do+    rows <- abbreviateList' tupleToWidget tuples+    op <- toBrickWidget opValue+    return $ vBox (L.intercalate [op] [[x] | x <- rows])+    where+      tupleToWidget (name, v) = toBrickWidget v >>= \w -> return $ hBox [+        withAttr fieldNameAttr $ str name+        , str " = "+        , w+        ] -  toBrickWidget (InfixCons opValue tuples) = vBox (L.intercalate [toBrickWidget opValue] [[x] | x <- rows])-    where rows-            | length tuples < 10 = fmap tupleToWidget tuples-            | otherwise = (fmap tupleToWidget (L.take 3 tuples))-                          <> [withAttr ellipsesAttr $ str "..."]-                          <> (fmap tupleToWidget (takeEnd 3 tuples))+abbreviateList :: [Value] -> Reader CustomExceptionFormatters [Widget n]+abbreviateList = abbreviateList' toBrickWidget -          tupleToWidget (name, v) = hBox [withAttr fieldNameAttr $ str name-                                         , str " = "-                                         , toBrickWidget v]+abbreviateList' :: (Monad m) => (a -> m (Widget n)) -> [a] -> m [Widget n]+abbreviateList' f vs | length vs < 10 = mapM f vs+abbreviateList' f vs = do+  initial <- mapM f (L.take 3 vs)+  final <- mapM f (takeEnd 3 vs)+  return $ initial <> [withAttr ellipsesAttr $ str "..."] <> final  instance ToBrickWidget CallStack where-  toBrickWidget cs = vBox (fmap renderLine $ getCallStack cs)+  toBrickWidget cs = vBox <$> (mapM renderLine $ getCallStack cs)     where-      renderLine (f, srcLoc) = hBox [+      renderLine (f, srcLoc) = toBrickWidget srcLoc >>= \w -> return $ hBox [         withAttr logFunctionAttr $ str f         , str " called at "-        , toBrickWidget srcLoc+        , w         ]  instance ToBrickWidget SrcLoc where-  toBrickWidget (SrcLoc {..}) = hBox [+  toBrickWidget (SrcLoc {..}) = return $ hBox [     withAttr logFilenameAttr $ str srcLocFile     , str ":"     , withAttr logLineAttr $ str $ show srcLocStartLine

@@ -5,7 +5,9 @@  module Test.Sandwich.Formatters.TerminalUI.Types where +import qualified Brick as B import qualified Brick.Widgets.List as L+import Control.Exception import Control.Monad.Logger import Data.Sequence import qualified Data.Text as T@@ -46,6 +48,8 @@   -- and invokes it with the strings LINE, COLUMN, and FILE replaced with the line number, column, and file path.   -- 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.+  , terminalUICustomExceptionFormatters :: CustomExceptionFormatters+  -- ^ Custom exception formatters, used to nicely format custom exception types.   }  instance Show TerminalUIFormatter where@@ -69,10 +73,16 @@   , terminalUIRefreshPeriod = 100000   , terminalUIDefaultEditor = Just "emacsclient +LINE:COLUMN --no-wait"   , terminalUIOpenInEditor = autoOpenInEditor+  , terminalUICustomExceptionFormatters = []   } -data AppEvent = RunTreeUpdated [RunNodeFixed BaseContext]+type CustomExceptionFormatters = [SomeException -> Maybe CustomTUIException] +data CustomTUIException = CustomTUIExceptionMessageAndCallStack T.Text (Maybe CallStack)+                        | CustomTUIExceptionBrick (forall n. B.Widget n)++newtype AppEvent = RunTreeUpdated [RunNodeFixed BaseContext]+ instance Show AppEvent where   show (RunTreeUpdated {}) = "<RunTreeUpdated>" @@ -113,6 +123,7 @@    , _appOpenInEditor :: SrcLoc -> IO ()   , _appDebug :: T.Text -> IO ()+  , _appCustomExceptionFormatters :: CustomExceptionFormatters   }  makeLenses ''AppState

@@ -6,7 +6,6 @@ module Test.Sandwich.RunTree where  import Control.Concurrent.STM-import GHC.Stack import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec @@ -112,10 +111,6 @@     RunNodeIt {..} -> do       return $ RunNodeIt { runNodeCommon=common', .. } --getCallStackFromStatus :: Status -> Maybe CallStack-getCallStackFromStatus Done {statusResult=(Failure reason)} = failureCallStack reason-getCallStackFromStatus _ = Nothing  isDone :: Status -> Bool isDone (Done {}) = True

@@ -15,6 +15,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE CPP #-}  -- | The core Spec/SpecCommand types, used to define the test free monad. @@ -35,6 +36,10 @@ import GHC.Stack import GHC.TypeLits import Safe++#if !MIN_VERSION_base(4,13,0)+import Control.Monad.Fail+#endif  -- * ExampleM monad