diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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`. 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: 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 . 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 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 @@ -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. 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 @@ -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 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 @@ -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 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 @@ -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 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 @@ -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 {}) = "" @@ -113,6 +123,7 @@ , _appOpenInEditor :: SrcLoc -> IO () , _appDebug :: T.Text -> IO () + , _appCustomExceptionFormatters :: CustomExceptionFormatters } makeLenses ''AppState 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 @@ -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 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 @@ -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