sandwich 0.1.5.2 → 0.2.0.0
raw patch · 43 files changed
+1957/−1815 lines, 43 filesdep +vty-crossplatformdep ~vtyPVP ok
version bump matches the API change (PVP)
Dependencies added: vty-crossplatform
Dependency ranges changed: vty
API changes (from Hackage documentation)
+ Test.Sandwich.Internal: [statusSetupTime] :: Status -> Maybe NominalDiffTime
+ Test.Sandwich.Internal: [statusTeardownTime] :: Status -> Maybe NominalDiffTime
+ Test.Sandwich.Options: defaultTestArtifactsDirectory :: TestArtifactsDirectory
- Test.Sandwich.Internal: Done :: UTCTime -> UTCTime -> Result -> Status
+ Test.Sandwich.Internal: Done :: UTCTime -> UTCTime -> Maybe NominalDiffTime -> Maybe NominalDiffTime -> Result -> Status
- Test.Sandwich.Internal: Running :: UTCTime -> Async Result -> Status
+ Test.Sandwich.Internal: Running :: UTCTime -> Maybe NominalDiffTime -> Async Result -> Status
Files
- CHANGELOG.md +7/−0
- app/Main.hs +1/−5
- sandwich.cabal +35/−34
- src/Test/Sandwich/ArgParsing.hs +22/−33
- src/Test/Sandwich/Formatters/Common/Util.hs +6/−6
- src/Test/Sandwich/Formatters/FailureReport.hs +3/−0
- src/Test/Sandwich/Formatters/Print.hs +23/−5
- src/Test/Sandwich/Formatters/Print/FailureReason.hs +0/−3
- src/Test/Sandwich/Formatters/Print/Printing.hs +8/−3
- src/Test/Sandwich/Formatters/Print/Types.hs +9/−0
- src/Test/Sandwich/Formatters/TerminalUI.hs +456/−0
- src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs +212/−0
- src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs +12/−0
- src/Test/Sandwich/Formatters/TerminalUI/Draw.hs +149/−0
- src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs +103/−0
- src/Test/Sandwich/Formatters/TerminalUI/Draw/RunTimes.hs +39/−0
- src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs +198/−0
- src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs +178/−0
- src/Test/Sandwich/Formatters/TerminalUI/Draw/Util.hs +34/−0
- src/Test/Sandwich/Formatters/TerminalUI/Filter.hs +93/−0
- src/Test/Sandwich/Formatters/TerminalUI/Keys.hs +55/−0
- src/Test/Sandwich/Formatters/TerminalUI/OpenInEditor.hs +44/−0
- src/Test/Sandwich/Formatters/TerminalUI/Types.hs +143/−0
- src/Test/Sandwich/Interpreters/StartTree.hs +88/−50
- src/Test/Sandwich/Options.hs +23/−0
- src/Test/Sandwich/RunTree.hs +1/−1
- src/Test/Sandwich/Shutdown.hs +1/−1
- src/Test/Sandwich/Types/ArgParsing.hs +0/−6
- src/Test/Sandwich/Types/RunTree.hs +3/−0
- src/Test/Sandwich/Types/Spec.hs +10/−7
- test/TestUtil.hs +1/−1
- unix-src/Test/Sandwich/Formatters/TerminalUI.hs +0/−444
- unix-src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs +0/−212
- unix-src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs +0/−12
- unix-src/Test/Sandwich/Formatters/TerminalUI/Draw.hs +0/−161
- unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs +0/−103
- unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs +0/−189
- unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs +0/−178
- unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/Util.hs +0/−34
- unix-src/Test/Sandwich/Formatters/TerminalUI/Filter.hs +0/−93
- unix-src/Test/Sandwich/Formatters/TerminalUI/Keys.hs +0/−55
- unix-src/Test/Sandwich/Formatters/TerminalUI/OpenInEditor.hs +0/−44
- unix-src/Test/Sandwich/Formatters/TerminalUI/Types.hs +0/−135
CHANGELOG.md view
@@ -2,6 +2,13 @@ ## Unreleased changes +## 0.2.0.0++* Allow any formatter except TUI to be used with --repeat N.+* Be able to include timestamps with print formatter and failure report formatter.+* Support vty-6.x/brick-2.x. This change adds Windows support, but forces us to do a major version bump.+* Add timing info for setup and teardown; closes #10+ ## 0.1.5.2 * Contexts: add pushContext and popContext helpers.
app/Main.hs view
@@ -10,15 +10,11 @@ import Control.Monad.IO.Class import Control.Monad.Logger (LogLevel(..)) import Data.String.Interpolate-import Data.Time.Clock import Test.Sandwich import Test.Sandwich.Formatters.FailureReport import Test.Sandwich.Formatters.LogSaver import Test.Sandwich.Formatters.Print--#ifndef mingw32_HOST_OS import Test.Sandwich.Formatters.TerminalUI-#endif data Database = Database String@@ -200,7 +196,7 @@ main = runSandwichWithCommandLineArgs options documentation where options = defaultOptions {- optionsTestArtifactsDirectory = TestArtifactsGeneratedDirectory "test_runs" (show <$> getCurrentTime)+ optionsTestArtifactsDirectory = defaultTestArtifactsDirectory , optionsFormatters = [SomeFormatter defaultLogSaverFormatter] , optionsProjectRoot = Just "sandwich" }
sandwich.cabal view
@@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.35.2.+-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack name: sandwich-version: 0.1.5.2+version: 0.2.0.0 synopsis: Yet another test framework for Haskell description: Please see the <https://codedownio.github.io/sandwich documentation>. category: Testing@@ -38,6 +38,7 @@ Test.Sandwich.Formatters.LogSaver Test.Sandwich.Formatters.Print Test.Sandwich.Formatters.Silent+ Test.Sandwich.Formatters.TerminalUI Test.Sandwich.Internal Test.Sandwich.TH other-modules:@@ -54,6 +55,18 @@ Test.Sandwich.Formatters.Print.PrintPretty Test.Sandwich.Formatters.Print.Types Test.Sandwich.Formatters.Print.Util+ Test.Sandwich.Formatters.TerminalUI.AttrMap+ Test.Sandwich.Formatters.TerminalUI.CrossPlatform+ Test.Sandwich.Formatters.TerminalUI.Draw+ Test.Sandwich.Formatters.TerminalUI.Draw.ColorProgressBar+ Test.Sandwich.Formatters.TerminalUI.Draw.RunTimes+ Test.Sandwich.Formatters.TerminalUI.Draw.ToBrickWidget+ Test.Sandwich.Formatters.TerminalUI.Draw.TopBox+ Test.Sandwich.Formatters.TerminalUI.Draw.Util+ Test.Sandwich.Formatters.TerminalUI.Filter+ Test.Sandwich.Formatters.TerminalUI.Keys+ Test.Sandwich.Formatters.TerminalUI.OpenInEditor+ Test.Sandwich.Formatters.TerminalUI.Types Test.Sandwich.Golden.Update Test.Sandwich.Internal.Formatters Test.Sandwich.Internal.Running@@ -98,6 +111,7 @@ , ansi-terminal , async , base >=4.11 && <5+ , brick , bytestring , colour , containers@@ -127,32 +141,15 @@ , transformers-base , unliftio-core , vector+ , vty >=6+ , vty-crossplatform default-language: Haskell2010 if !os(windows) build-depends:- brick- , unix- , vty+ unix if os(windows) build-depends: Win32- if !os(windows)- exposed-modules:- Test.Sandwich.Formatters.TerminalUI- other-modules:- Test.Sandwich.Formatters.TerminalUI.AttrMap- Test.Sandwich.Formatters.TerminalUI.CrossPlatform- Test.Sandwich.Formatters.TerminalUI.Draw- Test.Sandwich.Formatters.TerminalUI.Draw.ColorProgressBar- Test.Sandwich.Formatters.TerminalUI.Draw.ToBrickWidget- Test.Sandwich.Formatters.TerminalUI.Draw.TopBox- Test.Sandwich.Formatters.TerminalUI.Draw.Util- Test.Sandwich.Formatters.TerminalUI.Filter- Test.Sandwich.Formatters.TerminalUI.Keys- Test.Sandwich.Formatters.TerminalUI.OpenInEditor- Test.Sandwich.Formatters.TerminalUI.Types- hs-source-dirs:- unix-src executable sandwich-demo main-is: Main.hs@@ -176,6 +173,7 @@ , ansi-terminal , async , base >=4.11 && <5+ , brick , bytestring , colour , containers@@ -206,12 +204,12 @@ , transformers-base , unliftio-core , vector+ , vty >=6+ , vty-crossplatform default-language: Haskell2010 if !os(windows) build-depends:- brick- , unix- , vty+ unix executable sandwich-discover main-is: Main.hs@@ -235,6 +233,7 @@ , ansi-terminal , async , base >=4.11 && <5+ , brick , bytestring , colour , containers@@ -265,12 +264,12 @@ , transformers-base , unliftio-core , vector+ , vty >=6+ , vty-crossplatform default-language: Haskell2010 if !os(windows) build-depends:- brick- , unix- , vty+ unix executable sandwich-test main-is: Main.hs@@ -299,6 +298,7 @@ , ansi-terminal , async , base >=4.11 && <5+ , brick , bytestring , colour , containers@@ -329,12 +329,12 @@ , transformers-base , unliftio-core , vector+ , vty >=6+ , vty-crossplatform default-language: Haskell2010 if !os(windows) build-depends:- brick- , unix- , vty+ unix test-suite sandwich-test-suite type: exitcode-stdio-1.0@@ -364,6 +364,7 @@ , ansi-terminal , async , base >=4.11 && <5+ , brick , bytestring , colour , containers@@ -394,9 +395,9 @@ , transformers-base , unliftio-core , vector+ , vty >=6+ , vty-crossplatform default-language: Haskell2010 if !os(windows) build-depends:- brick- , unix- , vty+ unix
src/Test/Sandwich/ArgParsing.hs view
@@ -19,17 +19,14 @@ import Test.Sandwich.Formatters.MarkdownSummary 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.Internal.Running import Test.Sandwich.Options import Test.Sandwich.Types.ArgParsing import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec -#ifndef mingw32_HOST_OS-import Test.Sandwich.Formatters.TerminalUI-import Test.Sandwich.Formatters.TerminalUI.Types-#endif- #if MIN_VERSION_time(1,9,0) import Data.Time.Format.ISO8601 formatTime = T.unpack . T.replace ":" "_" . T.pack . iso8601Show@@ -115,9 +112,7 @@ formatter = flag' Print (long "print" <> help "Print to stdout") <|> flag' PrintFailures (long "print-failures" <> help "Print failures only to stdout")-#ifndef mingw32_HOST_OS <|> flag' TUI (long "tui" <> help "Open terminal UI app")-#endif <|> flag' Silent (long "silent" <> help "Run silently (print the run root only)") <|> flag Auto Auto (long "auto" <> help "Automatically decide which formatter to use") @@ -235,29 +230,32 @@ let failureReportFormatter = SomeFormatter $ defaultFailureReportFormatter { failureReportLogLevel = optLogLevel } let silentFormatter = SomeFormatter defaultSilentFormatter - maybeMainFormatter <- case (optRepeatCount, optFormatter) of- (x, _) | x /= 1 -> return $ Just printFormatter- (_, Auto) ->- -- Formerly this tried to use the TUI formatter by default after checking isTuiFormatterSupported.- -- Unfortunately, this function returns true under "cabal test", which also redirects stdout. So- -- you end up with no output and a hanging process (until you hit 'q'; stdin is still attached).- -- Seems like the best default is just the print formatter.- return $ Just printFormatter-#ifndef mingw32_HOST_OS- (_, TUI) -> do- let mainTerminalUiFormatter = headMay [x | SomeFormatter (cast -> Just x@(TerminalUIFormatter {})) <- optionsFormatters baseOptions]- return $ Just $ SomeFormatter $ (fromMaybe defaultTerminalUIFormatter mainTerminalUiFormatter) { terminalUILogLevel = optLogLevel }-#endif- (_, Print) -> return $ Just printFormatter- (_, PrintFailures) -> return $ Just failureReportFormatter- (_, Silent) -> return $ Just silentFormatter+ let mainFormatter = case (optRepeatCount, optFormatter) of+ (x, _) | x /= 1 -> case optFormatter of+ TUI -> printFormatter+ PrintFailures -> failureReportFormatter+ Silent -> silentFormatter+ Print -> printFormatter+ Auto -> printFormatter+ (_, Auto) ->+ -- Formerly this tried to use the TUI formatter by default after checking isTuiFormatterSupported.+ -- Unfortunately, this function returns true under "cabal test", which also redirects stdout. So+ -- you end up with no output and a hanging process (until you hit 'q'; stdin is still attached).+ -- Seems like the best default is just the print formatter.+ printFormatter+ (_, TUI) ->+ let mainTerminalUiFormatter = headMay [x | SomeFormatter (cast -> Just x@(TerminalUIFormatter {})) <- optionsFormatters baseOptions]+ in SomeFormatter $ (fromMaybe defaultTerminalUIFormatter mainTerminalUiFormatter) { terminalUILogLevel = optLogLevel }+ (_, Print) -> printFormatter+ (_, PrintFailures) -> failureReportFormatter+ (_, Silent) -> silentFormatter -- Strip out any "main" formatters since the options control that let baseFormatters = optionsFormatters baseOptions & tryAddMarkdownSummaryFormatter optMarkdownSummaryPath & filter (not . isMainFormatter) - let finalFormatters = baseFormatters <> catMaybes [maybeMainFormatter]+ let finalFormatters = baseFormatters <> [mainFormatter] & fmap (setVisibilityThreshold optVisibilityThreshold) let options = baseOptions {@@ -280,27 +278,18 @@ isMainFormatter :: SomeFormatter -> Bool isMainFormatter (SomeFormatter x) = case cast x of Just (_ :: PrintFormatter) -> True-#ifdef mingw32_HOST_OS- Nothing -> False-#else Nothing -> case cast x of Just (_ :: TerminalUIFormatter) -> True Nothing -> False-#endif setVisibilityThreshold Nothing x = x setVisibilityThreshold (Just v) x@(SomeFormatter f) = case cast f of Just pf@(PrintFormatter {}) -> SomeFormatter (pf { printFormatterVisibilityThreshold = v }) Nothing -> case cast f of-#ifdef mingw32_HOST_OS- Just (frf :: FailureReportFormatter) -> SomeFormatter (frf { failureReportVisibilityThreshold = v })- Nothing -> x-#else Just tuif@(TerminalUIFormatter {}) -> SomeFormatter (tuif { terminalUIVisibilityThreshold = v }) Nothing -> case cast f of Just (frf :: FailureReportFormatter) -> SomeFormatter (frf { failureReportVisibilityThreshold = v }) Nothing -> x-#endif isMarkdownSummaryFormatter :: SomeFormatter -> Bool isMarkdownSummaryFormatter (SomeFormatter x) = case cast x of
src/Test/Sandwich/Formatters/Common/Util.hs view
@@ -10,12 +10,12 @@ 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 = (roundFixed (nominalDiffTimeToSeconds diff)) <> " s"+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 = (roundFixed (nominalDiffTimeToSeconds diff)) <> "s" second = secondsToNominalDiffTime 1 ms = secondsToNominalDiffTime 0.001
src/Test/Sandwich/Formatters/FailureReport.hs view
@@ -46,6 +46,7 @@ , failureReportIncludeCallStacks :: Bool , failureReportIndentSize :: Int , failureReportVisibilityThreshold :: Int+ , failureReportIncludeTimestamps :: IncludeTimestamps } deriving (Show) defaultFailureReportFormatter :: FailureReportFormatter@@ -55,6 +56,7 @@ , failureReportIncludeCallStacks = True , failureReportIndentSize = 4 , failureReportVisibilityThreshold = 50+ , failureReportIncludeTimestamps = IncludeTimestampsNever } instance Formatter FailureReportFormatter where@@ -72,6 +74,7 @@ , printFormatterVisibilityThreshold = maxBound , printFormatterIncludeCallStacks = failureReportIncludeCallStacks , printFormatterIndentSize = failureReportIndentSize+ , printFormatterIncludeTimestamps = failureReportIncludeTimestamps } let extractFromNode node = let RunNodeCommonWithStatus {..} = runNodeCommon node in (runTreeId, (T.pack runTreeLabel, runTreeVisibilityLevel))
src/Test/Sandwich/Formatters/Print.hs view
@@ -27,7 +27,7 @@ import Test.Sandwich.Formatters.Common.Util import Test.Sandwich.Formatters.Print.Common import Test.Sandwich.Formatters.Print.FailureReason-import Test.Sandwich.Formatters.Print.Printing+import Test.Sandwich.Formatters.Print.Printing as Printing import Test.Sandwich.Formatters.Print.Types import Test.Sandwich.Formatters.Print.Util import Test.Sandwich.Interpreters.RunTree.Util@@ -76,16 +76,34 @@ runWithIndentation node@(RunNodeIt {..}) = do let common@(RunNodeCommonWithStatus {..}) = runNodeCommon + (PrintFormatter {..}, _, _) <- ask+ result <- liftIO $ waitForTree node + let printTiming = liftIO (readTVarIO runTreeStatus) >>= \case+ Done {..} -> p [i| (#{diffUTCTime statusEndTime statusStartTime})|]+ _ -> return () -- Shouldn't happen+ -- Print the main header case result of- Success -> pGreenLn runTreeLabel- DryRun -> pin runTreeLabel- Cancelled -> pin runTreeLabel+ Success -> do+ pGreen runTreeLabel+ when (printFormatterIncludeTimestamps == IncludeTimestampsAlways) printTiming+ p "\n"+ DryRun -> do+ Printing.pi runTreeLabel+ when (printFormatterIncludeTimestamps == IncludeTimestampsAlways) printTiming+ p "\n"+ Cancelled -> do+ Printing.pi runTreeLabel+ when (printFormatterIncludeTimestamps == IncludeTimestampsAlways) printTiming+ p "\n" (Failure (Pending _ _)) -> pYellowLn runTreeLabel (Failure reason) -> do- pRedLn runTreeLabel+ pRed runTreeLabel+ when (printFormatterIncludeTimestamps /= IncludeTimestampsNever) printTiming+ p "\n"+ withBumpIndent $ printFailureReason reason finishPrinting common result
src/Test/Sandwich/Formatters/Print/FailureReason.hs view
@@ -2,7 +2,6 @@ -- | Pretty printing failure reasons - module Test.Sandwich.Formatters.Print.FailureReason ( printFailureReason ) where@@ -28,10 +27,8 @@ printFailureReason :: FailureReason -> ReaderT (PrintFormatter, Int, Handle) IO () printFailureReason (Reason _ s) = do printShowBoxPrettyWithTitleString "Reason: " s-#ifndef mingw32_HOST_OS printFailureReason (RawImage _ fallback _image) = do forM_ (L.lines fallback) pin-#endif printFailureReason (ChildrenFailed _ n) = do picn midWhite ([i|#{n} #{if n == 1 then ("child" :: String) else "children"} failed|] :: String) printFailureReason (ExpectedButGot _ seb1 seb2) = do
src/Test/Sandwich/Formatters/Print/Printing.hs view
@@ -25,9 +25,14 @@ pn msg = printWithColor Nothing (msg <> "\n") pcn color msg = printWithColor (Just (SetRGBColor Foreground color)) (msg <> "\n") -pGreenLn msg = printIndentedWithColor (Just (SetColor Foreground Dull Green)) (msg <> "\n")-pYellowLn msg = printIndentedWithColor (Just (SetColor Foreground Dull Yellow)) (msg <> "\n")-pRedLn msg = printIndentedWithColor (Just (SetColor Foreground Dull Red)) (msg <> "\n") -- Tried solarizedRed here but it was too orange+pGreen msg = printIndentedWithColor (Just (SetColor Foreground Dull Green)) msg+pGreenLn msg = pGreen (msg <> "\n")++pYellow msg = printIndentedWithColor (Just (SetColor Foreground Dull Yellow)) msg+pYellowLn msg = pYellow (msg <> "\n")++pRed msg = printIndentedWithColor (Just (SetColor Foreground Dull Red)) msg -- Tried solarizedRed here but it was too orange+pRedLn msg = pRed (msg <> "\n") printIndentedWithColor maybeColor msg = do (PrintFormatter {}, indent, h) <- ask
src/Test/Sandwich/Formatters/Print/Types.hs view
@@ -14,8 +14,16 @@ -- ^ Whether to include callstacks with failures. , printFormatterIndentSize :: Int -- ^ The indentation unit in spaces. Defaults to 4.+ , printFormatterIncludeTimestamps :: IncludeTimestamps+ -- ^ Whether to include timestamps in output. Defaults to 'IncludeTimestampsNever'. } deriving (Show) +data IncludeTimestamps =+ IncludeTimestampsAlways+ | IncludeTimestampsNever+ | IncludeTimestampsFailuresOnly+ deriving (Show, Eq)+ defaultPrintFormatter :: PrintFormatter defaultPrintFormatter = PrintFormatter { printFormatterUseColor = True@@ -23,4 +31,5 @@ , printFormatterVisibilityThreshold = 50 , printFormatterIncludeCallStacks = True , printFormatterIndentSize = 4+ , printFormatterIncludeTimestamps = IncludeTimestampsNever }
+ src/Test/Sandwich/Formatters/TerminalUI.hs view
@@ -0,0 +1,456 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE CPP #-}++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+ , terminalUILogLevel+ , terminalUIInitialFolding+ , terminalUIDefaultEditor+ , terminalUIOpenInEditor+ , terminalUICustomExceptionFormatters++ -- * Auxiliary types+ , InitialFolding(..)+ , CustomTUIException(..)++ -- * Util+ , isTuiFormatterSupported+ ) where++import Brick as B+import Brick.BChan+import Brick.Widgets.List+import Control.Concurrent+import Control.Concurrent.Async+import Control.Concurrent.STM+import Control.Exception.Safe+import Control.Monad+import Control.Monad.IO.Class+import Control.Monad.IO.Unlift+import Control.Monad.Logger hiding (logError)+import Data.Either+import Data.Foldable+import qualified Data.List as L+import Data.Maybe+import qualified Data.Sequence as Seq+import qualified Data.Set as S+import Data.String.Interpolate+import Data.Time+import qualified Data.Vector as Vec+import GHC.Stack+import qualified Graphics.Vty as V+import qualified Graphics.Vty.CrossPlatform as V+import Lens.Micro+import Safe+import System.FilePath+import Test.Sandwich.Formatters.TerminalUI.AttrMap+import Test.Sandwich.Formatters.TerminalUI.CrossPlatform+import Test.Sandwich.Formatters.TerminalUI.Draw+import Test.Sandwich.Formatters.TerminalUI.Filter+import Test.Sandwich.Formatters.TerminalUI.Keys+import Test.Sandwich.Formatters.TerminalUI.Types+import Test.Sandwich.Interpreters.RunTree.Util+import Test.Sandwich.Interpreters.StartTree+import Test.Sandwich.Logging+import Test.Sandwich.RunTree+import Test.Sandwich.Shutdown+import Test.Sandwich.Types.ArgParsing+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+import Test.Sandwich.Util+++instance Formatter TerminalUIFormatter where+ formatterName _ = "terminal-ui-formatter"+ runFormatter = runApp+ finalizeFormatter _ _ _ = return ()++isTuiFormatterSupported :: IO Bool+isTuiFormatterSupported = isRight <$> tryAny (V.mkVty V.defaultConfig)++runApp :: (MonadLoggerIO m, MonadUnliftIO m) => TerminalUIFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()+runApp (TerminalUIFormatter {..}) rts _maybeCommandLineOptions baseContext = do+ startTime <- liftIO getCurrentTime++ liftIO $ setInitialFolding terminalUIInitialFolding rts++ rtsFixed <- liftIO $ atomically $ mapM fixRunTree rts++ let initialState = updateFilteredTree $+ AppState {+ _appRunTreeBase = rts+ , _appRunTree = rtsFixed+ , _appMainList = list MainList mempty 1+ , _appBaseContext = baseContext++ , _appStartTime = startTime+ , _appCurrentTime = startTime++ , _appVisibilityThresholdSteps = L.sort $ L.nub $ terminalUIVisibilityThreshold : (fmap runTreeVisibilityLevel $ concatMap getCommons rts)+ , _appVisibilityThreshold = terminalUIVisibilityThreshold++ , _appLogLevel = terminalUILogLevel+ , _appShowRunTimes = terminalUIShowRunTimes+ , _appShowFileLocations = terminalUIShowFileLocations+ , _appShowVisibilityThresholds = terminalUIShowVisibilityThresholds++ , _appOpenInEditor = terminalUIOpenInEditor terminalUIDefaultEditor (const $ return ())+ , _appDebug = (const $ return ())+ , _appCustomExceptionFormatters = terminalUICustomExceptionFormatters+ }++ eventChan <- liftIO $ newBChan 10++ logFn <- askLoggerIO++ currentFixedTree <- liftIO $ newTVarIO rtsFixed+ eventAsync <- liftIO $ async $+ forever $ do+ handleAny (\e -> flip runLoggingT logFn (logError [i|Got exception in event async: #{e}|]) >> threadDelay terminalUIRefreshPeriod) $ do+ newFixedTree <- atomically $ do+ currentFixed <- readTVar currentFixedTree+ newFixed <- mapM fixRunTree rts+ when (fmap getCommons newFixed == fmap getCommons currentFixed) retry+ writeTVar currentFixedTree newFixed+ return newFixed+ writeBChan eventChan (RunTreeUpdated newFixedTree)+ threadDelay terminalUIRefreshPeriod++ let buildVty = do+ v <- V.mkVty V.defaultConfig+ let output = V.outputIface v+ when (V.supportsMode output V.Mouse) $+ liftIO $ V.setMode output V.Mouse True+ return v+ initialVty <- liftIO buildVty++ let updateCurrentTimeForever period = forever $ do+ now <- getCurrentTime+ writeBChan eventChan (CurrentTimeUpdated now)+ threadDelay period++ liftIO $+ (case terminalUIClockUpdatePeriod of Nothing -> id; Just ts -> \action -> withAsync (updateCurrentTimeForever ts) (\_ -> action)) $+ flip onException (cancel eventAsync) $+ void $ customMain initialVty buildVty (Just eventChan) app initialState++app :: App AppState AppEvent ClickableName+app = App {+ appDraw = drawUI+ , appChooseCursor = showFirstCursor+#if MIN_VERSION_brick(1,0,0)+ , appHandleEvent = \event -> get >>= \s -> appEvent s event+ , appStartEvent = return ()+#else+ , appHandleEvent = appEvent+ , appStartEvent = return+#endif+ , appAttrMap = const mainAttrMap+ }++#if MIN_VERSION_brick(1,0,0)+continue :: AppState -> EventM ClickableName AppState ()+continue = put++continueNoChange :: AppState -> EventM ClickableName AppState ()+continueNoChange _ = return ()++doHalt _ = halt+#else+continueNoChange :: AppState -> EventM ClickableName (Next AppState)+continueNoChange = continue++doHalt = halt+#endif++#if MIN_VERSION_brick(1,0,0)+appEvent :: AppState -> BrickEvent ClickableName AppEvent -> EventM ClickableName AppState ()+#else+appEvent :: AppState -> BrickEvent ClickableName AppEvent -> EventM ClickableName (Next AppState)+#endif+appEvent s (AppEvent (RunTreeUpdated newTree)) = do+ now <- liftIO getCurrentTime+ continue $ s+ & appRunTree .~ newTree+ & appCurrentTime .~ now+ & updateFilteredTree+appEvent s (AppEvent (CurrentTimeUpdated ts)) = do+ continue $ s+ & appCurrentTime .~ ts++appEvent s (MouseDown ColorBar _ _ (B.Location (x, _))) = do+ lookupExtent ColorBar >>= \case+ Nothing -> continue s+ Just (Extent {extentSize=(w, _), extentUpperLeft=(B.Location (l, _))}) -> do+ let percent :: Double = (fromIntegral (x - l)) / (fromIntegral w)+ let allCommons = concatMap getCommons $ s ^. appRunTree+ let index = max 0 $ min (length allCommons - 1) $ round $ percent * (fromIntegral $ (length allCommons - 1))+ -- A subsequent RunTreeUpdated will pick up the new open nodes+ liftIO $ openIndices (s ^. appRunTreeBase) (runTreeAncestors $ allCommons !! index)+ continue $ s+ & appMainList %~ (listMoveTo index)+ & updateFilteredTree++appEvent s (MouseDown (ListRow _i) V.BScrollUp _ _) = do+ vScrollBy (viewportScroll MainList) (-1)+ continueNoChange s+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 (VtyEvent e) =+ case e of+ -- Column 1+ V.EvKey c [] | c == nextKey -> continue (s & appMainList %~ (listMoveBy 1))+ V.EvKey c [] | c == previousKey -> continue (s & appMainList %~ (listMoveBy (-1)))+ 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+ Nothing -> zip [0..] ls+ case L.find (isFailureStatus . status . snd) listToSearch of+ Nothing -> continue s+ Just (i', _) -> continue (s & appMainList %~ (listMoveTo i'))+ 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)+ Nothing -> L.reverse (zip [0..] ls)+ case L.find (isFailureStatus . status . snd) listToSearch of+ Nothing -> continue s+ Just (i', _) -> continue (s & appMainList %~ (listMoveTo i'))+ V.EvKey c [] | c == closeNodeKey -> modifyOpen s (const False)+ V.EvKey c [] | c == openNodeKey -> modifyOpen s (const True)+ V.EvKey c@(V.KChar ch) [V.MMeta] | c `elem` (fmap V.KChar ['0'..'9']) -> do+ let num :: Int = read [ch]+ liftIO $ openToDepth (s ^. (appMainList . listElementsL)) num+ continue s+ V.EvKey c [] | c `elem` toggleKeys -> modifyToggled s not++ -- Scrolling in toggled items+ -- Wanted to make these uniformly Ctrl+whatever, but Ctrl+PageUp/PageDown was causing it to get KEsc and exit (?)+ V.EvKey V.KUp [V.MCtrl] -> withScroll s $ \vp -> vScrollBy vp (-1)+ V.EvKey (V.KChar 'p') [V.MCtrl] -> withScroll s $ \vp -> vScrollBy vp (-1)+ V.EvKey V.KDown [V.MCtrl] -> withScroll s $ \vp -> vScrollBy vp 1+ V.EvKey (V.KChar 'n') [V.MCtrl] -> withScroll s $ \vp -> vScrollBy vp 1+ V.EvKey (V.KChar 'v') [V.MMeta] -> withScroll s $ \vp -> vScrollPage vp Up+ V.EvKey (V.KChar 'v') [V.MCtrl] -> withScroll s $ \vp -> vScrollPage vp Down+ V.EvKey V.KHome [V.MCtrl] -> withScroll s $ \vp -> vScrollToBeginning vp+ V.EvKey V.KEnd [V.MCtrl] -> withScroll s $ \vp -> vScrollToEnd vp++ -- Column 2+ V.EvKey c [] | c == cancelAllKey -> do+ liftIO $ mapM_ cancelNode (s ^. appRunTreeBase)+ continue s+ V.EvKey c [] | c == cancelSelectedKey -> withContinueS s $ do+ whenJust (listSelectedElement (s ^. appMainList)) $ \(_, MainListElem {..}) -> liftIO $+ (readTVarIO $ runTreeStatus node) >>= \case+ Running {..} -> cancel statusAsync+ _ -> return ()+ V.EvKey c [] | c == runAllKey -> withContinueS s $ do+ when (all (not . isRunning . runTreeStatus . runNodeCommon) (s ^. appRunTree)) $ liftIO $ do+ mapM_ clearRecursively (s ^. appRunTreeBase)+ void $ async $ void $ runNodesSequentially (s ^. appRunTreeBase) (s ^. appBaseContext)+ V.EvKey c [] | c == runSelectedKey -> withContinueS s $+ whenJust (listSelectedElement (s ^. appMainList)) $ \(_, MainListElem {..}) -> case status of+ Running {} -> return ()+ _ -> do+ -- Get the set of IDs for only this node's ancestors and children+ let ancestorIds = S.fromList $ toList $ runTreeAncestors node+ case findRunNodeChildrenById ident (s ^. appRunTree) of+ Nothing -> return ()+ Just childIds -> do+ let allIds = ancestorIds <> childIds+ -- Clear the status of all affected nodes+ liftIO $ mapM_ (clearRecursivelyWhere (\x -> runTreeId x `S.member` allIds)) (s ^. appRunTreeBase)+ -- Start a run for all affected nodes+ let bc = (s ^. appBaseContext) { baseContextOnlyRunIds = Just allIds }+ void $ liftIO $ async $ void $ runNodesSequentially (s ^. appRunTreeBase) bc+ V.EvKey c [] | c == clearSelectedKey -> withContinueS s $ do+ whenJust (listSelectedElement (s ^. appMainList)) $ \(_, MainListElem {..}) -> case status of+ Running {} -> return ()+ _ -> case findRunNodeChildrenById ident (s ^. appRunTree) of+ Nothing -> return ()+ Just childIds -> liftIO $ mapM_ (clearRecursivelyWhere (\x -> runTreeId x `S.member` childIds)) (s ^. appRunTreeBase)+ V.EvKey c [] | c == clearAllKey -> withContinueS s $ do+ liftIO $ mapM_ clearRecursively (s ^. appRunTreeBase)+ V.EvKey c [] | c == openSelectedFolderInFileExplorer -> withContinueS s $ do+ whenJust (listSelectedElement (s ^. appMainList)) $ \(_i, MainListElem {folderPath}) ->+ whenJust folderPath $ liftIO . openFileExplorerFolderPortable+ V.EvKey c [] | c == openTestRootKey -> withContinueS s $+ whenJust (baseContextRunRoot (s ^. appBaseContext)) $ liftIO . openFileExplorerFolderPortable+ V.EvKey c [] | c == openTestInEditorKey -> case listSelectedElement (s ^. appMainList) of+ Just (_i, MainListElem {node=(runTreeLoc -> Just loc)}) -> openSrcLoc s loc+ _ -> continue s+ V.EvKey c [] | c == openLogsInEditorKey -> case listSelectedElement (s ^. appMainList) of+ Just (_i, MainListElem {node=(runTreeFolder -> Just dir)}) -> do+ let srcLoc = SrcLoc {+ srcLocPackage = ""+ , srcLocModule = ""+ , srcLocFile = dir </> "test_logs.txt"+ , srcLocStartLine = 0+ , srcLocStartCol = 0+ , srcLocEndLine = 0+ , srcLocEndCol = 0+ }+ suspendAndResume ((s ^. appOpenInEditor) srcLoc >> return s)+ _ -> continue s+ V.EvKey c [] | c == openFailureInEditorKey -> do+ case (listSelectedElement (s ^. appMainList)) of+ Nothing -> continue s+ Just (_i, MainListElem {status}) -> case status of+ Done _ _ _ _ (Failure (failureCallStack -> Just (getCallStack -> ((_, loc):_)))) -> openSrcLoc s loc+ _ -> continue s++ -- Column 3+ V.EvKey c [] | c == cycleVisibilityThresholdKey -> do+ let newVisibilityThreshold = case [(i, x) | (i, x) <- zip [0..] (s ^. appVisibilityThresholdSteps)+ , x > s ^. appVisibilityThreshold] of+ [] -> 0+ xs -> minimum $ fmap snd xs+ continue $ s+ & appVisibilityThreshold .~ newVisibilityThreshold+ & updateFilteredTree+ V.EvKey c [] | c == toggleShowRunTimesKey -> continue $ s+ & appShowRunTimes %~ not+ V.EvKey c [] | c == toggleFileLocationsKey -> continue $ s+ & appShowFileLocations %~ not+ V.EvKey c [] | c == toggleVisibilityThresholdsKey -> continue $ s+ & appShowVisibilityThresholds %~ not+ V.EvKey c [] | c `elem` [V.KEsc, exitKey] -> do+ -- Cancel everything and wait for cleanups+ liftIO $ mapM_ cancelNode (s ^. appRunTreeBase)+ forM_ (s ^. appRunTreeBase) (liftIO . waitForTree)+ doHalt s+ V.EvKey c [] | c == debugKey -> continue (s & appLogLevel ?~ LevelDebug)+ V.EvKey c [] | c == infoKey -> continue (s & appLogLevel ?~ LevelInfo)+ V.EvKey c [] | c == warnKey -> continue (s & appLogLevel ?~ LevelWarn)+ V.EvKey c [] | c == errorKey -> continue (s & appLogLevel ?~ LevelError)++#if MIN_VERSION_brick(1,0,0)+ ev -> zoom appMainList $ handleListEvent ev+#else+ ev -> handleEventLensed s appMainList handleListEvent ev >>= continue+#endif++ where withContinueS s action = action >> continue s+#if MIN_VERSION_brick(1,0,0)+appEvent _ _ = return ()+#else+appEvent s _ = continue s+#endif++modifyToggled s f = case listSelectedElement (s ^. appMainList) of+ Nothing -> continue s+ Just (_i, MainListElem {..}) -> do+ liftIO $ atomically $ modifyTVar (runTreeToggled node) f+ continue s++modifyOpen s f = case listSelectedElement (s ^. appMainList) of+ Nothing -> continue s+ Just (_i, MainListElem {..}) -> do+ liftIO $ atomically $ modifyTVar (runTreeOpen node) f+ continue s++openIndices :: [RunNode context] -> Seq.Seq Int -> IO ()+openIndices nodes openSet =+ atomically $ forM_ (concatMap getCommons nodes) $ \node ->+ when ((runTreeId node) `elem` (toList openSet)) $+ modifyTVar (runTreeOpen node) (const True)++openToDepth :: (Foldable t) => t MainListElem -> Int -> IO ()+openToDepth elems thresh =+ atomically $ forM_ elems $ \(MainListElem {..}) ->+ if | (depth < thresh) -> modifyTVar (runTreeOpen node) (const True)+ | otherwise -> modifyTVar (runTreeOpen node) (const False)++setInitialFolding :: InitialFolding -> [RunNode BaseContext] -> IO ()+setInitialFolding InitialFoldingAllOpen _rts = return ()+setInitialFolding InitialFoldingAllClosed rts =+ atomically $ forM_ (concatMap getCommons rts) $ \(RunNodeCommonWithStatus {..}) ->+ modifyTVar runTreeOpen (const False)+setInitialFolding (InitialFoldingTopNOpen n) rts =+ atomically $ forM_ (concatMap getCommons rts) $ \(RunNodeCommonWithStatus {..}) ->+ when (Seq.length runTreeAncestors > n) $+ modifyTVar runTreeOpen (const False)++updateFilteredTree :: AppState -> AppState+updateFilteredTree s = s+ & appMainList %~ listReplace elems (listSelected $ s ^. appMainList)+ where filteredTree = filterRunTree (s ^. appVisibilityThreshold) (s ^. appRunTree)+ elems :: Vec.Vector MainListElem = Vec.fromList $ concatMap treeToList (zip filteredTree (s ^. appRunTreeBase))++-- * Clearing++clearRecursively :: RunNode context -> IO ()+clearRecursively = mapM_ clearCommon . getCommons++clearRecursivelyWhere :: (RunNodeCommon -> Bool) -> RunNode context -> IO ()+clearRecursivelyWhere f = mapM_ clearCommon . filter f . getCommons++clearCommon :: RunNodeCommon -> IO ()+clearCommon (RunNodeCommonWithStatus {..}) = do+ atomically $ do+ writeTVar runTreeStatus NotStarted+ writeTVar runTreeLogs mempty++ -- TODO: clearing the folders might be better for reproducibility, but it might be more surprising than not doing it.+ -- Also, we'd want to be a little judicious about which folders get cleared -- clearing entire "describe" folders would+ -- blow away unrelated test results. So maybe it's better to not clear, and for tests to just do idempotent things in+ -- their folders.+ -- whenJust runTreeFolder $ \folder -> do+ -- doesDirectoryExist folder >>= \case+ -- False -> return ()+ -- True -> clearDirectoryContents folder+ -- where+ -- clearDirectoryContents :: FilePath -> IO ()+ -- clearDirectoryContents path = do+ -- paths <- listDirectory path+ -- forM_ paths removePathForcibly++findRunNodeChildrenById :: Int -> [RunNodeFixed context] -> Maybe (S.Set Int)+findRunNodeChildrenById ident rts = headMay $ mapMaybe (findRunNodeChildrenById' ident) rts++findRunNodeChildrenById' :: Int -> RunNodeFixed context -> Maybe (S.Set Int)+findRunNodeChildrenById' ident node | ident == runTreeId (runNodeCommon node) = Just $ S.fromList $ extractValues (runTreeId . runNodeCommon) node+findRunNodeChildrenById' _ident (RunNodeIt {}) = Nothing+findRunNodeChildrenById' ident (RunNodeIntroduce {..}) = findRunNodeChildrenById ident runNodeChildrenAugmented+findRunNodeChildrenById' ident (RunNodeIntroduceWith {..}) = findRunNodeChildrenById ident runNodeChildrenAugmented+findRunNodeChildrenById' ident node = findRunNodeChildrenById ident (runNodeChildren node)++#if MIN_VERSION_brick(1,0,0)+withScroll :: AppState -> (forall s. ViewportScroll ClickableName -> EventM n s ()) -> EventM n AppState ()+#else+withScroll :: AppState -> (ViewportScroll ClickableName -> EventM n ()) -> EventM n (Next AppState)+#endif+withScroll s action = do+ case listSelectedElement (s ^. appMainList) of+ Nothing -> return ()+ Just (_, MainListElem {..}) -> do+ let scroll = viewportScroll (InnerViewport [i|viewport_#{ident}|])+ action scroll++#if !MIN_VERSION_brick(1,0,0)+ continue s+#endif++openSrcLoc s loc' = do+ -- Try to make the file path in the SrcLoc absolute+ loc <- case isRelative (srcLocFile loc') of+ False -> return loc'+ True -> do+ case optionsProjectRoot (baseContextOptions (s ^. appBaseContext)) of+ Just d -> return $ loc' { srcLocFile = d </> (srcLocFile loc') }+ Nothing -> return loc'++ -- TODO: check if the path exists and show a warning message if not+ -- Maybe choose the first callstack location we can find?+ suspendAndResume (((s ^. appOpenInEditor) loc) >> return s)
+ src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs view
@@ -0,0 +1,212 @@+{-# LANGUAGE CPP #-}++module Test.Sandwich.Formatters.TerminalUI.AttrMap where++import Brick+import Brick.Widgets.ProgressBar+import qualified Graphics.Vty as V+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec++#if MIN_VERSION_brick(1,0,0)+mkAttrName :: String -> AttrName+mkAttrName = attrName+#else+import Data.String++mkAttrName :: String -> AttrName+mkAttrName = fromString+#endif+++mainAttrMap :: AttrMap+mainAttrMap = attrMap V.defAttr [+ -- (listAttr, V.white `on` V.blue)+ -- (listSelectedAttr, V.blue `on` V.white)+ -- (listSelectedAttr, bg (V.Color240 $ V.rgbColorToColor240 0 1 0))+ -- (selectedAttr, bg (V.Color240 $ V.rgbColorToColor240 0 1 0))++ -- Top bar+ (visibilityThresholdNotSelectedAttr, fg midGray)+ , (visibilityThresholdSelectedAttr, fg solarizedBase2)++ -- Statuses+ -- , (notStartedAttr, fg V.)+ , (runningAttr, fg V.blue)+ , (pendingAttr, fg V.yellow)+ , (successAttr, fg V.green)+ , (failureAttr, fg V.red)+ , (totalAttr, fg solarizedCyan)++ -- Logging+ , (debugAttr, fg V.blue), (infoAttr, fg V.yellow), (warnAttr, fg V.red), (errorAttr, fg V.red), (otherAttr, V.defAttr)+ , (logTimestampAttr, fg midGray)+ , (logFilenameAttr, fg solarizedViolet)+ , (logModuleAttr, fg solarizedMagenta)+ , (logPackageAttr, fg solarizedGreen)+ , (logLineAttr, fg solarizedCyan)+ , (logChAttr, fg solarizedOrange)+ , (logFunctionAttr, fg solarizedMagenta)++ -- Progress bar+ , (progressCompleteAttr, bg (V.Color240 235))+ , (progressIncompleteAttr, bg (V.Color240 225))++ -- Main list+ , (toggleMarkerAttr, fg midGray)+ , (openMarkerAttr, fg midGray)+ , (visibilityThresholdIndicatorMutedAttr, fg $ grayAt 50)+ , (visibilityThresholdIndicatorAttr, fg $ grayAt 150)++ -- Hotkey stuff+ , (hotkeyAttr, fg V.blue)+ , (disabledHotkeyAttr, fg midGray)+ , (hotkeyMessageAttr, fg brightWhite)+ , (disabledHotkeyMessageAttr, fg brightGray)++ -- Exceptions and pretty printing+ , (expectedAttr, fg midWhite)+ , (sawAttr, fg midWhite)+ , (integerAttr, fg solarizedMagenta)+ , (floatAttr, fg solarizedMagenta)+ , (charAttr, fg solarizedCyan)+ , (stringAttr, fg solarizedYellow)+ , (dateAttr, fg solarizedBase2)+ , (timeAttr, fg solarizedBase1)+ , (quoteAttr, fg solarizedBase1)+ , (slashAttr, fg solarizedViolet)+ , (negAttr, fg solarizedViolet)+ , (listBracketAttr, fg solarizedOrange) -- TODO: make green?+ , (tupleBracketAttr, fg solarizedGreen)+ , (braceAttr, fg solarizedGreen)+ , (ellipsesAttr, fg solarizedBase0)+ , (recordNameAttr, fg solarizedRed)+ , (fieldNameAttr, fg solarizedYellow)+ , (constructorNameAttr, fg solarizedViolet)+ ]++-- selectedAttr :: AttrName+-- selectedAttr = "list_line_selected"++visibilityThresholdNotSelectedAttr :: AttrName+visibilityThresholdNotSelectedAttr = mkAttrName "visibility_threshold_not_selected"++visibilityThresholdSelectedAttr :: AttrName+visibilityThresholdSelectedAttr = mkAttrName "visibility_threshold_selected"++runningAttr :: AttrName+runningAttr = mkAttrName "running"++notStartedAttr :: AttrName+notStartedAttr = mkAttrName "not_started"++pendingAttr :: AttrName+pendingAttr = mkAttrName "pending"++totalAttr :: AttrName+totalAttr = mkAttrName "total"++successAttr :: AttrName+successAttr = mkAttrName "success"++failureAttr :: AttrName+failureAttr = mkAttrName "failure"++toggleMarkerAttr :: AttrName+toggleMarkerAttr = mkAttrName "toggleMarker"++openMarkerAttr :: AttrName+openMarkerAttr = mkAttrName "openMarker"++visibilityThresholdIndicatorAttr :: AttrName+visibilityThresholdIndicatorAttr = mkAttrName "visibilityThresholdIndicator"++visibilityThresholdIndicatorMutedAttr :: AttrName+visibilityThresholdIndicatorMutedAttr = mkAttrName "visibilityThresholdMutedIndicator"++hotkeyAttr, disabledHotkeyAttr, hotkeyMessageAttr, disabledHotkeyMessageAttr :: AttrName+hotkeyAttr = mkAttrName "hotkey"+disabledHotkeyAttr = mkAttrName "disableHotkey"+hotkeyMessageAttr = mkAttrName "hotkeyMessage"+disabledHotkeyMessageAttr = mkAttrName "disabledHotkeyMessage"++chooseAttr :: Status -> AttrName+chooseAttr NotStarted = notStartedAttr+chooseAttr (Running {}) = runningAttr+chooseAttr (Done _ _ _ _ (Success {})) = successAttr+chooseAttr (Done _ _ _ _ (Failure (Pending {}))) = pendingAttr+chooseAttr (Done _ _ _ _ (Failure {})) = failureAttr+chooseAttr (Done _ _ _ _ DryRun) = notStartedAttr+chooseAttr (Done _ _ _ _ Cancelled) = failureAttr++-- * Logging and callstacks++debugAttr, infoAttr, warnAttr, errorAttr, otherAttr :: AttrName+debugAttr = attrName"log_debug"+infoAttr = attrName"log_info"+warnAttr = attrName"log_warn"+errorAttr = attrName"log_error"+otherAttr = mkAttrName "log_other"++logTimestampAttr :: AttrName+logTimestampAttr = mkAttrName "log_timestamp"++logFilenameAttr, logModuleAttr, logPackageAttr, logLineAttr, logChAttr :: AttrName+logFilenameAttr = mkAttrName "logFilename"+logModuleAttr = mkAttrName "logModule"+logPackageAttr = mkAttrName "logPackage"+logLineAttr = mkAttrName "logLine"+logChAttr = mkAttrName "logCh"+logFunctionAttr = mkAttrName "logFunction"++-- * Exceptions and pretty printing++expectedAttr, sawAttr :: AttrName+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"+stringAttr = mkAttrName "string"+dateAttr = mkAttrName "date"+timeAttr = mkAttrName "time"+quoteAttr = mkAttrName "quote"+slashAttr = mkAttrName "slash"+negAttr = mkAttrName "neg"+listBracketAttr = mkAttrName "listBracket"+tupleBracketAttr = mkAttrName "tupleBracket"+braceAttr = mkAttrName "brace"+ellipsesAttr = mkAttrName "ellipses"+recordNameAttr = mkAttrName "recordName"+fieldNameAttr = mkAttrName "fieldName"+constructorNameAttr = mkAttrName "fieldName"++-- * Colors++solarizedBase03 = V.rgbColor 0x00 0x2b 0x36+solarizedBase02 = V.rgbColor 0x07 0x36 0x42+solarizedBase01 = V.rgbColor 0x58 0x6e 0x75+solarizedbase00 = V.rgbColor 0x65 0x7b 0x83+solarizedBase0 = V.rgbColor 0x83 0x94 0x96+solarizedBase1 = V.rgbColor 0x93 0xa1 0xa1+solarizedBase2 = V.rgbColor 0xee 0xe8 0xd5+solarizedBase3 = V.rgbColor 0xfd 0xf6 0xe3+solarizedYellow = V.rgbColor 0xb5 0x89 0x00+solarizedOrange = V.rgbColor 0xcb 0x4b 0x16+solarizedRed = V.rgbColor 0xdc 0x32 0x2f+solarizedMagenta = V.rgbColor 0xd3 0x36 0x82+solarizedViolet = V.rgbColor 0x6c 0x71 0xc4+solarizedBlue = V.rgbColor 0x26 0x8b 0xd2+solarizedCyan = V.rgbColor 0x2a 0xa1 0x98+solarizedGreen = V.rgbColor 0x85 0x99 0x00++midGray = grayAt 50+brightGray = grayAt 80+midWhite = grayAt 140+brightWhite = grayAt 200++grayAt level = V.rgbColor level level level+-- grayAt level = V.Color240 $ V.rgbColorToColor240 level level level
+ src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs view
@@ -0,0 +1,12 @@+-- |++module Test.Sandwich.Formatters.TerminalUI.CrossPlatform (+ openFileExplorerFolderPortable+ ) where++import Control.Monad+import System.Process++-- | TODO: report exceptions here+openFileExplorerFolderPortable folder = do+ void $ readCreateProcessWithExitCode (proc "xdg-open" [folder]) ""
+ src/Test/Sandwich/Formatters/TerminalUI/Draw.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE CPP #-}++module Test.Sandwich.Formatters.TerminalUI.Draw where++import Brick+import Brick.Widgets.Border+import Brick.Widgets.Center+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+import qualified Data.Sequence as Seq+import Data.String.Interpolate+import qualified Data.Text.Encoding as E+import Data.Time.Clock+import GHC.Stack+import Lens.Micro+import Safe+import Test.Sandwich.Formatters.Common.Count+import Test.Sandwich.Formatters.Common.Util+import Test.Sandwich.Formatters.TerminalUI.AttrMap+import Test.Sandwich.Formatters.TerminalUI.Draw.ColorProgressBar+import Test.Sandwich.Formatters.TerminalUI.Draw.RunTimes+import Test.Sandwich.Formatters.TerminalUI.Draw.ToBrickWidget+import Test.Sandwich.Formatters.TerminalUI.Draw.TopBox+import Test.Sandwich.Formatters.TerminalUI.Draw.Util+import Test.Sandwich.Formatters.TerminalUI.Types+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+++drawUI :: AppState -> [Widget ClickableName]+drawUI app = [ui]+ where+ ui = vBox [+ topBox app+ , borderWithCounts app+ , mainList app+ , clickable ColorBar $ bottomProgressBarColored app+ ]++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 [+ Just $ renderLine isSelected x+ , do+ guard toggled+ let infoWidgets = getInfoWidgets x+ guard (not $ L.null infoWidgets)+ return $ padLeft (Pad 4) $+ fixedHeightOrViewportPercent (InnerViewport [i|viewport_#{ident}|]) 33 $+ vBox infoWidgets+ ]++ renderLine _isSelected (MainListElem {..}) = hBox $ catMaybes [+ Just $ withAttr openMarkerAttr $ str (if open then "[-] " else "[+] ")+ , Just $ withAttr (chooseAttr status) (str label)+ , if not (app ^. appShowFileLocations) then Nothing else+ case runTreeLoc node of+ Nothing -> Nothing+ Just loc ->+ Just $ hBox [str " ["+ , withAttr logFilenameAttr $ str $ srcLocFile loc+ , str ":"+ , withAttr logLineAttr $ str $ show $ srcLocStartLine loc+ , str "]"]+ , if not (app ^. appShowVisibilityThresholds) then Nothing else+ Just $ hBox [str " ["+ , withAttr visibilityThresholdIndicatorMutedAttr $ str "V="+ , withAttr visibilityThresholdIndicatorAttr $ str $ show visibilityLevel+ , str "]"]+ , Just $ padRight Max $ withAttr toggleMarkerAttr $ str (if toggled then " [-]" else " [+]")+ , if not (app ^. appShowRunTimes) then Nothing else case status of+ Running {..} -> Just $ getRunTimes app statusStartTime (app ^. appCurrentTime) statusSetupTime Nothing True+ Done {..} -> Just $ getRunTimes app statusStartTime statusEndTime statusSetupTime statusTeardownTime False+ _ -> Nothing+ ]++ getInfoWidgets mle@(MainListElem {..}) = catMaybes [Just $ runReader (toBrickWidget status) (app ^. appCustomExceptionFormatters), callStackWidget mle, logWidget mle]++ callStackWidget (MainListElem {..}) = do+ 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+ Nothing -> mempty+ Just logLevel -> Seq.filter (\x -> logEntryLevel x >= logLevel) logs+ guard (not $ Seq.null filteredLogs)+ return $ borderWithLabel (padLeftRight 1 $ str "Logs") $ vBox $+ toList $ fmap logEntryWidget filteredLogs++ logEntryWidget (LogEntry {..}) = hBox [+ withAttr logTimestampAttr $ str (show logEntryTime)+ , str " "+ , logLevelWidget logEntryLevel+ , str " "+ , logLocWidget logEntryLoc+ , str " "+ , txtWrap (E.decodeUtf8 $ fromLogStr logEntryStr)+ ]++ logLocWidget (Loc {loc_start=(line, ch), ..}) = hBox [+ str "["+ , withAttr logFilenameAttr $ str loc_filename+ , str ":"+ , withAttr logLineAttr $ str (show line)+ , str ":"+ , withAttr logChAttr $ str (show ch)+ , str "]"+ ]++ logLevelWidget LevelDebug = withAttr debugAttr $ str "(DEBUG)"+ logLevelWidget LevelInfo = withAttr infoAttr $ str "(INFO)"+ logLevelWidget LevelWarn = withAttr infoAttr $ str "(WARN)"+ logLevelWidget LevelError = withAttr infoAttr $ str "(ERROR)"+ logLevelWidget (LevelOther x) = withAttr infoAttr $ str [i|#{x}|]+++borderWithCounts app = hBorderWithLabel $ padLeftRight 1 $ hBox (L.intercalate [str ", "] countWidgets <> [str [i| of |]+ , withAttr totalAttr $ str $ show totalNumTests+ , str [i| in |]+ , withAttr timeAttr $ str $ formatNominalDiffTime (diffUTCTime (app ^. appCurrentTime) (app ^. appStartTime))])+ where+ countWidgets =+ (if totalSucceededTests > 0 then [[withAttr successAttr $ str $ show totalSucceededTests, str " succeeded"]] else mempty)+ <> (if totalFailedTests > 0 then [[withAttr failureAttr $ str $ show totalFailedTests, str " failed"]] else mempty)+ <> (if totalPendingTests > 0 then [[withAttr pendingAttr $ str $ show totalPendingTests, str " pending"]] else mempty)+ <> (if totalRunningTests > 0 then [[withAttr runningAttr $ str $ show totalRunningTests, str " running"]] else mempty)+ <> (if totalNotStartedTests > 0 then [[str $ show totalNotStartedTests, str " not started"]] else mempty)++ totalNumTests = countWhere isItBlock (app ^. appRunTree)+ totalSucceededTests = countWhere isSuccessItBlock (app ^. appRunTree)+ totalPendingTests = countWhere isPendingItBlock (app ^. appRunTree)+ 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
+ src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE MultiWayIf #-}++module Test.Sandwich.Formatters.TerminalUI.Draw.ColorProgressBar (+ bottomProgressBarColored+ ) where++import Brick+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+import Test.Sandwich.Formatters.TerminalUI.Types+import Test.Sandwich.RunTree+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec++type Chunk a = [(Rational, a)]++data ChunkSum = ChunkSum { _running :: Rational+ , _notStarted :: Rational+ , _pending :: Rational+ , _success :: Rational+ , _failure :: Rational }++zeroChunkSum :: ChunkSum+zeroChunkSum = ChunkSum 0 0 0 0 0++makeLenses ''ChunkSum++splitIntoChunks :: forall a. (Show a) => Rational -> [(Rational, a)] -> [[(Rational, a)]]+splitIntoChunks _ [] = []+splitIntoChunks chunkSize remaining = chunk : (splitIntoChunks chunkSize remaining')+ where+ (chunk, remaining') = go [] chunkSize remaining++ go :: Chunk a -> Rational -> [(Rational, a)] -> (Chunk a, [(Rational, a)])+ go chunkSoFar needed ((amount, val):xs) =+ if | amount == needed -> (chunkSoFar <> [(amount, val)], xs)+ | amount < needed -> go (chunkSoFar <> [(amount, val)]) (needed - amount) xs+ | amount > needed -> (chunkSoFar <> [(needed, val)], (amount - needed, val):xs)+ | otherwise -> error "impossible"+ go chunkSoFar needed [] = error [i|Bottomed out in go: #{chunkSoFar}, #{needed}|]++-- TODO: improve this to use block chars+getCharForChunk :: [(Rational, Status)] -> Widget n+getCharForChunk chunk = withAttr attrToUse (str full_five_eighth_height)+ where ChunkSum {..} = sumChunk chunk+ (_, attrToUse) = maxBy fst [(_running, runningAttr)+ , (_notStarted, notStartedAttr)+ , (_pending, pendingAttr)+ , (_success, successAttr)+ , (_failure, failureAttr)+ ]++sumChunk :: Chunk Status -> ChunkSum+sumChunk = foldl combine zeroChunkSum+ where combine chunkSum (amount, status) = chunkSum & (lensForStatus status) %~ (+ amount)++ lensForStatus NotStarted = notStarted+ lensForStatus (Running {}) = running+ lensForStatus (Done {statusResult=Success}) = success+ lensForStatus (Done {statusResult=(Failure (Pending {}))}) = pending+ lensForStatus (Done {statusResult=(Failure _)}) = failure+ lensForStatus (Done {statusResult=DryRun}) = notStarted+ lensForStatus (Done {statusResult=Cancelled}) = failure++maxBy :: (Foldable t, Ord a) => (b -> a) -> t b -> b+maxBy = maximumBy . comparing++-- * Block elems++-- full = "█"+-- seven_eighth = "▉"+-- six_eighth = "▊"+-- five_eighth = "▋"+-- four_eighth = "▌"+-- three_eighth = "▍"+-- two_eighth = "▎"+-- one_eighth = "▏"++full_five_eighth_height = "▆"++-- * Exports++bottomProgressBarColored app = Widget Greedy Fixed $ do+ c <- getContext+ render $ bottomProgressBarColoredWidth app (c ^. availWidthL)++bottomProgressBarColoredWidth app width = hBox [getCharForChunk chunk | chunk <- chunks]+ where+ statuses = concatMap getStatuses (app ^. appRunTree)+ statusesWithAmounts = [(testsPerChar, x) | x <- statuses]++ chunks = splitIntoChunks 1 statusesWithAmounts++ testsPerChar :: Rational = fromIntegral width / fromIntegral (length statuses)++ getStatuses :: (HasCallStack) => RunNodeWithStatus context a l t -> [a]+ getStatuses = extractValues (runTreeStatus . runNodeCommon)
+ src/Test/Sandwich/Formatters/TerminalUI/Draw/RunTimes.hs view
@@ -0,0 +1,39 @@++module Test.Sandwich.Formatters.TerminalUI.Draw.RunTimes (getRunTimes) where++import Brick+import Data.Maybe+import Data.String.Interpolate+import Data.Time.Clock+import qualified Graphics.Vty as V+import Lens.Micro+import Test.Sandwich.Formatters.Common.Util+import Test.Sandwich.Formatters.TerminalUI.AttrMap+import Test.Sandwich.Formatters.TerminalUI.Types+++minGray :: Int = 50+maxGray :: Int = 255++getRunTimes app startTime endTime statusSetupTime statusTeardownTime showEllipses = raw setupWork <+> raw actualWork <+> raw teardownWork+ where+ totalElapsed = diffUTCTime (app ^. appCurrentTime) (app ^. appStartTime)++ actualWorkTime = (diffUTCTime endTime startTime) - (fromMaybe 0 statusSetupTime) - (fromMaybe 0 statusTeardownTime)++ setupWork = maybe mempty (\dt -> V.string (getAttr totalElapsed dt) [i|(#{formatNominalDiffTime dt}) + |]) statusSetupTime+ actualWork = V.string (getAttr totalElapsed actualWorkTime) (formatNominalDiffTime actualWorkTime <> (if showEllipses then "..." else ""))+ teardownWork = maybe mempty (\dt -> V.string (getAttr totalElapsed dt) [i| + (#{formatNominalDiffTime dt})|]) statusTeardownTime++getAttr :: NominalDiffTime -> NominalDiffTime -> V.Attr+getAttr totalElapsed dt = V.Attr {+ V.attrStyle = V.Default+ , V.attrForeColor = V.SetTo $ grayAt $ getLevel (realToFrac totalElapsed) (realToFrac dt)+ , V.attrBackColor = V.Default+ , V.attrURL = V.Default+ }++getLevel :: Double -> Double -> Int+getLevel totalElapsed duration = min maxGray $ max minGray $ round (fromIntegral minGray + (intensity * (fromIntegral (maxGray - minGray))))+ where+ intensity :: Double = logBase (totalElapsed + 1) (duration + 1)
+ src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs view
@@ -0,0 +1,198 @@+{-# LANGUAGE CPP #-}+{-# 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 -> Reader CustomExceptionFormatters (Widget n)++instance ToBrickWidget Status where+ toBrickWidget (NotStarted {}) = return $ strWrap "Not started."+ toBrickWidget (Running {statusStartTime}) = return $ strWrap [i|Started at #{statusStartTime}.|]+ toBrickWidget (Done startTime endTime setupTime teardownTime Success) = return $ strWrap ([i|Succeeded in #{showTimeDiff startTime endTime}.#{setupTeardownInfo}|])+ where+ setupInfo :: Maybe T.Text = (\t -> [i|Setup: #{formatNominalDiffTime t}.|]) <$> setupTime+ teardownInfo :: Maybe T.Text = (\t -> [i|Teardown: #{formatNominalDiffTime t}.|]) <$> teardownTime+ setupTeardownInfo = case catMaybes [setupInfo, teardownInfo] of+ [] -> ""+ xs -> " (" <> T.intercalate " " xs <> ")"+ toBrickWidget (Done {statusResult=(Failure failureReason)}) = toBrickWidget failureReason+ toBrickWidget (Done {statusResult=DryRun}) = return $ strWrap "Not started due to dry run."+ toBrickWidget (Done {statusResult=Cancelled}) = return $ strWrap "Cancelled."++showTimeDiff :: UTCTime -> UTCTime -> String+showTimeDiff startTime endTime = formatNominalDiffTime (diffUTCTime endTime startTime)++instance ToBrickWidget FailureReason where+ 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) = return $ boxWithTitle "Failure reason:" (strWrap msg)+ toBrickWidget (RawImage _ _ image) = return $ boxWithTitle "Failure reason:" (raw image)+ 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)+ 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)+ 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)+++boxWithTitle :: String -> Widget n -> Widget n+boxWithTitle heading inside = hBox [+ border $+ padAll 1 $+ (padBottom (Pad 1) (withAttr expectedAttr $ strWrap heading))+ <=>+ inside+ ]++reifyWidget :: Show a => a -> Reader CustomExceptionFormatters (Widget n)+reifyWidget x = case P.reify x of+ Just v -> toBrickWidget v+ _ -> return $ strWrap (show x)++instance ToBrickWidget P.Value where+ 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) = 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) = 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+ ]++abbreviateList :: [Value] -> Reader CustomExceptionFormatters [Widget n]+abbreviateList = abbreviateList' toBrickWidget++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 <$> (mapM renderLine $ getCallStack cs)+ where+ renderLine (f, srcLoc) = toBrickWidget srcLoc >>= \w -> return $ hBox [+ withAttr logFunctionAttr $ str f+ , str " called at "+ , w+ ]++instance ToBrickWidget SrcLoc where+ toBrickWidget (SrcLoc {..}) = return $ hBox [+ withAttr logFilenameAttr $ str srcLocFile+ , str ":"+ , withAttr logLineAttr $ str $ show srcLocStartLine+ , str ":"+ , withAttr logChAttr $ str $ show srcLocStartCol+ , str " in "+ , withAttr logPackageAttr $ str srcLocPackage+ , str ":"+ , str srcLocModule+ ]++-- * Util++takeEnd :: Int -> [a] -> [a]+takeEnd j xs = f xs (drop j xs)+ where f (_:zs) (_:ys) = f zs ys+ f zs _ = zs
+ src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE MultiWayIf #-}+-- |++module Test.Sandwich.Formatters.TerminalUI.Draw.TopBox (+ topBox+ ) where++import Brick+import qualified Brick.Widgets.List as L+import Control.Monad.Logger+import qualified Data.List as L+import Data.Maybe+import Lens.Micro+import Test.Sandwich.Formatters.TerminalUI.AttrMap+import Test.Sandwich.Formatters.TerminalUI.Keys+import Test.Sandwich.Formatters.TerminalUI.Types+import Test.Sandwich.RunTree+import Test.Sandwich.Types.RunTree+import Test.Sandwich.Types.Spec+++topBox app = hBox [columnPadding settingsColumn+ , columnPadding actionsColumn+ , columnPadding otherActionsColumn]+ where+ settingsColumn = keybindingBox [keyIndicator (L.intersperse '/' [unKChar nextKey, unKChar previousKey, '↑', '↓']) "Navigate"+ , keyIndicatorHasSelected app (showKeys toggleKeys) "Open/close node"+ , keyIndicatorHasSelectedOpen app "Control-v/Meta-v" "Scroll node"+ , keyIndicatorHasSelected app (unKChar closeNodeKey : '/' : [unKChar openNodeKey]) "Fold/unfold node"+ , keyIndicator "Meta + [0-9]" "Unfold top # nodes"+ , keyIndicator (unKChar nextFailureKey : '/' : [unKChar previousFailureKey]) "Next/previous failure"+ ]++ actionsColumn = keybindingBox [hBox [str "["+ , highlightKeyIfPredicate selectedTestRunning app (str $ showKey cancelSelectedKey)+ , str "/"+ , highlightKeyIfPredicate someTestRunning app (str $ showKey cancelAllKey)+ , str "] "+ , withAttr hotkeyMessageAttr $ str "Cancel "+ , highlightMessageIfPredicate selectedTestRunning app (str "selected")+ , str "/"+ , highlightMessageIfPredicate someTestRunning app (str "all")+ ]+ , hBox [str "["+ , highlightKeyIfPredicate selectedTestDone app (str $ showKey runSelectedKey)+ , str "/"+ , highlightKeyIfPredicate noTestsRunning app (str $ showKey runAllKey)+ , str "] "+ , withAttr hotkeyMessageAttr $ str "Run "+ , highlightMessageIfPredicate selectedTestDone app (str "selected")+ , str "/"+ , highlightMessageIfPredicate noTestsRunning app (str "all")+ ]+ , hBox [str "["+ , highlightKeyIfPredicate selectedTestDone app (str $ showKey clearSelectedKey)+ , str "/"+ , highlightKeyIfPredicate allTestsDone app (str $ showKey clearAllKey)+ , str "] "+ , withAttr hotkeyMessageAttr $ str "Clear "+ , highlightMessageIfPredicate selectedTestDone app (str "selected")+ , str "/"+ , highlightMessageIfPredicate allTestsDone app (str "all")+ ]+ , hBox [str "["+ , highlightKeyIfPredicate someTestSelected app (str $ showKey openSelectedFolderInFileExplorer)+ , str "/"+ , highlightKeyIfPredicate (const True) app (str $ showKey openTestRootKey)+ , str "] "+ , withAttr hotkeyMessageAttr $ str "Open "+ , highlightMessageIfPredicate someTestSelected app (str "selected")+ , str "/"+ , highlightMessageIfPredicate (const True) app (str "root")+ , withAttr hotkeyMessageAttr $ str " folder"+ ]+ , hBox [str "["+ , highlightKeyIfPredicate someTestSelected app (str $ showKey openTestInEditorKey)+ , str "/"+ , highlightKeyIfPredicate someTestSelected app (str $ showKey openLogsInEditorKey)+ , str "/"+ , highlightKeyIfPredicate someTestSelected app (str $ showKey openFailureInEditorKey)+ , str "] "+ , withAttr hotkeyMessageAttr $ str "Edit "+ , highlightMessageIfPredicate someTestSelected app (str "test")+ , str "/"+ , highlightMessageIfPredicate someTestSelected app (str "logs")+ , str "/"+ , highlightMessageIfPredicate selectedTestHasCallStack app (str "failure")+ ]+ ]++ otherActionsColumn = keybindingBox [keyIndicator' (showKey cycleVisibilityThresholdKey) (visibilityThresholdWidget app)+ , hBox [str "["+ , str $ showKey toggleShowRunTimesKey+ , str "/"+ , str $ showKey toggleFileLocationsKey+ , str "/"+ , str $ showKey toggleVisibilityThresholdsKey+ , str "] "+ , highlightMessageIfPredicate (^. appShowRunTimes) app (str "Times")+ , str "/"+ , highlightMessageIfPredicate (^. appShowFileLocations) app (str "locations")+ , str "/"+ , highlightMessageIfPredicate (^. appShowVisibilityThresholds) app (str "thresholds")+ ]+ , hBox [str "["+ , highlightIfLogLevel app LevelDebug [unKChar debugKey]+ , str "/"+ , highlightIfLogLevel app LevelInfo [unKChar infoKey]+ , str "/"+ , highlightIfLogLevel app LevelWarn [unKChar warnKey]+ , str "/"+ , highlightIfLogLevel app LevelError [unKChar errorKey]+ , str "] "+ , str "Log level"]++ , keyIndicator "q" "Exit"]++visibilityThresholdWidget app = hBox $+ [withAttr hotkeyMessageAttr $ str "Visibility threshold ("]+ <> L.intersperse (str ", ") [withAttr (if x == app ^. appVisibilityThreshold then visibilityThresholdSelectedAttr else visibilityThresholdNotSelectedAttr) $ str $ show x | x <- (app ^. appVisibilityThresholdSteps)]+ <> [(str ")")]++columnPadding = padLeft (Pad 1) . padRight (Pad 3) -- . padTop (Pad 1)++keybindingBox = vBox++highlightIfLogLevel app desiredLevel thing =+ if | app ^. appLogLevel == Just desiredLevel -> withAttr visibilityThresholdSelectedAttr $ str thing+ | otherwise -> withAttr hotkeyAttr $ str thing++highlightKeyIfPredicate p app x = case p app of+ True -> withAttr hotkeyAttr x+ False -> withAttr disabledHotkeyAttr x++highlightMessageIfPredicate p app x = case p app of+ True -> withAttr hotkeyMessageAttr x+ False -> withAttr disabledHotkeyMessageAttr x++keyIndicator key msg = keyIndicator' key (withAttr hotkeyMessageAttr $ str msg)++keyIndicator' key label = hBox [str "[", withAttr hotkeyAttr $ str key, str "] ", label]++keyIndicatorHasSelected app = keyIndicatorContextual app someTestSelected++keyIndicatorHasSelectedOpen app = keyIndicatorContextual app selectedTestToggled++keyIndicatorContextual app p key msg = case p app of+ True -> hBox [str "[", withAttr hotkeyAttr $ str key, str "] ", withAttr hotkeyMessageAttr $ str msg]+ False -> hBox [str "[", withAttr disabledHotkeyAttr $ str key, str "] ", withAttr disabledHotkeyMessageAttr $ str msg]+++-- * Predicates++selectedTestRunning s = case L.listSelectedElement (s ^. appMainList) of+ Nothing -> False+ Just (_, MainListElem {..}) -> isRunning status++selectedTestDone s = case L.listSelectedElement (s ^. appMainList) of+ Nothing -> False+ Just (_, MainListElem {..}) -> isDone status++selectedTestHasCallStack s = case L.listSelectedElement (s ^. appMainList) of+ Nothing -> False+ Just (_, MainListElem {..}) -> case status of+ (Done _ _ _ _ (Failure failureReason)) -> isJust $ failureCallStack failureReason+ _ -> False++selectedTestToggled s = case L.listSelectedElement (s ^. appMainList) of+ Nothing -> False+ Just (_, MainListElem {..}) -> toggled++noTestsRunning s = all (not . isRunning . runTreeStatus . runNodeCommon) (s ^. appRunTree)++someTestRunning s = any (isRunning . runTreeStatus . runNodeCommon) (s ^. appRunTree)++allTestsDone s = all (isDone . runTreeStatus . runNodeCommon) (s ^. appRunTree)++someTestSelected s = isJust $ L.listSelectedElement (s ^. appMainList)
+ src/Test/Sandwich/Formatters/TerminalUI/Draw/Util.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE CPP #-}++module Test.Sandwich.Formatters.TerminalUI.Draw.Util where++import Brick+import Graphics.Vty.Image+import Lens.Micro+++fixedHeightOrViewportPercent :: (Ord n, Show n) => n -> Int -> Widget n -> Widget n+fixedHeightOrViewportPercent vpName maxHeightPercent w =+ Widget Fixed Fixed $ do+ -- Render the viewport contents in advance+ result <- render w+ -- If the contents will fit in the maximum allowed rows,+ -- just return the content without putting it in a viewport.++ ctx <- getContext++#if MIN_VERSION_brick(0,56,0)+ let usableHeight = ctx ^. windowHeightL+#else+ let usableHeight = min 80 (ctx ^. availHeightL) -- Bound this so it looks okay inside a viewport+#endif++ let maxHeight = round (toRational usableHeight * (toRational maxHeightPercent / 100))++ if imageHeight (image result) <= maxHeight+ then return result+ -- Otherwise put the contents (pre-rendered) in a viewport+ -- and limit the height to the maximum allowable height.+ else render (vLimit maxHeight $+ viewport vpName Vertical $+ Widget Fixed Fixed $ return result)
+ src/Test/Sandwich/Formatters/TerminalUI/Filter.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE MultiWayIf #-}+-- |++module Test.Sandwich.Formatters.TerminalUI.Filter (+ filterRunTree+ , treeToList+ ) where++import Control.Monad+import Control.Monad.Trans.Reader+import Data.Function+import qualified Data.List as L+import Test.Sandwich.Formatters.TerminalUI.Types+import Test.Sandwich.RunTree+import Test.Sandwich.Types.RunTree++filterRunTree :: Int -> [RunNodeFixed context] -> [RunNodeFixed context]+filterRunTree visibilityThreshold rtsFixed = rtsFixed+ & fmap (mapCommon (hideIfThresholdAbove visibilityThreshold))+ & fmap hideClosed++mapCommon :: (RunNodeCommonWithStatus s l t -> RunNodeCommonWithStatus s l t) -> RunNodeWithStatus context s l t -> RunNodeWithStatus context s l t+mapCommon f node@(RunNodeIt {}) = node { runNodeCommon = f (runNodeCommon node) }+mapCommon f (RunNodeIntroduce {..}) = RunNodeIntroduce { runNodeCommon = f runNodeCommon+ , runNodeChildrenAugmented = fmap (mapCommon f) runNodeChildrenAugmented+ , .. }+mapCommon f (RunNodeIntroduceWith {..}) = RunNodeIntroduceWith { runNodeCommon = f runNodeCommon+ , runNodeChildrenAugmented = fmap (mapCommon f) runNodeChildrenAugmented+ , .. }+mapCommon f node = node { runNodeCommon = f (runNodeCommon node)+ , runNodeChildren = fmap (mapCommon f) (runNodeChildren node) }+++hideIfThresholdAbove :: Int -> RunNodeCommonFixed -> RunNodeCommonFixed+hideIfThresholdAbove visibilityThreshold node@(RunNodeCommonWithStatus {..}) =+ if | runTreeVisibilityLevel <= visibilityThreshold -> node { runTreeVisible = True }+ | otherwise -> node { runTreeVisible = False+ , runTreeOpen = True -- Must be open so children have a chance to be seen+ }++markClosed :: RunNodeCommonWithStatus s l Bool -> RunNodeCommonWithStatus s l Bool+markClosed node@(RunNodeCommonWithStatus {..}) = node { runTreeVisible = False }++hideClosed :: RunNodeWithStatus context s l Bool -> RunNodeWithStatus context s l Bool+hideClosed node@(RunNodeIt {}) = node+hideClosed (RunNodeIntroduce {..})+ | runTreeOpen runNodeCommon = RunNodeIntroduce { runNodeChildrenAugmented = fmap hideClosed runNodeChildrenAugmented, .. }+ | otherwise = RunNodeIntroduce { runNodeChildrenAugmented = fmap (mapCommon markClosed) runNodeChildrenAugmented, .. }+hideClosed (RunNodeIntroduceWith {..})+ | runTreeOpen runNodeCommon = RunNodeIntroduceWith { runNodeChildrenAugmented = fmap hideClosed runNodeChildrenAugmented, .. }+ | otherwise = RunNodeIntroduceWith { runNodeChildrenAugmented = fmap (mapCommon markClosed) runNodeChildrenAugmented, .. }+hideClosed node+ | runTreeOpen (runNodeCommon node) = node { runNodeChildren = fmap hideClosed (runNodeChildren node) }+ | otherwise = node { runNodeChildren = fmap (mapCommon markClosed) (runNodeChildren node) }+++treeToList :: (RunNodeFixed context, RunNode context) -> [MainListElem]+treeToList (nodeFixed, node) = L.zip (runReader (getCommonsWithVisibleDepth' nodeFixed) 0) (getCommons node)+ & L.filter (isVisible . fst . fst)+ & fmap commonToMainListElem+ where++ isVisible :: RunNodeCommonFixed -> Bool+ isVisible (RunNodeCommonWithStatus {..}) = runTreeVisible++ commonToMainListElem :: ((RunNodeCommonFixed, Int), RunNodeCommon) -> MainListElem+ commonToMainListElem ((RunNodeCommonWithStatus {..}, depth), common) = MainListElem {+ label = runTreeLabel+ , depth = depth+ , toggled = runTreeToggled+ , open = runTreeOpen+ , status = runTreeStatus+ , logs = runTreeLogs+ , visibilityLevel = runTreeVisibilityLevel+ , folderPath = runTreeFolder+ , node = common+ , ident = runTreeId+ }++getCommonsWithVisibleDepth' :: RunNodeWithStatus context s l t -> Reader Int [(RunNodeCommonWithStatus s l t, Int)]+getCommonsWithVisibleDepth' node@(RunNodeIt {}) = ask >>= \vd -> return [(runNodeCommon node, vd)]+getCommonsWithVisibleDepth' (RunNodeIntroduce {..}) = do+ let context = if runTreeVisible runNodeCommon then (local (+1)) else id+ rest <- context $ (mconcat <$>) $ forM runNodeChildrenAugmented getCommonsWithVisibleDepth'+ ask >>= \vd -> return ((runNodeCommon, vd) : rest)+getCommonsWithVisibleDepth' (RunNodeIntroduceWith {..}) = do+ let context = if runTreeVisible runNodeCommon then (local (+1)) else id+ rest <- context $ (mconcat <$>) $ forM runNodeChildrenAugmented getCommonsWithVisibleDepth'+ ask >>= \vd -> return ((runNodeCommon, vd) : rest)+getCommonsWithVisibleDepth' node = do+ let context = if runTreeVisible (runNodeCommon node) then (local (+1)) else id+ rest <- context $ (mconcat <$>) $ forM (runNodeChildren node) getCommonsWithVisibleDepth'+ ask >>= \vd -> return ((runNodeCommon node, vd) : rest)
+ src/Test/Sandwich/Formatters/TerminalUI/Keys.hs view
@@ -0,0 +1,55 @@++module Test.Sandwich.Formatters.TerminalUI.Keys where++import qualified Data.List as L+import qualified Graphics.Vty as V++-- Column 1+nextKey = V.KChar 'n'+previousKey = V.KChar 'p'+nextFailureKey = V.KChar 'N'+previousFailureKey = V.KChar 'P'+closeNodeKey = V.KLeft+openNodeKey = V.KRight+toggleKeys = [V.KEnter, V.KChar '\t']++-- Column 2+cancelAllKey = V.KChar 'C'+cancelSelectedKey = V.KChar 'c'+runAllKey = V.KChar 'R'+runSelectedKey = V.KChar 'r'+clearAllKey = V.KChar 'K'+clearSelectedKey = V.KChar 'k'+openSelectedFolderInFileExplorer = V.KChar 'o'+openTestRootKey = V.KChar 'O'+openTestInEditorKey = V.KChar 't'+openFailureInEditorKey = V.KChar 'f'+openLogsInEditorKey = V.KChar 'l'++-- Column 3+cycleVisibilityThresholdKey = V.KChar 'v'+toggleShowRunTimesKey = V.KChar 'T'+toggleFileLocationsKey = V.KChar 'F'+toggleVisibilityThresholdsKey = V.KChar 'V'+debugKey = V.KChar 'd'+infoKey = V.KChar 'i'+warnKey = V.KChar 'w'+errorKey = V.KChar 'e'+exitKey = V.KChar 'q'++++-- Other++showKey (V.KChar '\t') = "Tab"+showKey (V.KChar c) = [c]+showKey V.KEnter = "Enter"+showKey _ = "?"++showKeys = L.intercalate "/" . fmap showKey++unKChar :: V.Key -> Char+unKChar (V.KChar c) = c+unKChar V.KLeft = '←'+unKChar V.KRight = '→'+unKChar _ = '?'
+ src/Test/Sandwich/Formatters/TerminalUI/OpenInEditor.hs view
@@ -0,0 +1,44 @@++module Test.Sandwich.Formatters.TerminalUI.OpenInEditor where++import Control.Applicative+import Data.Function+import qualified Data.Text as T+import GHC.Stack+import System.Environment+import System.Exit+import System.Process+++autoOpenInEditor :: Maybe String -> (T.Text -> IO ()) -> SrcLoc -> IO ()+autoOpenInEditor terminalUIDefaultEditor debugFn (SrcLoc {..}) = do+ maybeEditor' <- lookupEnv "EDITOR"+ let maybeEditor = maybeEditor' <|> terminalUIDefaultEditor++ case maybeEditor of+ Nothing -> return ()+ Just editorString -> do+ let editor = editorString+ & T.pack+ & T.replace "LINE" (T.pack $ show srcLocStartLine)+ & T.replace "COLUMN" (T.pack $ show srcLocStartCol)+ & fillInFile+ & T.unpack++ debugFn ("Opening editor with command: " <> T.pack editor)++ (_, _, _, p) <- createProcess ((shell editor) { delegate_ctlc = True })+ waitForProcess p >>= \case+ ExitSuccess -> return ()+ ExitFailure n -> debugFn ("Editor failed with exit code " <> T.pack (show n))++ where+ fillInFile cmd+ | "FILE" `T.isInfixOf` cmd = T.replace "FILE" (T.pack $ show srcLocFile) cmd+ | otherwise = cmd <> " '" <> T.pack srcLocFile <> "'"++-- elisp = [i|(progn+-- (x-focus-frame (selected-frame))+-- (raise-frame)+-- (recenter)+-- )|]
+ src/Test/Sandwich/Formatters/TerminalUI/Types.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE ExistentialQuantification #-}++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+import Data.Time+import GHC.Stack+import Lens.Micro.TH+import Test.Sandwich.Formatters.TerminalUI.OpenInEditor+import Test.Sandwich.RunTree+import Test.Sandwich.Types.RunTree+++data TerminalUIFormatter = TerminalUIFormatter {+ terminalUIVisibilityThreshold :: Int+ -- ^ The initial visibility threshold to use when the formatter starts.+ , terminalUIInitialFolding :: InitialFolding+ -- ^ The initial folding settings to use when the formatter starts.+ , terminalUIShowRunTimes :: Bool+ -- ^ Whether to show or hide run times.+ , terminalUIShowFileLocations :: Bool+ -- ^ Whether to show or hide the files in which tests are defined.+ , terminalUIShowVisibilityThresholds :: Bool+ -- ^ Whether to show or hide visibility thresholds next to nodes.+ , terminalUILogLevel :: Maybe LogLevel+ -- ^ Log level for test log displays.+ , terminalUIRefreshPeriod :: Int+ -- ^ Time in microseconds between test tree renders. Defaults to 100ms. Can be increased if CPU usage of the UI is too high.+ , terminalUIClockUpdatePeriod :: Maybe Int+ -- ^ Time in microseconds between clock ticks. This causes the app's current time to be updated, which powers the+ -- run time displays and the overall app uptime displayed at the top. Defaults to Just 1s. If Nothing, the clock timer is disabled.+ -- Can be increased if CPU usage of the UI is too high.+ , terminalUIDefaultEditor :: Maybe String+ -- ^ Default value to use for the EDITOR environment variable when one is not provided.+ -- If 'Nothing' and EDITOR can't be found, edit commands will do nothing.+ --+ -- Here are some recommended values, depending on your preferred editor:+ --+ -- * Emacs: @export EDITOR="emacsclient --eval '(progn (find-file FILE) (goto-line LINE) (forward-char (- COLUMN 1)) (recenter))'"@+ -- * Terminal Emacs: @export EDITOR="emacsclient -nw --eval '(progn (find-file FILE) (goto-line LINE) (forward-char (- COLUMN 1)) (recenter))'"@+ -- * Vim: @export EDITOR="vim +LINE"@+ , terminalUIOpenInEditor :: Maybe String -> (T.Text -> IO ()) -> SrcLoc -> IO ()+ -- ^ Callback to open a source location in your editor. By default, finds the command in the EDITOR environment variable+ -- 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+ show (TerminalUIFormatter {}) = "<TerminalUIFormatter>"++data InitialFolding =+ InitialFoldingAllOpen+ | InitialFoldingAllClosed+ | InitialFoldingTopNOpen Int+ deriving (Show, Eq)++-- | Default settings for the terminal UI formatter.+defaultTerminalUIFormatter :: TerminalUIFormatter+defaultTerminalUIFormatter = TerminalUIFormatter {+ terminalUIVisibilityThreshold = 50+ , terminalUIInitialFolding = InitialFoldingAllOpen+ , terminalUIShowRunTimes = True+ , terminalUIShowFileLocations = False+ , terminalUIShowVisibilityThresholds = False+ , terminalUILogLevel = Just LevelWarn+ , terminalUIRefreshPeriod = 100000+ , terminalUIClockUpdatePeriod = Just 1000000+ , terminalUIDefaultEditor = Just "emacsclient +$((LINE+1)):COLUMN --no-wait"+ , terminalUIOpenInEditor = autoOpenInEditor+ , terminalUICustomExceptionFormatters = []+ }++type CustomExceptionFormatters = [SomeException -> Maybe CustomTUIException]++data CustomTUIException = CustomTUIExceptionMessageAndCallStack T.Text (Maybe CallStack)+ | CustomTUIExceptionBrick (forall n. B.Widget n)++data AppEvent =+ RunTreeUpdated [RunNodeFixed BaseContext]+ | CurrentTimeUpdated UTCTime++instance Show AppEvent where+ show (RunTreeUpdated {}) = "<RunTreeUpdated>"+ show (CurrentTimeUpdated {}) = "<CurrentTimeUpdated>"++data MainListElem = MainListElem {+ label :: String+ , depth :: Int+ , toggled :: Bool+ , open :: Bool+ , status :: Status+ , logs :: Seq LogEntry+ , visibilityLevel :: Int+ , folderPath :: Maybe FilePath+ , node :: RunNodeCommon+ , ident :: Int+ }++data SomeRunNode = forall context s l t. SomeRunNode { unSomeRunNode :: RunNodeWithStatus context s l t }++data ClickableName = ColorBar | ListRow Int | MainList | InnerViewport T.Text+ deriving (Show, Ord, Eq)++data AppState = AppState {+ _appRunTreeBase :: [RunNode BaseContext]+ , _appRunTree :: [RunNodeFixed BaseContext]+ , _appMainList :: L.List ClickableName MainListElem+ , _appBaseContext :: BaseContext++ , _appStartTime :: UTCTime+ , _appCurrentTime :: UTCTime++ , _appVisibilityThresholdSteps :: [Int]+ , _appVisibilityThreshold :: Int++ , _appLogLevel :: Maybe LogLevel+ , _appShowRunTimes :: Bool+ , _appShowFileLocations :: Bool+ , _appShowVisibilityThresholds :: Bool++ , _appOpenInEditor :: SrcLoc -> IO ()+ , _appDebug :: T.Text -> IO ()+ , _appCustomExceptionFormatters :: CustomExceptionFormatters+ }++makeLenses ''AppState+++extractValues' :: (forall context s l t. RunNodeWithStatus context s l t -> a) -> SomeRunNode -> [a]+extractValues' f (SomeRunNode n@(RunNodeIt {})) = [f n]+extractValues' f (SomeRunNode n@(RunNodeIntroduce {runNodeChildrenAugmented})) = (f n) : (concatMap (extractValues f) runNodeChildrenAugmented)+extractValues' f (SomeRunNode n@(RunNodeIntroduceWith {runNodeChildrenAugmented})) = (f n) : (concatMap (extractValues f) runNodeChildrenAugmented)+extractValues' f (SomeRunNode n) = (f n) : (concatMap (extractValues f) (runNodeChildren n))
src/Test/Sandwich/Interpreters/StartTree.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE TupleSections #-} module Test.Sandwich.Interpreters.StartTree ( startTree@@ -50,44 +52,48 @@ let RunNodeCommonWithStatus {..} = runNodeCommon let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon runInAsync node ctx $ do- (runExampleM runNodeBefore ctx runTreeLogs (Just [i|Exception in before '#{runTreeLabel}' handler|])) >>= \case- result@(Failure fr@(Pending {..})) -> do+ (timed (runExampleM runNodeBefore ctx runTreeLogs (Just [i|Exception in before '#{runTreeLabel}' handler|]))) >>= \case+ (result@(Failure fr@(Pending {..})), setupTime) -> do markAllChildrenWithResult runNodeChildren ctx (Failure fr)- return result- result@(Failure fr) -> do+ return (result, mkSetupTimingInfo setupTime)+ (result@(Failure fr), setupTime) -> do markAllChildrenWithResult runNodeChildren ctx (Failure $ GetContextException Nothing (SomeExceptionWithEq $ toException fr))- return result- Success -> do+ return (result, mkSetupTimingInfo setupTime)+ (Success, setupTime) -> do void $ runNodesSequentially runNodeChildren ctx- return Success- Cancelled -> do- return Cancelled- DryRun -> do+ return (Success, mkSetupTimingInfo setupTime)+ (Cancelled, setupTime) -> do+ return (Cancelled, mkSetupTimingInfo setupTime)+ (DryRun, setupTime) -> do void $ runNodesSequentially runNodeChildren ctx- return DryRun+ return (DryRun, mkSetupTimingInfo setupTime) startTree node@(RunNodeAfter {..}) ctx' = do let RunNodeCommonWithStatus {..} = runNodeCommon let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon runInAsync node ctx $ do- result <- liftIO $ newIORef Success+ result <- liftIO $ newIORef (Success, emptyExtraTimingInfo) finally (void $ runNodesSequentially runNodeChildren ctx)- ((runExampleM runNodeAfter ctx runTreeLogs (Just [i|Exception in after '#{runTreeLabel}' handler|])) >>= writeIORef result)+ (do+ (ret, dt) <- timed (runExampleM runNodeAfter ctx runTreeLogs (Just [i|Exception in after '#{runTreeLabel}' handler|]))+ writeIORef result (ret, mkTeardownTimingInfo dt)+ ) liftIO $ readIORef result startTree node@(RunNodeIntroduce {..}) ctx' = do let RunNodeCommonWithStatus {..} = runNodeCommon let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon runInAsync node ctx $ do- result <- liftIO $ newIORef Success+ result <- liftIO $ newIORef (Success, emptyExtraTimingInfo) bracket (do let asyncExceptionResult e = Failure $ GotAsyncException Nothing (Just [i|introduceWith #{runTreeLabel} alloc handler got async exception|]) (SomeAsyncExceptionWithEq e) flip withException (\(e :: SomeAsyncException) -> markAllChildrenWithResult runNodeChildrenAugmented ctx (asyncExceptionResult e)) $- runExampleM' runNodeAlloc ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' allocation handler|]))- (\case- Left failureReason -> writeIORef result (Failure failureReason)- Right intro ->- (runExampleM (runNodeCleanup intro) ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' cleanup handler|])) >>= writeIORef result+ timed (runExampleM' runNodeAlloc ctx runTreeLogs (Just [i|Failure in introduce '#{runTreeLabel}' allocation handler|])))+ (\(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)) )- (\case+ (\(ret, _setupTime) -> case ret of Left failureReason@(Pending {}) -> do -- TODO: add note about failure in allocation markAllChildrenWithResult runNodeChildrenAugmented ctx (Failure failureReason)@@ -107,61 +113,86 @@ startTree node@(RunNodeIntroduceWith {..}) ctx' = do let RunNodeCommonWithStatus {..} = runNodeCommon let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon- didRunWrappedAction <- liftIO $ newIORef (Left ())+ didRunWrappedAction <- liftIO $ newIORef (Left (), emptyExtraTimingInfo) runInAsync node ctx $ do let wrappedAction = do let failureResult e = case fromException e of Just fr@(Pending {}) -> Failure fr _ -> Failure $ Reason Nothing [i|introduceWith '#{runTreeLabel}' handler threw exception|] flip withException (\e -> recordExceptionInStatus runTreeStatus e >> markAllChildrenWithResult runNodeChildrenAugmented ctx (failureResult e)) $ do- runNodeIntroduceAction $ \intro -> do+ beginningCleanupVar <- liftIO $ newIORef Nothing+ startTime <- liftIO getCurrentTime+ results <- runNodeIntroduceAction $ \intro -> do+ afterMakingIntroTime <- liftIO getCurrentTime+ let setupTime = diffUTCTime afterMakingIntroTime startTime+ results <- liftIO $ runNodesSequentially runNodeChildrenAugmented ((LabelValue intro) :> ctx)- liftIO $ writeIORef didRunWrappedAction (Right results)++ beginningCleanupTs <- liftIO getCurrentTime+ liftIO $ writeIORef beginningCleanupVar (Just beginningCleanupTs)++ liftIO $ writeIORef didRunWrappedAction (Right results, mkSetupTimingInfo setupTime) return results - (liftIO $ readIORef didRunWrappedAction) >>= \case- Left () -> return $ Failure $ Reason Nothing [i|introduceWith '#{runTreeLabel}' handler didn't call action|]- Right _ -> return Success- runExampleM'' wrappedAction ctx runTreeLogs (Just [i|Exception in introduceWith '#{runTreeLabel}' handler|])+ endTime <- liftIO getCurrentTime+ liftIO (readIORef beginningCleanupVar) >>= \case+ Nothing -> return ()+ Just beginningCleanupTs ->+ liftIO $ modifyIORef' didRunWrappedAction $+ \(ret, timingInfo) -> (ret, timingInfo { teardownTime = Just (diffUTCTime endTime beginningCleanupTs) })++ return results++ liftIO (readIORef didRunWrappedAction) >>= \case+ (Left (), timingInfo) -> return (Failure $ Reason Nothing [i|introduceWith '#{runTreeLabel}' handler didn't call action|], timingInfo)+ (Right _, timingInfo) -> return (Success, timingInfo)+ runExampleM' wrappedAction ctx runTreeLogs (Just [i|Exception in introduceWith '#{runTreeLabel}' handler|]) >>= \case+ Left err -> return (Failure err, emptyExtraTimingInfo)+ Right x -> pure x startTree node@(RunNodeAround {..}) ctx' = do let RunNodeCommonWithStatus {..} = runNodeCommon let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon- didRunWrappedAction <- liftIO $ newIORef (Left ())+ didRunWrappedAction <- liftIO $ newIORef (Left (), emptyExtraTimingInfo) runInAsync node ctx $ do let wrappedAction = do let failureResult e = case fromException e of Just fr@(Pending {}) -> Failure fr _ -> Failure $ Reason Nothing [i|around '#{runTreeLabel}' handler threw exception|] flip withException (\e -> recordExceptionInStatus runTreeStatus e >> markAllChildrenWithResult runNodeChildren ctx (failureResult e)) $ do+ startTime <- liftIO getCurrentTime runNodeActionWith $ do+ setupEndTime <- liftIO getCurrentTime+ let setupTime = diffUTCTime setupEndTime startTime results <- liftIO $ runNodesSequentially runNodeChildren ctx- liftIO $ writeIORef didRunWrappedAction (Right results)+ liftIO $ writeIORef didRunWrappedAction (Right results, mkSetupTimingInfo setupTime) return results (liftIO $ readIORef didRunWrappedAction) >>= \case- Left () -> return $ Failure $ Reason Nothing [i|around '#{runTreeLabel}' handler didn't call action|]- Right _ -> return Success- runExampleM'' wrappedAction ctx runTreeLogs (Just [i|Exception in introduceWith '#{runTreeLabel}' handler|])+ (Left (), timingInfo) -> return (Failure $ Reason Nothing [i|around '#{runTreeLabel}' handler didn't call action|], timingInfo)+ (Right _, timingInfo) -> return (Success, timingInfo)+ runExampleM' wrappedAction ctx runTreeLogs (Just [i|Exception in introduceWith '#{runTreeLabel}' handler|]) >>= \case+ Left err -> return (Failure err, emptyExtraTimingInfo)+ Right x -> pure x startTree node@(RunNodeDescribe {..}) ctx' = do let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon runInAsync node ctx $ do ((L.length . L.filter isFailure) <$> runNodesSequentially runNodeChildren ctx) >>= \case- 0 -> return Success- n -> return $ Failure (ChildrenFailed Nothing n)+ 0 -> return (Success, emptyExtraTimingInfo)+ n -> return (Failure (ChildrenFailed Nothing n), emptyExtraTimingInfo) 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 (ChildrenFailed Nothing n)+ 0 -> return (Success, emptyExtraTimingInfo)+ n -> return (Failure (ChildrenFailed Nothing n), emptyExtraTimingInfo) startTree node@(RunNodeIt {..}) ctx' = do let ctx = modifyBaseContext ctx' $ baseContextFromCommon runNodeCommon runInAsync node ctx $ do- runExampleM runNodeExample ctx (runTreeLogs runNodeCommon) Nothing+ (, emptyExtraTimingInfo) <$> runExampleM runNodeExample ctx (runTreeLogs runNodeCommon) Nothing -- * Util -runInAsync :: (HasBaseContext context, MonadIO m) => RunNode context -> context -> IO Result -> m (Async Result)+runInAsync :: (HasBaseContext context, MonadIO m) => RunNode context -> context -> IO (Result, ExtraTimingInfo) -> m (Async Result) runInAsync node ctx action = do let RunNodeCommonWithStatus {..} = runNodeCommon node let bc@(BaseContext {..}) = getBaseContext ctx@@ -173,9 +204,9 @@ myAsync <- liftIO $ asyncWithUnmask $ \unmask -> do flip withException (recordExceptionInStatus runTreeStatus) $ unmask $ do readMVar mvar- result <- timerFn action+ (result, extraTimingInfo) <- timerFn action endTime <- liftIO getCurrentTime- liftIO $ atomically $ writeTVar runTreeStatus $ Done startTime endTime result+ liftIO $ atomically $ writeTVar runTreeStatus $ Done startTime endTime (setupTime extraTimingInfo) (teardownTime extraTimingInfo) result whenFailure result $ \reason -> do -- Make sure the folder exists, if configured@@ -204,7 +235,12 @@ exists <- doesPathExist symlinkPath when exists $ removePathForcibly symlinkPath +#ifndef mingw32_HOST_OS+ -- 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? liftIO $ createDirectoryLink relativePath symlinkPath+#endif -- Write failure info whenJust baseContextPath $ \dir -> do@@ -224,7 +260,7 @@ printLogs runTreeLogs return result- liftIO $ atomically $ writeTVar runTreeStatus $ Running startTime myAsync+ liftIO $ atomically $ writeTVar runTreeStatus $ Running startTime Nothing myAsync liftIO $ putMVar mvar () return myAsync -- TODO: fix race condition with writing to runTreeStatus (here and above) @@ -246,7 +282,7 @@ markAllChildrenWithResult children baseContext status = do now <- liftIO getCurrentTime forM_ (L.filter (shouldRunChild' baseContext) $ concatMap getCommons children) $ \child ->- liftIO $ atomically $ writeTVar (runTreeStatus child) (Done now now status)+ liftIO $ atomically $ writeTVar (runTreeStatus child) (Done now now Nothing Nothing status) cancelAllChildrenWith :: [RunNode context] -> SomeAsyncException -> IO () cancelAllChildrenWith children e = do@@ -256,7 +292,7 @@ NotStarted -> do now <- getCurrentTime let reason = GotAsyncException Nothing Nothing (SomeAsyncExceptionWithEq e)- atomically $ writeTVar (runTreeStatus $ runNodeCommon node) (Done now now (Failure reason))+ atomically $ writeTVar (runTreeStatus $ runNodeCommon node) (Done now now Nothing Nothing (Failure reason)) _ -> return () shouldRunChild :: (HasBaseContext ctx) => ctx -> RunNodeWithStatus context s l t -> Bool@@ -274,11 +310,6 @@ Left err -> return $ Failure err Right () -> return Success -runExampleM'' :: HasBaseContext r => ExampleM r Result -> r -> TVar (Seq LogEntry) -> Maybe String -> IO Result-runExampleM'' ex ctx logs exceptionMessage = runExampleM' ex ctx logs exceptionMessage >>= \case- Left err -> return $ Failure err- Right x -> return x- runExampleM' :: HasBaseContext r => ExampleM r a -> r -> TVar (Seq LogEntry) -> Maybe String -> IO (Either FailureReason a) runExampleM' ex ctx logs exceptionMessage = do maybeTestDirectory <- getTestDirectory ctx@@ -321,5 +352,12 @@ Just (e' :: FailureReason) -> Failure e' _ -> Failure (GotException Nothing Nothing (SomeExceptionWithEq e)) liftIO $ atomically $ modifyTVar status $ \case- Running {statusStartTime} -> Done statusStartTime endTime ret- _ -> Done endTime endTime ret+ 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 action = do+ startTime <- liftIO getCurrentTime+ ret <- action+ endTime <- liftIO getCurrentTime+ pure (ret, diffUTCTime endTime startTime)
src/Test/Sandwich/Options.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} module Test.Sandwich.Options ( Options@@ -6,6 +7,7 @@ -- * Artifacts , optionsTestArtifactsDirectory , TestArtifactsDirectory(..)+ , defaultTestArtifactsDirectory -- * Logging , optionsSavedLogLevel@@ -34,9 +36,15 @@ ) where import Control.Monad.Logger+import Data.Time.Clock import Test.Sandwich.Formatters.Print import Test.Sandwich.Types.RunTree +#ifdef mingw32_HOST_OS+import Data.Function ((&))+#endif++ -- | A reasonable default set of options. defaultOptions :: Options defaultOptions = Options {@@ -51,3 +59,18 @@ , optionsProjectRoot = Nothing , optionsTestTimerType = SpeedScopeTestTimerType { speedScopeTestTimerWriteRawTimings = False } }++defaultTestArtifactsDirectory :: TestArtifactsDirectory+defaultTestArtifactsDirectory = TestArtifactsGeneratedDirectory "test_runs" getFolderName+ where+#ifndef mingw32_HOST_OS+ getFolderName = show <$> getCurrentTime+#else+ getFolderName = do+ ts <- show <$> getCurrentTime+ return $ ts+ & replace ':' '_'++ replace :: Eq a => a -> a -> [a] -> [a]+ replace a b = map $ \c -> if c == a then b else c+#endif
src/Test/Sandwich/RunTree.hs view
@@ -118,7 +118,7 @@ isRunning _ = False isFailureStatus :: Status -> Bool-isFailureStatus (Done _ _ stat) = isFailure stat+isFailureStatus (Done _ _ _ _ stat) = isFailure stat isFailureStatus _ = False isFailure :: Result -> Bool
src/Test/Sandwich/Shutdown.hs view
@@ -13,5 +13,5 @@ Running {..} -> cancel statusAsync NotStarted -> do now <- getCurrentTime- atomically $ writeTVar (runTreeStatus $ runNodeCommon node) (Done now now Cancelled)+ atomically $ writeTVar (runTreeStatus $ runNodeCommon node) (Done now now Nothing Nothing Cancelled) Done {} -> return ()
src/Test/Sandwich/Types/ArgParsing.hs view
@@ -11,9 +11,7 @@ data FormatterType = Print-#ifndef mingw32_HOST_OS | TUI-#endif | PrintFailures | Auto | Silent@@ -21,17 +19,13 @@ instance Show FormatterType where show Print = "print" show PrintFailures = "print-failures"-#ifndef mingw32_HOST_OS show TUI = "tui"-#endif show Auto = "auto" show Silent = "silent" instance Read FormatterType where readsPrec _ "print" = [(Print, "")]-#ifndef mingw32_HOST_OS readsPrec _ "tui" = [(TUI, "")]-#endif readsPrec _ "auto" = [(Auto, "")] readsPrec _ "silent" = [(Silent, "")] readsPrec _ _ = []
src/Test/Sandwich/Types/RunTree.hs view
@@ -28,9 +28,12 @@ data Status = NotStarted | Running { statusStartTime :: UTCTime+ , statusSetupTime :: Maybe NominalDiffTime , statusAsync :: Async Result } | Done { statusStartTime :: UTCTime , statusEndTime :: UTCTime+ , statusSetupTime :: Maybe NominalDiffTime+ , statusTeardownTime :: Maybe NominalDiffTime , statusResult :: Result } deriving (Show, Eq)
src/Test/Sandwich/Types/Spec.hs view
@@ -30,13 +30,11 @@ import Data.Kind (Type) import Data.Maybe import Data.String.Interpolate+import Data.Time import GHC.Stack import GHC.TypeLits-import Safe--#ifndef mingw32_HOST_OS import Graphics.Vty.Image (Image)-#endif+import Safe #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail@@ -82,6 +80,14 @@ | Cancelled deriving (Show, Eq) +data ExtraTimingInfo = ExtraTimingInfo {+ setupTime :: Maybe NominalDiffTime+ , teardownTime :: Maybe NominalDiffTime+ }+emptyExtraTimingInfo = ExtraTimingInfo Nothing Nothing+mkSetupTimingInfo dt = ExtraTimingInfo (Just dt) Nothing+mkTeardownTimingInfo dt = ExtraTimingInfo Nothing (Just dt)+ data ShowEqBox = forall s. (Show s, Eq s) => SEB s instance Show ShowEqBox where show (SEB x) = show x instance Eq ShowEqBox where (SEB x1) == (SEB x2) = show x1 == show x2@@ -105,12 +111,9 @@ , failureAsyncException :: SomeAsyncExceptionWithEq } | ChildrenFailed { failureCallStack :: Maybe CallStack , failureNumChildren :: Int }-#ifndef mingw32_HOST_OS | RawImage { failureCallStack :: Maybe CallStack , failureFallback :: String , failureRawImage :: Image }-#endif- deriving (Show, Typeable, Eq) instance Exception FailureReason
test/TestUtil.hs view
@@ -76,7 +76,7 @@ statusToResult :: (HasCallStack) => (String, Status) -> Result statusToResult (label, NotStarted) = error [i|Expected status to be Done but was NotStarted for label '#{label}'|] statusToResult (label, Running {}) = error [i|Expected status to be Done but was Running for label '#{label}'|]-statusToResult (_, Done _ _ result) = result+statusToResult (_, Done _ _ _ _ result) = result mustBe :: (HasCallStack, Eq a, Show a) => a -> a -> IO () mustBe x y
− unix-src/Test/Sandwich/Formatters/TerminalUI.hs
@@ -1,444 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE CPP #-}--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- , terminalUILogLevel- , terminalUIInitialFolding- , terminalUIDefaultEditor- , terminalUIOpenInEditor- , terminalUICustomExceptionFormatters-- -- * Auxiliary types- , InitialFolding(..)- , CustomTUIException(..)-- -- * Util- , isTuiFormatterSupported- ) where--import Brick as B-import Brick.BChan-import Brick.Widgets.List-import Control.Concurrent-import Control.Concurrent.Async-import Control.Concurrent.STM-import Control.Exception.Safe-import Control.Monad-import Control.Monad.IO.Class-import Control.Monad.IO.Unlift-import Control.Monad.Logger hiding (logError)-import Data.Either-import Data.Foldable-import qualified Data.List as L-import Data.Maybe-import qualified Data.Sequence as Seq-import qualified Data.Set as S-import Data.String.Interpolate-import Data.Time-import qualified Data.Vector as Vec-import GHC.Stack-import qualified Graphics.Vty as V-import Lens.Micro-import Safe-import System.FilePath-import Test.Sandwich.Formatters.TerminalUI.AttrMap-import Test.Sandwich.Formatters.TerminalUI.CrossPlatform-import Test.Sandwich.Formatters.TerminalUI.Draw-import Test.Sandwich.Formatters.TerminalUI.Filter-import Test.Sandwich.Formatters.TerminalUI.Keys-import Test.Sandwich.Formatters.TerminalUI.Types-import Test.Sandwich.Interpreters.RunTree.Util-import Test.Sandwich.Interpreters.StartTree-import Test.Sandwich.Logging-import Test.Sandwich.RunTree-import Test.Sandwich.Shutdown-import Test.Sandwich.Types.ArgParsing-import Test.Sandwich.Types.RunTree-import Test.Sandwich.Types.Spec-import Test.Sandwich.Util---instance Formatter TerminalUIFormatter where- formatterName _ = "terminal-ui-formatter"- runFormatter = runApp- finalizeFormatter _ _ _ = return ()--isTuiFormatterSupported :: IO Bool-isTuiFormatterSupported = isRight <$> tryAny (V.mkVty V.defaultConfig)--runApp :: (MonadLoggerIO m, MonadUnliftIO m) => TerminalUIFormatter -> [RunNode BaseContext] -> Maybe (CommandLineOptions ()) -> BaseContext -> m ()-runApp (TerminalUIFormatter {..}) rts _maybeCommandLineOptions baseContext = do- startTime <- liftIO getCurrentTime-- liftIO $ setInitialFolding terminalUIInitialFolding rts-- rtsFixed <- liftIO $ atomically $ mapM fixRunTree rts-- let initialState = updateFilteredTree $- AppState {- _appRunTreeBase = rts- , _appRunTree = rtsFixed- , _appMainList = list MainList mempty 1- , _appBaseContext = baseContext-- , _appStartTime = startTime- , _appTimeSinceStart = 0-- , _appVisibilityThresholdSteps = L.sort $ L.nub $ terminalUIVisibilityThreshold : (fmap runTreeVisibilityLevel $ concatMap getCommons rts)- , _appVisibilityThreshold = terminalUIVisibilityThreshold-- , _appLogLevel = terminalUILogLevel- , _appShowRunTimes = terminalUIShowRunTimes- , _appShowFileLocations = terminalUIShowFileLocations- , _appShowVisibilityThresholds = terminalUIShowVisibilityThresholds-- , _appOpenInEditor = terminalUIOpenInEditor terminalUIDefaultEditor (const $ return ())- , _appDebug = (const $ return ())- , _appCustomExceptionFormatters = terminalUICustomExceptionFormatters- }-- eventChan <- liftIO $ newBChan 10-- logFn <- askLoggerIO-- currentFixedTree <- liftIO $ newTVarIO rtsFixed- eventAsync <- liftIO $ async $- forever $ do- handleAny (\e -> flip runLoggingT logFn (logError [i|Got exception in event async: #{e}|]) >> threadDelay terminalUIRefreshPeriod) $ do- newFixedTree <- atomically $ do- currentFixed <- readTVar currentFixedTree- newFixed <- mapM fixRunTree rts- when (fmap getCommons newFixed == fmap getCommons currentFixed) retry- writeTVar currentFixedTree newFixed- return newFixed- writeBChan eventChan (RunTreeUpdated newFixedTree)- threadDelay terminalUIRefreshPeriod-- let buildVty = do- v <- V.mkVty V.defaultConfig- let output = V.outputIface v- when (V.supportsMode output V.Mouse) $- liftIO $ V.setMode output V.Mouse True- return v- initialVty <- liftIO buildVty- liftIO $ flip onException (cancel eventAsync) $- void $ customMain initialVty buildVty (Just eventChan) app initialState--app :: App AppState AppEvent ClickableName-app = App {- appDraw = drawUI- , appChooseCursor = showFirstCursor-#if MIN_VERSION_brick(1,0,0)- , appHandleEvent = \event -> get >>= \s -> appEvent s event- , appStartEvent = return ()-#else- , appHandleEvent = appEvent- , appStartEvent = return-#endif- , appAttrMap = const mainAttrMap- }--#if MIN_VERSION_brick(1,0,0)-continue :: AppState -> EventM ClickableName AppState ()-continue = put--continueNoChange :: AppState -> EventM ClickableName AppState ()-continueNoChange _ = return ()--doHalt _ = halt-#else-continueNoChange :: AppState -> EventM ClickableName (Next AppState)-continueNoChange = continue--doHalt = halt-#endif--#if MIN_VERSION_brick(1,0,0)-appEvent :: AppState -> BrickEvent ClickableName AppEvent -> EventM ClickableName AppState ()-#else-appEvent :: AppState -> BrickEvent ClickableName AppEvent -> EventM ClickableName (Next AppState)-#endif-appEvent s (AppEvent (RunTreeUpdated newTree)) = do- now <- liftIO getCurrentTime- continue $ s- & appRunTree .~ newTree- & appTimeSinceStart .~ (diffUTCTime now (s ^. appStartTime))- & updateFilteredTree--appEvent s (MouseDown ColorBar _ _ (B.Location (x, _))) = do- lookupExtent ColorBar >>= \case- Nothing -> continue s- Just (Extent {extentSize=(w, _), extentUpperLeft=(B.Location (l, _))}) -> do- let percent :: Double = (fromIntegral (x - l)) / (fromIntegral w)- let allCommons = concatMap getCommons $ s ^. appRunTree- let index = max 0 $ min (length allCommons - 1) $ round $ percent * (fromIntegral $ (length allCommons - 1))- -- A subsequent RunTreeUpdated will pick up the new open nodes- liftIO $ openIndices (s ^. appRunTreeBase) (runTreeAncestors $ allCommons !! index)- continue $ s- & appMainList %~ (listMoveTo index)- & updateFilteredTree--appEvent s (MouseDown (ListRow _i) V.BScrollUp _ _) = do- vScrollBy (viewportScroll MainList) (-1)- continueNoChange s-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 (VtyEvent e) =- case e of- -- Column 1- V.EvKey c [] | c == nextKey -> continue (s & appMainList %~ (listMoveBy 1))- V.EvKey c [] | c == previousKey -> continue (s & appMainList %~ (listMoveBy (-1)))- 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- Nothing -> zip [0..] ls- case L.find (isFailureStatus . status . snd) listToSearch of- Nothing -> continue s- Just (i', _) -> continue (s & appMainList %~ (listMoveTo i'))- 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)- Nothing -> L.reverse (zip [0..] ls)- case L.find (isFailureStatus . status . snd) listToSearch of- Nothing -> continue s- Just (i', _) -> continue (s & appMainList %~ (listMoveTo i'))- V.EvKey c [] | c == closeNodeKey -> modifyOpen s (const False)- V.EvKey c [] | c == openNodeKey -> modifyOpen s (const True)- V.EvKey c@(V.KChar ch) [V.MMeta] | c `elem` (fmap V.KChar ['0'..'9']) -> do- let num :: Int = read [ch]- liftIO $ openToDepth (s ^. (appMainList . listElementsL)) num- continue s- V.EvKey c [] | c `elem` toggleKeys -> modifyToggled s not-- -- Scrolling in toggled items- -- Wanted to make these uniformly Ctrl+whatever, but Ctrl+PageUp/PageDown was causing it to get KEsc and exit (?)- V.EvKey V.KUp [V.MCtrl] -> withScroll s $ \vp -> vScrollBy vp (-1)- V.EvKey (V.KChar 'p') [V.MCtrl] -> withScroll s $ \vp -> vScrollBy vp (-1)- V.EvKey V.KDown [V.MCtrl] -> withScroll s $ \vp -> vScrollBy vp 1- V.EvKey (V.KChar 'n') [V.MCtrl] -> withScroll s $ \vp -> vScrollBy vp 1- V.EvKey (V.KChar 'v') [V.MMeta] -> withScroll s $ \vp -> vScrollPage vp Up- V.EvKey (V.KChar 'v') [V.MCtrl] -> withScroll s $ \vp -> vScrollPage vp Down- V.EvKey V.KHome [V.MCtrl] -> withScroll s $ \vp -> vScrollToBeginning vp- V.EvKey V.KEnd [V.MCtrl] -> withScroll s $ \vp -> vScrollToEnd vp-- -- Column 2- V.EvKey c [] | c == cancelAllKey -> do- liftIO $ mapM_ cancelNode (s ^. appRunTreeBase)- continue s- V.EvKey c [] | c == cancelSelectedKey -> withContinueS s $ do- whenJust (listSelectedElement (s ^. appMainList)) $ \(_, MainListElem {..}) -> liftIO $- (readTVarIO $ runTreeStatus node) >>= \case- Running {..} -> cancel statusAsync- _ -> return ()- V.EvKey c [] | c == runAllKey -> withContinueS s $ do- when (all (not . isRunning . runTreeStatus . runNodeCommon) (s ^. appRunTree)) $ liftIO $ do- mapM_ clearRecursively (s ^. appRunTreeBase)- void $ async $ void $ runNodesSequentially (s ^. appRunTreeBase) (s ^. appBaseContext)- V.EvKey c [] | c == runSelectedKey -> withContinueS s $- whenJust (listSelectedElement (s ^. appMainList)) $ \(_, MainListElem {..}) -> case status of- Running {} -> return ()- _ -> do- -- Get the set of IDs for only this node's ancestors and children- let ancestorIds = S.fromList $ toList $ runTreeAncestors node- case findRunNodeChildrenById ident (s ^. appRunTree) of- Nothing -> return ()- Just childIds -> do- let allIds = ancestorIds <> childIds- -- Clear the status of all affected nodes- liftIO $ mapM_ (clearRecursivelyWhere (\x -> runTreeId x `S.member` allIds)) (s ^. appRunTreeBase)- -- Start a run for all affected nodes- let bc = (s ^. appBaseContext) { baseContextOnlyRunIds = Just allIds }- void $ liftIO $ async $ void $ runNodesSequentially (s ^. appRunTreeBase) bc- V.EvKey c [] | c == clearSelectedKey -> withContinueS s $ do- whenJust (listSelectedElement (s ^. appMainList)) $ \(_, MainListElem {..}) -> case status of- Running {} -> return ()- _ -> case findRunNodeChildrenById ident (s ^. appRunTree) of- Nothing -> return ()- Just childIds -> liftIO $ mapM_ (clearRecursivelyWhere (\x -> runTreeId x `S.member` childIds)) (s ^. appRunTreeBase)- V.EvKey c [] | c == clearAllKey -> withContinueS s $ do- liftIO $ mapM_ clearRecursively (s ^. appRunTreeBase)- V.EvKey c [] | c == openSelectedFolderInFileExplorer -> withContinueS s $ do- whenJust (listSelectedElement (s ^. appMainList)) $ \(_i, MainListElem {folderPath}) ->- whenJust folderPath $ liftIO . openFileExplorerFolderPortable- V.EvKey c [] | c == openTestRootKey -> withContinueS s $- whenJust (baseContextRunRoot (s ^. appBaseContext)) $ liftIO . openFileExplorerFolderPortable- V.EvKey c [] | c == openTestInEditorKey -> case listSelectedElement (s ^. appMainList) of- Just (_i, MainListElem {node=(runTreeLoc -> Just loc)}) -> openSrcLoc s loc- _ -> continue s- V.EvKey c [] | c == openLogsInEditorKey -> case listSelectedElement (s ^. appMainList) of- Just (_i, MainListElem {node=(runTreeFolder -> Just dir)}) -> do- let srcLoc = SrcLoc {- srcLocPackage = ""- , srcLocModule = ""- , srcLocFile = dir </> "test_logs.txt"- , srcLocStartLine = 0- , srcLocStartCol = 0- , srcLocEndLine = 0- , srcLocEndCol = 0- }- suspendAndResume ((s ^. appOpenInEditor) srcLoc >> return s)- _ -> continue s- V.EvKey c [] | c == openFailureInEditorKey -> do- case (listSelectedElement (s ^. appMainList)) of- Nothing -> continue s- Just (_i, MainListElem {status}) -> case status of- Done _ _ (Failure (failureCallStack -> Just (getCallStack -> ((_, loc):_)))) -> openSrcLoc s loc- _ -> continue s-- -- Column 3- V.EvKey c [] | c == cycleVisibilityThresholdKey -> do- let newVisibilityThreshold = case [(i, x) | (i, x) <- zip [0..] (s ^. appVisibilityThresholdSteps)- , x > s ^. appVisibilityThreshold] of- [] -> 0- xs -> minimum $ fmap snd xs- continue $ s- & appVisibilityThreshold .~ newVisibilityThreshold- & updateFilteredTree- V.EvKey c [] | c == toggleShowRunTimesKey -> continue $ s- & appShowRunTimes %~ not- V.EvKey c [] | c == toggleFileLocationsKey -> continue $ s- & appShowFileLocations %~ not- V.EvKey c [] | c == toggleVisibilityThresholdsKey -> continue $ s- & appShowVisibilityThresholds %~ not- V.EvKey c [] | c `elem` [V.KEsc, exitKey] -> do- -- Cancel everything and wait for cleanups- liftIO $ mapM_ cancelNode (s ^. appRunTreeBase)- forM_ (s ^. appRunTreeBase) (liftIO . waitForTree)- doHalt s- V.EvKey c [] | c == debugKey -> continue (s & appLogLevel ?~ LevelDebug)- V.EvKey c [] | c == infoKey -> continue (s & appLogLevel ?~ LevelInfo)- V.EvKey c [] | c == warnKey -> continue (s & appLogLevel ?~ LevelWarn)- V.EvKey c [] | c == errorKey -> continue (s & appLogLevel ?~ LevelError)--#if MIN_VERSION_brick(1,0,0)- ev -> zoom appMainList $ handleListEvent ev-#else- ev -> handleEventLensed s appMainList handleListEvent ev >>= continue-#endif-- where withContinueS s action = action >> continue s-#if MIN_VERSION_brick(1,0,0)-appEvent _ _ = return ()-#else-appEvent s _ = continue s-#endif--modifyToggled s f = case listSelectedElement (s ^. appMainList) of- Nothing -> continue s- Just (_i, MainListElem {..}) -> do- liftIO $ atomically $ modifyTVar (runTreeToggled node) f- continue s--modifyOpen s f = case listSelectedElement (s ^. appMainList) of- Nothing -> continue s- Just (_i, MainListElem {..}) -> do- liftIO $ atomically $ modifyTVar (runTreeOpen node) f- continue s--openIndices :: [RunNode context] -> Seq.Seq Int -> IO ()-openIndices nodes openSet =- atomically $ forM_ (concatMap getCommons nodes) $ \node ->- when ((runTreeId node) `elem` (toList openSet)) $- modifyTVar (runTreeOpen node) (const True)--openToDepth :: (Foldable t) => t MainListElem -> Int -> IO ()-openToDepth elems thresh =- atomically $ forM_ elems $ \(MainListElem {..}) ->- if | (depth < thresh) -> modifyTVar (runTreeOpen node) (const True)- | otherwise -> modifyTVar (runTreeOpen node) (const False)--setInitialFolding :: InitialFolding -> [RunNode BaseContext] -> IO ()-setInitialFolding InitialFoldingAllOpen _rts = return ()-setInitialFolding InitialFoldingAllClosed rts =- atomically $ forM_ (concatMap getCommons rts) $ \(RunNodeCommonWithStatus {..}) ->- modifyTVar runTreeOpen (const False)-setInitialFolding (InitialFoldingTopNOpen n) rts =- atomically $ forM_ (concatMap getCommons rts) $ \(RunNodeCommonWithStatus {..}) ->- when (Seq.length runTreeAncestors > n) $- modifyTVar runTreeOpen (const False)--updateFilteredTree :: AppState -> AppState-updateFilteredTree s = s- & appMainList %~ listReplace elems (listSelected $ s ^. appMainList)- where filteredTree = filterRunTree (s ^. appVisibilityThreshold) (s ^. appRunTree)- elems :: Vec.Vector MainListElem = Vec.fromList $ concatMap treeToList (zip filteredTree (s ^. appRunTreeBase))---- * Clearing--clearRecursively :: RunNode context -> IO ()-clearRecursively = mapM_ clearCommon . getCommons--clearRecursivelyWhere :: (RunNodeCommon -> Bool) -> RunNode context -> IO ()-clearRecursivelyWhere f = mapM_ clearCommon . filter f . getCommons--clearCommon :: RunNodeCommon -> IO ()-clearCommon (RunNodeCommonWithStatus {..}) = do- atomically $ do- writeTVar runTreeStatus NotStarted- writeTVar runTreeLogs mempty-- -- TODO: clearing the folders might be better for reproducibility, but it might be more surprising than not doing it.- -- Also, we'd want to be a little judicious about which folders get cleared -- clearing entire "describe" folders would- -- blow away unrelated test results. So maybe it's better to not clear, and for tests to just do idempotent things in- -- their folders.- -- whenJust runTreeFolder $ \folder -> do- -- doesDirectoryExist folder >>= \case- -- False -> return ()- -- True -> clearDirectoryContents folder- -- where- -- clearDirectoryContents :: FilePath -> IO ()- -- clearDirectoryContents path = do- -- paths <- listDirectory path- -- forM_ paths removePathForcibly--findRunNodeChildrenById :: Int -> [RunNodeFixed context] -> Maybe (S.Set Int)-findRunNodeChildrenById ident rts = headMay $ mapMaybe (findRunNodeChildrenById' ident) rts--findRunNodeChildrenById' :: Int -> RunNodeFixed context -> Maybe (S.Set Int)-findRunNodeChildrenById' ident node | ident == runTreeId (runNodeCommon node) = Just $ S.fromList $ extractValues (runTreeId . runNodeCommon) node-findRunNodeChildrenById' _ident (RunNodeIt {}) = Nothing-findRunNodeChildrenById' ident (RunNodeIntroduce {..}) = findRunNodeChildrenById ident runNodeChildrenAugmented-findRunNodeChildrenById' ident (RunNodeIntroduceWith {..}) = findRunNodeChildrenById ident runNodeChildrenAugmented-findRunNodeChildrenById' ident node = findRunNodeChildrenById ident (runNodeChildren node)--#if MIN_VERSION_brick(1,0,0)-withScroll :: AppState -> (forall s. ViewportScroll ClickableName -> EventM n s ()) -> EventM n AppState ()-#else-withScroll :: AppState -> (ViewportScroll ClickableName -> EventM n ()) -> EventM n (Next AppState)-#endif-withScroll s action = do- case listSelectedElement (s ^. appMainList) of- Nothing -> return ()- Just (_, MainListElem {..}) -> do- let scroll = viewportScroll (InnerViewport [i|viewport_#{ident}|])- action scroll--#if !MIN_VERSION_brick(1,0,0)- continue s-#endif--openSrcLoc s loc' = do- -- Try to make the file path in the SrcLoc absolute- loc <- case isRelative (srcLocFile loc') of- False -> return loc'- True -> do- case optionsProjectRoot (baseContextOptions (s ^. appBaseContext)) of- Just d -> return $ loc' { srcLocFile = d </> (srcLocFile loc') }- Nothing -> return loc'-- -- TODO: check if the path exists and show a warning message if not- -- Maybe choose the first callstack location we can find?- suspendAndResume (((s ^. appOpenInEditor) loc) >> return s)
− unix-src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs
@@ -1,212 +0,0 @@-{-# LANGUAGE CPP #-}--module Test.Sandwich.Formatters.TerminalUI.AttrMap where--import Brick-import Brick.Widgets.ProgressBar-import qualified Graphics.Vty as V-import Test.Sandwich.Types.RunTree-import Test.Sandwich.Types.Spec--#if MIN_VERSION_brick(1,0,0)-mkAttrName :: String -> AttrName-mkAttrName = attrName-#else-import Data.String--mkAttrName :: String -> AttrName-mkAttrName = fromString-#endif---mainAttrMap :: AttrMap-mainAttrMap = attrMap V.defAttr [- -- (listAttr, V.white `on` V.blue)- -- (listSelectedAttr, V.blue `on` V.white)- -- (listSelectedAttr, bg (V.Color240 $ V.rgbColorToColor240 0 1 0))- -- (selectedAttr, bg (V.Color240 $ V.rgbColorToColor240 0 1 0))-- -- Top bar- (visibilityThresholdNotSelectedAttr, fg midGray)- , (visibilityThresholdSelectedAttr, fg solarizedBase2)-- -- Statuses- -- , (notStartedAttr, fg V.)- , (runningAttr, fg V.blue)- , (pendingAttr, fg V.yellow)- , (successAttr, fg V.green)- , (failureAttr, fg V.red)- , (totalAttr, fg solarizedCyan)-- -- Logging- , (debugAttr, fg V.blue), (infoAttr, fg V.yellow), (warnAttr, fg V.red), (errorAttr, fg V.red), (otherAttr, V.defAttr)- , (logTimestampAttr, fg midGray)- , (logFilenameAttr, fg solarizedViolet)- , (logModuleAttr, fg solarizedMagenta)- , (logPackageAttr, fg solarizedGreen)- , (logLineAttr, fg solarizedCyan)- , (logChAttr, fg solarizedOrange)- , (logFunctionAttr, fg solarizedMagenta)-- -- Progress bar- , (progressCompleteAttr, bg (V.Color240 235))- , (progressIncompleteAttr, bg (V.Color240 225))-- -- Main list- , (toggleMarkerAttr, fg midGray)- , (openMarkerAttr, fg midGray)- , (visibilityThresholdIndicatorMutedAttr, fg $ grayAt 50)- , (visibilityThresholdIndicatorAttr, fg $ grayAt 150)-- -- Hotkey stuff- , (hotkeyAttr, fg V.blue)- , (disabledHotkeyAttr, fg midGray)- , (hotkeyMessageAttr, fg brightWhite)- , (disabledHotkeyMessageAttr, fg brightGray)-- -- Exceptions and pretty printing- , (expectedAttr, fg midWhite)- , (sawAttr, fg midWhite)- , (integerAttr, fg solarizedMagenta)- , (floatAttr, fg solarizedMagenta)- , (charAttr, fg solarizedCyan)- , (stringAttr, fg solarizedYellow)- , (dateAttr, fg solarizedBase2)- , (timeAttr, fg solarizedBase1)- , (quoteAttr, fg solarizedBase1)- , (slashAttr, fg solarizedViolet)- , (negAttr, fg solarizedViolet)- , (listBracketAttr, fg solarizedOrange) -- TODO: make green?- , (tupleBracketAttr, fg solarizedGreen)- , (braceAttr, fg solarizedGreen)- , (ellipsesAttr, fg solarizedBase0)- , (recordNameAttr, fg solarizedRed)- , (fieldNameAttr, fg solarizedYellow)- , (constructorNameAttr, fg solarizedViolet)- ]---- selectedAttr :: AttrName--- selectedAttr = "list_line_selected"--visibilityThresholdNotSelectedAttr :: AttrName-visibilityThresholdNotSelectedAttr = mkAttrName "visibility_threshold_not_selected"--visibilityThresholdSelectedAttr :: AttrName-visibilityThresholdSelectedAttr = mkAttrName "visibility_threshold_selected"--runningAttr :: AttrName-runningAttr = mkAttrName "running"--notStartedAttr :: AttrName-notStartedAttr = mkAttrName "not_started"--pendingAttr :: AttrName-pendingAttr = mkAttrName "pending"--totalAttr :: AttrName-totalAttr = mkAttrName "total"--successAttr :: AttrName-successAttr = mkAttrName "success"--failureAttr :: AttrName-failureAttr = mkAttrName "failure"--toggleMarkerAttr :: AttrName-toggleMarkerAttr = mkAttrName "toggleMarker"--openMarkerAttr :: AttrName-openMarkerAttr = mkAttrName "openMarker"--visibilityThresholdIndicatorAttr :: AttrName-visibilityThresholdIndicatorAttr = mkAttrName "visibilityThresholdIndicator"--visibilityThresholdIndicatorMutedAttr :: AttrName-visibilityThresholdIndicatorMutedAttr = mkAttrName "visibilityThresholdMutedIndicator"--hotkeyAttr, disabledHotkeyAttr, hotkeyMessageAttr, disabledHotkeyMessageAttr :: AttrName-hotkeyAttr = mkAttrName "hotkey"-disabledHotkeyAttr = mkAttrName "disableHotkey"-hotkeyMessageAttr = mkAttrName "hotkeyMessage"-disabledHotkeyMessageAttr = mkAttrName "disabledHotkeyMessage"--chooseAttr :: Status -> AttrName-chooseAttr NotStarted = notStartedAttr-chooseAttr (Running {}) = runningAttr-chooseAttr (Done _ _ (Success {})) = successAttr-chooseAttr (Done _ _ (Failure (Pending {}))) = pendingAttr-chooseAttr (Done _ _ (Failure {})) = failureAttr-chooseAttr (Done _ _ DryRun) = notStartedAttr-chooseAttr (Done _ _ Cancelled) = failureAttr---- * Logging and callstacks--debugAttr, infoAttr, warnAttr, errorAttr, otherAttr :: AttrName-debugAttr = attrName"log_debug"-infoAttr = attrName"log_info"-warnAttr = attrName"log_warn"-errorAttr = attrName"log_error"-otherAttr = mkAttrName "log_other"--logTimestampAttr :: AttrName-logTimestampAttr = mkAttrName "log_timestamp"--logFilenameAttr, logModuleAttr, logPackageAttr, logLineAttr, logChAttr :: AttrName-logFilenameAttr = mkAttrName "logFilename"-logModuleAttr = mkAttrName "logModule"-logPackageAttr = mkAttrName "logPackage"-logLineAttr = mkAttrName "logLine"-logChAttr = mkAttrName "logCh"-logFunctionAttr = mkAttrName "logFunction"---- * Exceptions and pretty printing--expectedAttr, sawAttr :: AttrName-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"-stringAttr = mkAttrName "string"-dateAttr = mkAttrName "date"-timeAttr = mkAttrName "time"-quoteAttr = mkAttrName "quote"-slashAttr = mkAttrName "slash"-negAttr = mkAttrName "neg"-listBracketAttr = mkAttrName "listBracket"-tupleBracketAttr = mkAttrName "tupleBracket"-braceAttr = mkAttrName "brace"-ellipsesAttr = mkAttrName "ellipses"-recordNameAttr = mkAttrName "recordName"-fieldNameAttr = mkAttrName "fieldName"-constructorNameAttr = mkAttrName "fieldName"---- * Colors--solarizedBase03 = V.rgbColor 0x00 0x2b 0x36-solarizedBase02 = V.rgbColor 0x07 0x36 0x42-solarizedBase01 = V.rgbColor 0x58 0x6e 0x75-solarizedbase00 = V.rgbColor 0x65 0x7b 0x83-solarizedBase0 = V.rgbColor 0x83 0x94 0x96-solarizedBase1 = V.rgbColor 0x93 0xa1 0xa1-solarizedBase2 = V.rgbColor 0xee 0xe8 0xd5-solarizedBase3 = V.rgbColor 0xfd 0xf6 0xe3-solarizedYellow = V.rgbColor 0xb5 0x89 0x00-solarizedOrange = V.rgbColor 0xcb 0x4b 0x16-solarizedRed = V.rgbColor 0xdc 0x32 0x2f-solarizedMagenta = V.rgbColor 0xd3 0x36 0x82-solarizedViolet = V.rgbColor 0x6c 0x71 0xc4-solarizedBlue = V.rgbColor 0x26 0x8b 0xd2-solarizedCyan = V.rgbColor 0x2a 0xa1 0x98-solarizedGreen = V.rgbColor 0x85 0x99 0x00--midGray = grayAt 50-brightGray = grayAt 80-midWhite = grayAt 140-brightWhite = grayAt 200--grayAt level = V.rgbColor level level level--- grayAt level = V.Color240 $ V.rgbColorToColor240 level level level
− unix-src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs
@@ -1,12 +0,0 @@--- |--module Test.Sandwich.Formatters.TerminalUI.CrossPlatform (- openFileExplorerFolderPortable- ) where--import Control.Monad-import System.Process---- | TODO: report exceptions here-openFileExplorerFolderPortable folder = do- void $ readCreateProcessWithExitCode (proc "xdg-open" [folder]) ""
− unix-src/Test/Sandwich/Formatters/TerminalUI/Draw.hs
@@ -1,161 +0,0 @@-{-# LANGUAGE MultiWayIf #-}-{-# LANGUAGE CPP #-}--module Test.Sandwich.Formatters.TerminalUI.Draw where--import Brick-import Brick.Widgets.Border-import Brick.Widgets.Center-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-import qualified Data.Sequence as Seq-import Data.String.Interpolate-import qualified Data.Text.Encoding as E-import Data.Time.Clock-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-import Test.Sandwich.Formatters.TerminalUI.Draw.ColorProgressBar-import Test.Sandwich.Formatters.TerminalUI.Draw.ToBrickWidget-import Test.Sandwich.Formatters.TerminalUI.Draw.TopBox-import Test.Sandwich.Formatters.TerminalUI.Draw.Util-import Test.Sandwich.Formatters.TerminalUI.Types-import Test.Sandwich.Types.RunTree-import Test.Sandwich.Types.Spec---drawUI :: AppState -> [Widget ClickableName]-drawUI app = [ui]- where- ui = vBox [- topBox app- , borderWithCounts app- , mainList app- , clickable ColorBar $ bottomProgressBarColored app- ]--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 [- Just $ renderLine isSelected x- , do- guard toggled- let infoWidgets = getInfoWidgets x- guard (not $ L.null infoWidgets)- return $ padLeft (Pad 4) $- fixedHeightOrViewportPercent (InnerViewport [i|viewport_#{ident}|]) 33 $- vBox infoWidgets- ]-- renderLine _isSelected (MainListElem {..}) = hBox $ catMaybes [- Just $ withAttr openMarkerAttr $ str (if open then "[-] " else "[+] ")- , Just $ withAttr (chooseAttr status) (str label)- , if not (app ^. appShowFileLocations) then Nothing else- case runTreeLoc node of- Nothing -> Nothing- Just loc ->- Just $ hBox [str " ["- , withAttr logFilenameAttr $ str $ srcLocFile loc- , str ":"- , withAttr logLineAttr $ str $ show $ srcLocStartLine loc- , str "]"]- , if not (app ^. appShowVisibilityThresholds) then Nothing else- Just $ hBox [str " ["- , withAttr visibilityThresholdIndicatorMutedAttr $ str "V="- , withAttr visibilityThresholdIndicatorAttr $ str $ show visibilityLevel- , str "]"]- , Just $ padRight Max $ withAttr toggleMarkerAttr $ str (if toggled then " [-]" else " [+]")- , if not (app ^. appShowRunTimes) then Nothing else case status of- Running {..} -> Just $ str $ show statusStartTime- Done {..} -> Just $ raw $ V.string attr $ formatNominalDiffTime (diffUTCTime statusEndTime statusStartTime)- where totalElapsed = realToFrac (max (app ^. appTimeSinceStart) (diffUTCTime statusEndTime (app ^. appStartTime)))- duration = realToFrac (diffUTCTime statusEndTime statusStartTime)- intensity :: Double = logBase (totalElapsed + 1) (duration + 1)- minGray :: Int = 50- maxGray :: Int = 255- level :: Int = min maxGray $ max minGray $ round (fromIntegral minGray + (intensity * (fromIntegral (maxGray - minGray))))- attr = V.Attr {- V.attrStyle = V.Default- , V.attrForeColor = V.SetTo (grayAt level)- , V.attrBackColor = V.Default- , V.attrURL = V.Default- }- _ -> Nothing- ]-- getInfoWidgets mle@(MainListElem {..}) = catMaybes [Just $ runReader (toBrickWidget status) (app ^. appCustomExceptionFormatters), callStackWidget mle, logWidget mle]-- callStackWidget (MainListElem {..}) = do- 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- Nothing -> mempty- Just logLevel -> Seq.filter (\x -> logEntryLevel x >= logLevel) logs- guard (not $ Seq.null filteredLogs)- return $ borderWithLabel (padLeftRight 1 $ str "Logs") $ vBox $- toList $ fmap logEntryWidget filteredLogs-- logEntryWidget (LogEntry {..}) = hBox [- withAttr logTimestampAttr $ str (show logEntryTime)- , str " "- , logLevelWidget logEntryLevel- , str " "- , logLocWidget logEntryLoc- , str " "- , txtWrap (E.decodeUtf8 $ fromLogStr logEntryStr)- ]-- logLocWidget (Loc {loc_start=(line, ch), ..}) = hBox [- str "["- , withAttr logFilenameAttr $ str loc_filename- , str ":"- , withAttr logLineAttr $ str (show line)- , str ":"- , withAttr logChAttr $ str (show ch)- , str "]"- ]-- logLevelWidget LevelDebug = withAttr debugAttr $ str "(DEBUG)"- logLevelWidget LevelInfo = withAttr infoAttr $ str "(INFO)"- logLevelWidget LevelWarn = withAttr infoAttr $ str "(WARN)"- logLevelWidget LevelError = withAttr infoAttr $ str "(ERROR)"- logLevelWidget (LevelOther x) = withAttr infoAttr $ str [i|#{x}|]---borderWithCounts app = hBorderWithLabel $ padLeftRight 1 $ hBox (L.intercalate [str ", "] countWidgets <> [str [i| of |]- , withAttr totalAttr $ str $ show totalNumTests- , str [i| in |]- , withAttr timeAttr $ str $ formatNominalDiffTime (app ^. appTimeSinceStart)])- where- countWidgets =- (if totalSucceededTests > 0 then [[withAttr successAttr $ str $ show totalSucceededTests, str " succeeded"]] else mempty)- <> (if totalFailedTests > 0 then [[withAttr failureAttr $ str $ show totalFailedTests, str " failed"]] else mempty)- <> (if totalPendingTests > 0 then [[withAttr pendingAttr $ str $ show totalPendingTests, str " pending"]] else mempty)- <> (if totalRunningTests > 0 then [[withAttr runningAttr $ str $ show totalRunningTests, str " running"]] else mempty)- <> (if totalNotStartedTests > 0 then [[str $ show totalNotStartedTests, str " not started"]] else mempty)-- totalNumTests = countWhere isItBlock (app ^. appRunTree)- totalSucceededTests = countWhere isSuccessItBlock (app ^. appRunTree)- totalPendingTests = countWhere isPendingItBlock (app ^. appRunTree)- 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
− unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs
@@ -1,103 +0,0 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE MultiWayIf #-}--module Test.Sandwich.Formatters.TerminalUI.Draw.ColorProgressBar (- bottomProgressBarColored- ) where--import Brick-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-import Test.Sandwich.Formatters.TerminalUI.Types-import Test.Sandwich.RunTree-import Test.Sandwich.Types.RunTree-import Test.Sandwich.Types.Spec--type Chunk a = [(Rational, a)]--data ChunkSum = ChunkSum { _running :: Rational- , _notStarted :: Rational- , _pending :: Rational- , _success :: Rational- , _failure :: Rational }--zeroChunkSum :: ChunkSum-zeroChunkSum = ChunkSum 0 0 0 0 0--makeLenses ''ChunkSum--splitIntoChunks :: forall a. (Show a) => Rational -> [(Rational, a)] -> [[(Rational, a)]]-splitIntoChunks _ [] = []-splitIntoChunks chunkSize remaining = chunk : (splitIntoChunks chunkSize remaining')- where- (chunk, remaining') = go [] chunkSize remaining-- go :: Chunk a -> Rational -> [(Rational, a)] -> (Chunk a, [(Rational, a)])- go chunkSoFar needed ((amount, val):xs) =- if | amount == needed -> (chunkSoFar <> [(amount, val)], xs)- | amount < needed -> go (chunkSoFar <> [(amount, val)]) (needed - amount) xs- | amount > needed -> (chunkSoFar <> [(needed, val)], (amount - needed, val):xs)- | otherwise -> error "impossible"- go chunkSoFar needed [] = error [i|Bottomed out in go: #{chunkSoFar}, #{needed}|]---- TODO: improve this to use block chars-getCharForChunk :: [(Rational, Status)] -> Widget n-getCharForChunk chunk = withAttr attrToUse (str full_five_eighth_height)- where ChunkSum {..} = sumChunk chunk- (_, attrToUse) = maxBy fst [(_running, runningAttr)- , (_notStarted, notStartedAttr)- , (_pending, pendingAttr)- , (_success, successAttr)- , (_failure, failureAttr)- ]--sumChunk :: Chunk Status -> ChunkSum-sumChunk = foldl combine zeroChunkSum- where combine chunkSum (amount, status) = chunkSum & (lensForStatus status) %~ (+ amount)-- lensForStatus NotStarted = notStarted- lensForStatus (Running {}) = running- lensForStatus (Done {statusResult=Success}) = success- lensForStatus (Done {statusResult=(Failure (Pending {}))}) = pending- lensForStatus (Done {statusResult=(Failure _)}) = failure- lensForStatus (Done {statusResult=DryRun}) = notStarted- lensForStatus (Done {statusResult=Cancelled}) = failure--maxBy :: (Foldable t, Ord a) => (b -> a) -> t b -> b-maxBy = maximumBy . comparing---- * Block elems---- full = "█"--- seven_eighth = "▉"--- six_eighth = "▊"--- five_eighth = "▋"--- four_eighth = "▌"--- three_eighth = "▍"--- two_eighth = "▎"--- one_eighth = "▏"--full_five_eighth_height = "▆"---- * Exports--bottomProgressBarColored app = Widget Greedy Fixed $ do- c <- getContext- render $ bottomProgressBarColoredWidth app (c ^. availWidthL)--bottomProgressBarColoredWidth app width = hBox [getCharForChunk chunk | chunk <- chunks]- where- statuses = concatMap getStatuses (app ^. appRunTree)- statusesWithAmounts = [(testsPerChar, x) | x <- statuses]-- chunks = splitIntoChunks 1 statusesWithAmounts-- testsPerChar :: Rational = fromIntegral width / fromIntegral (length statuses)-- getStatuses :: (HasCallStack) => RunNodeWithStatus context a l t -> [a]- getStatuses = extractValues (runTreeStatus . runNodeCommon)
− unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs
@@ -1,189 +0,0 @@-{-# LANGUAGE CPP #-}-{-# 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 -> Reader CustomExceptionFormatters (Widget n)--instance ToBrickWidget Status where- 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- toBrickWidget (Done {statusResult=DryRun}) = return $ strWrap "Not started due to dry run"- toBrickWidget (Done {statusResult=Cancelled}) = return $ strWrap "Cancelled"--instance ToBrickWidget FailureReason where- 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) = return $ boxWithTitle "Failure reason:" (strWrap msg)- toBrickWidget (RawImage _ _ image) = return $ boxWithTitle "Failure reason:" (raw image)- 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)- 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)- 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)---boxWithTitle :: String -> Widget n -> Widget n-boxWithTitle heading inside = hBox [- border $- padAll 1 $- (padBottom (Pad 1) (withAttr expectedAttr $ strWrap heading))- <=>- inside- ]--reifyWidget :: Show a => a -> Reader CustomExceptionFormatters (Widget n)-reifyWidget x = case P.reify x of- Just v -> toBrickWidget v- _ -> return $ strWrap (show x)--instance ToBrickWidget P.Value where- 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) = 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) = 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- ]--abbreviateList :: [Value] -> Reader CustomExceptionFormatters [Widget n]-abbreviateList = abbreviateList' toBrickWidget--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 <$> (mapM renderLine $ getCallStack cs)- where- renderLine (f, srcLoc) = toBrickWidget srcLoc >>= \w -> return $ hBox [- withAttr logFunctionAttr $ str f- , str " called at "- , w- ]--instance ToBrickWidget SrcLoc where- toBrickWidget (SrcLoc {..}) = return $ hBox [- withAttr logFilenameAttr $ str srcLocFile- , str ":"- , withAttr logLineAttr $ str $ show srcLocStartLine- , str ":"- , withAttr logChAttr $ str $ show srcLocStartCol- , str " in "- , withAttr logPackageAttr $ str srcLocPackage- , str ":"- , str srcLocModule- ]---- * Util--takeEnd :: Int -> [a] -> [a]-takeEnd j xs = f xs (drop j xs)- where f (_:zs) (_:ys) = f zs ys- f zs _ = zs
− unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs
@@ -1,178 +0,0 @@-{-# LANGUAGE MultiWayIf #-}--- |--module Test.Sandwich.Formatters.TerminalUI.Draw.TopBox (- topBox- ) where--import Brick-import qualified Brick.Widgets.List as L-import Control.Monad.Logger-import qualified Data.List as L-import Data.Maybe-import Lens.Micro-import Test.Sandwich.Formatters.TerminalUI.AttrMap-import Test.Sandwich.Formatters.TerminalUI.Keys-import Test.Sandwich.Formatters.TerminalUI.Types-import Test.Sandwich.RunTree-import Test.Sandwich.Types.RunTree-import Test.Sandwich.Types.Spec---topBox app = hBox [columnPadding settingsColumn- , columnPadding actionsColumn- , columnPadding otherActionsColumn]- where- settingsColumn = keybindingBox [keyIndicator (L.intersperse '/' [unKChar nextKey, unKChar previousKey, '↑', '↓']) "Navigate"- , keyIndicatorHasSelected app (showKeys toggleKeys) "Open/close node"- , keyIndicatorHasSelectedOpen app "Control-v/Meta-v" "Scroll node"- , keyIndicatorHasSelected app (unKChar closeNodeKey : '/' : [unKChar openNodeKey]) "Fold/unfold node"- , keyIndicator "Meta + [0-9]" "Unfold top # nodes"- , keyIndicator (unKChar nextFailureKey : '/' : [unKChar previousFailureKey]) "Next/previous failure"- ]-- actionsColumn = keybindingBox [hBox [str "["- , highlightKeyIfPredicate selectedTestRunning app (str $ showKey cancelSelectedKey)- , str "/"- , highlightKeyIfPredicate someTestRunning app (str $ showKey cancelAllKey)- , str "] "- , withAttr hotkeyMessageAttr $ str "Cancel "- , highlightMessageIfPredicate selectedTestRunning app (str "selected")- , str "/"- , highlightMessageIfPredicate someTestRunning app (str "all")- ]- , hBox [str "["- , highlightKeyIfPredicate selectedTestDone app (str $ showKey runSelectedKey)- , str "/"- , highlightKeyIfPredicate noTestsRunning app (str $ showKey runAllKey)- , str "] "- , withAttr hotkeyMessageAttr $ str "Run "- , highlightMessageIfPredicate selectedTestDone app (str "selected")- , str "/"- , highlightMessageIfPredicate noTestsRunning app (str "all")- ]- , hBox [str "["- , highlightKeyIfPredicate selectedTestDone app (str $ showKey clearSelectedKey)- , str "/"- , highlightKeyIfPredicate allTestsDone app (str $ showKey clearAllKey)- , str "] "- , withAttr hotkeyMessageAttr $ str "Clear "- , highlightMessageIfPredicate selectedTestDone app (str "selected")- , str "/"- , highlightMessageIfPredicate allTestsDone app (str "all")- ]- , hBox [str "["- , highlightKeyIfPredicate someTestSelected app (str $ showKey openSelectedFolderInFileExplorer)- , str "/"- , highlightKeyIfPredicate (const True) app (str $ showKey openTestRootKey)- , str "] "- , withAttr hotkeyMessageAttr $ str "Open "- , highlightMessageIfPredicate someTestSelected app (str "selected")- , str "/"- , highlightMessageIfPredicate (const True) app (str "root")- , withAttr hotkeyMessageAttr $ str " folder"- ]- , hBox [str "["- , highlightKeyIfPredicate someTestSelected app (str $ showKey openTestInEditorKey)- , str "/"- , highlightKeyIfPredicate someTestSelected app (str $ showKey openLogsInEditorKey)- , str "/"- , highlightKeyIfPredicate someTestSelected app (str $ showKey openFailureInEditorKey)- , str "] "- , withAttr hotkeyMessageAttr $ str "Edit "- , highlightMessageIfPredicate someTestSelected app (str "test")- , str "/"- , highlightMessageIfPredicate someTestSelected app (str "logs")- , str "/"- , highlightMessageIfPredicate selectedTestHasCallStack app (str "failure")- ]- ]-- otherActionsColumn = keybindingBox [keyIndicator' (showKey cycleVisibilityThresholdKey) (visibilityThresholdWidget app)- , hBox [str "["- , str $ showKey toggleShowRunTimesKey- , str "/"- , str $ showKey toggleFileLocationsKey- , str "/"- , str $ showKey toggleVisibilityThresholdsKey- , str "] "- , highlightMessageIfPredicate (^. appShowRunTimes) app (str "Times")- , str "/"- , highlightMessageIfPredicate (^. appShowFileLocations) app (str "locations")- , str "/"- , highlightMessageIfPredicate (^. appShowVisibilityThresholds) app (str "thresholds")- ]- , hBox [str "["- , highlightIfLogLevel app LevelDebug [unKChar debugKey]- , str "/"- , highlightIfLogLevel app LevelInfo [unKChar infoKey]- , str "/"- , highlightIfLogLevel app LevelWarn [unKChar warnKey]- , str "/"- , highlightIfLogLevel app LevelError [unKChar errorKey]- , str "] "- , str "Log level"]-- , keyIndicator "q" "Exit"]--visibilityThresholdWidget app = hBox $- [withAttr hotkeyMessageAttr $ str "Visibility threshold ("]- <> L.intersperse (str ", ") [withAttr (if x == app ^. appVisibilityThreshold then visibilityThresholdSelectedAttr else visibilityThresholdNotSelectedAttr) $ str $ show x | x <- (app ^. appVisibilityThresholdSteps)]- <> [(str ")")]--columnPadding = padLeft (Pad 1) . padRight (Pad 3) -- . padTop (Pad 1)--keybindingBox = vBox--highlightIfLogLevel app desiredLevel thing =- if | app ^. appLogLevel == Just desiredLevel -> withAttr visibilityThresholdSelectedAttr $ str thing- | otherwise -> withAttr hotkeyAttr $ str thing--highlightKeyIfPredicate p app x = case p app of- True -> withAttr hotkeyAttr x- False -> withAttr disabledHotkeyAttr x--highlightMessageIfPredicate p app x = case p app of- True -> withAttr hotkeyMessageAttr x- False -> withAttr disabledHotkeyMessageAttr x--keyIndicator key msg = keyIndicator' key (withAttr hotkeyMessageAttr $ str msg)--keyIndicator' key label = hBox [str "[", withAttr hotkeyAttr $ str key, str "] ", label]--keyIndicatorHasSelected app = keyIndicatorContextual app someTestSelected--keyIndicatorHasSelectedOpen app = keyIndicatorContextual app selectedTestToggled--keyIndicatorContextual app p key msg = case p app of- True -> hBox [str "[", withAttr hotkeyAttr $ str key, str "] ", withAttr hotkeyMessageAttr $ str msg]- False -> hBox [str "[", withAttr disabledHotkeyAttr $ str key, str "] ", withAttr disabledHotkeyMessageAttr $ str msg]----- * Predicates--selectedTestRunning s = case L.listSelectedElement (s ^. appMainList) of- Nothing -> False- Just (_, MainListElem {..}) -> isRunning status--selectedTestDone s = case L.listSelectedElement (s ^. appMainList) of- Nothing -> False- Just (_, MainListElem {..}) -> isDone status--selectedTestHasCallStack s = case L.listSelectedElement (s ^. appMainList) of- Nothing -> False- Just (_, MainListElem {..}) -> case status of- (Done _ _ (Failure failureReason)) -> isJust $ failureCallStack failureReason- _ -> False--selectedTestToggled s = case L.listSelectedElement (s ^. appMainList) of- Nothing -> False- Just (_, MainListElem {..}) -> toggled--noTestsRunning s = all (not . isRunning . runTreeStatus . runNodeCommon) (s ^. appRunTree)--someTestRunning s = any (isRunning . runTreeStatus . runNodeCommon) (s ^. appRunTree)--allTestsDone s = all (isDone . runTreeStatus . runNodeCommon) (s ^. appRunTree)--someTestSelected s = isJust $ L.listSelectedElement (s ^. appMainList)
− unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/Util.hs
@@ -1,34 +0,0 @@-{-# LANGUAGE CPP #-}--module Test.Sandwich.Formatters.TerminalUI.Draw.Util where--import Brick-import Graphics.Vty.Image-import Lens.Micro---fixedHeightOrViewportPercent :: (Ord n, Show n) => n -> Int -> Widget n -> Widget n-fixedHeightOrViewportPercent vpName maxHeightPercent w =- Widget Fixed Fixed $ do- -- Render the viewport contents in advance- result <- render w- -- If the contents will fit in the maximum allowed rows,- -- just return the content without putting it in a viewport.-- ctx <- getContext--#if MIN_VERSION_brick(0,56,0)- let usableHeight = ctx ^. windowHeightL-#else- let usableHeight = min 80 (ctx ^. availHeightL) -- Bound this so it looks okay inside a viewport-#endif-- let maxHeight = round (toRational usableHeight * (toRational maxHeightPercent / 100))-- if imageHeight (image result) <= maxHeight- then return result- -- Otherwise put the contents (pre-rendered) in a viewport- -- and limit the height to the maximum allowable height.- else render (vLimit maxHeight $- viewport vpName Vertical $- Widget Fixed Fixed $ return result)
− unix-src/Test/Sandwich/Formatters/TerminalUI/Filter.hs
@@ -1,93 +0,0 @@-{-# LANGUAGE MultiWayIf #-}--- |--module Test.Sandwich.Formatters.TerminalUI.Filter (- filterRunTree- , treeToList- ) where--import Control.Monad-import Control.Monad.Trans.Reader-import Data.Function-import qualified Data.List as L-import Test.Sandwich.Formatters.TerminalUI.Types-import Test.Sandwich.RunTree-import Test.Sandwich.Types.RunTree--filterRunTree :: Int -> [RunNodeFixed context] -> [RunNodeFixed context]-filterRunTree visibilityThreshold rtsFixed = rtsFixed- & fmap (mapCommon (hideIfThresholdAbove visibilityThreshold))- & fmap hideClosed--mapCommon :: (RunNodeCommonWithStatus s l t -> RunNodeCommonWithStatus s l t) -> RunNodeWithStatus context s l t -> RunNodeWithStatus context s l t-mapCommon f node@(RunNodeIt {}) = node { runNodeCommon = f (runNodeCommon node) }-mapCommon f (RunNodeIntroduce {..}) = RunNodeIntroduce { runNodeCommon = f runNodeCommon- , runNodeChildrenAugmented = fmap (mapCommon f) runNodeChildrenAugmented- , .. }-mapCommon f (RunNodeIntroduceWith {..}) = RunNodeIntroduceWith { runNodeCommon = f runNodeCommon- , runNodeChildrenAugmented = fmap (mapCommon f) runNodeChildrenAugmented- , .. }-mapCommon f node = node { runNodeCommon = f (runNodeCommon node)- , runNodeChildren = fmap (mapCommon f) (runNodeChildren node) }---hideIfThresholdAbove :: Int -> RunNodeCommonFixed -> RunNodeCommonFixed-hideIfThresholdAbove visibilityThreshold node@(RunNodeCommonWithStatus {..}) =- if | runTreeVisibilityLevel <= visibilityThreshold -> node { runTreeVisible = True }- | otherwise -> node { runTreeVisible = False- , runTreeOpen = True -- Must be open so children have a chance to be seen- }--markClosed :: RunNodeCommonWithStatus s l Bool -> RunNodeCommonWithStatus s l Bool-markClosed node@(RunNodeCommonWithStatus {..}) = node { runTreeVisible = False }--hideClosed :: RunNodeWithStatus context s l Bool -> RunNodeWithStatus context s l Bool-hideClosed node@(RunNodeIt {}) = node-hideClosed (RunNodeIntroduce {..})- | runTreeOpen runNodeCommon = RunNodeIntroduce { runNodeChildrenAugmented = fmap hideClosed runNodeChildrenAugmented, .. }- | otherwise = RunNodeIntroduce { runNodeChildrenAugmented = fmap (mapCommon markClosed) runNodeChildrenAugmented, .. }-hideClosed (RunNodeIntroduceWith {..})- | runTreeOpen runNodeCommon = RunNodeIntroduceWith { runNodeChildrenAugmented = fmap hideClosed runNodeChildrenAugmented, .. }- | otherwise = RunNodeIntroduceWith { runNodeChildrenAugmented = fmap (mapCommon markClosed) runNodeChildrenAugmented, .. }-hideClosed node- | runTreeOpen (runNodeCommon node) = node { runNodeChildren = fmap hideClosed (runNodeChildren node) }- | otherwise = node { runNodeChildren = fmap (mapCommon markClosed) (runNodeChildren node) }---treeToList :: (RunNodeFixed context, RunNode context) -> [MainListElem]-treeToList (nodeFixed, node) = L.zip (runReader (getCommonsWithVisibleDepth' nodeFixed) 0) (getCommons node)- & L.filter (isVisible . fst . fst)- & fmap commonToMainListElem- where-- isVisible :: RunNodeCommonFixed -> Bool- isVisible (RunNodeCommonWithStatus {..}) = runTreeVisible-- commonToMainListElem :: ((RunNodeCommonFixed, Int), RunNodeCommon) -> MainListElem- commonToMainListElem ((RunNodeCommonWithStatus {..}, depth), common) = MainListElem {- label = runTreeLabel- , depth = depth- , toggled = runTreeToggled- , open = runTreeOpen- , status = runTreeStatus- , logs = runTreeLogs- , visibilityLevel = runTreeVisibilityLevel- , folderPath = runTreeFolder- , node = common- , ident = runTreeId- }--getCommonsWithVisibleDepth' :: RunNodeWithStatus context s l t -> Reader Int [(RunNodeCommonWithStatus s l t, Int)]-getCommonsWithVisibleDepth' node@(RunNodeIt {}) = ask >>= \vd -> return [(runNodeCommon node, vd)]-getCommonsWithVisibleDepth' (RunNodeIntroduce {..}) = do- let context = if runTreeVisible runNodeCommon then (local (+1)) else id- rest <- context $ (mconcat <$>) $ forM runNodeChildrenAugmented getCommonsWithVisibleDepth'- ask >>= \vd -> return ((runNodeCommon, vd) : rest)-getCommonsWithVisibleDepth' (RunNodeIntroduceWith {..}) = do- let context = if runTreeVisible runNodeCommon then (local (+1)) else id- rest <- context $ (mconcat <$>) $ forM runNodeChildrenAugmented getCommonsWithVisibleDepth'- ask >>= \vd -> return ((runNodeCommon, vd) : rest)-getCommonsWithVisibleDepth' node = do- let context = if runTreeVisible (runNodeCommon node) then (local (+1)) else id- rest <- context $ (mconcat <$>) $ forM (runNodeChildren node) getCommonsWithVisibleDepth'- ask >>= \vd -> return ((runNodeCommon node, vd) : rest)
− unix-src/Test/Sandwich/Formatters/TerminalUI/Keys.hs
@@ -1,55 +0,0 @@--module Test.Sandwich.Formatters.TerminalUI.Keys where--import qualified Data.List as L-import qualified Graphics.Vty as V---- Column 1-nextKey = V.KChar 'n'-previousKey = V.KChar 'p'-nextFailureKey = V.KChar 'N'-previousFailureKey = V.KChar 'P'-closeNodeKey = V.KLeft-openNodeKey = V.KRight-toggleKeys = [V.KEnter, V.KChar '\t']---- Column 2-cancelAllKey = V.KChar 'C'-cancelSelectedKey = V.KChar 'c'-runAllKey = V.KChar 'R'-runSelectedKey = V.KChar 'r'-clearAllKey = V.KChar 'K'-clearSelectedKey = V.KChar 'k'-openSelectedFolderInFileExplorer = V.KChar 'o'-openTestRootKey = V.KChar 'O'-openTestInEditorKey = V.KChar 't'-openFailureInEditorKey = V.KChar 'f'-openLogsInEditorKey = V.KChar 'l'---- Column 3-cycleVisibilityThresholdKey = V.KChar 'v'-toggleShowRunTimesKey = V.KChar 'T'-toggleFileLocationsKey = V.KChar 'F'-toggleVisibilityThresholdsKey = V.KChar 'V'-debugKey = V.KChar 'd'-infoKey = V.KChar 'i'-warnKey = V.KChar 'w'-errorKey = V.KChar 'e'-exitKey = V.KChar 'q'------ Other--showKey (V.KChar '\t') = "Tab"-showKey (V.KChar c) = [c]-showKey V.KEnter = "Enter"-showKey _ = "?"--showKeys = L.intercalate "/" . fmap showKey--unKChar :: V.Key -> Char-unKChar (V.KChar c) = c-unKChar V.KLeft = '←'-unKChar V.KRight = '→'-unKChar _ = '?'
− unix-src/Test/Sandwich/Formatters/TerminalUI/OpenInEditor.hs
@@ -1,44 +0,0 @@--module Test.Sandwich.Formatters.TerminalUI.OpenInEditor where--import Control.Applicative-import Data.Function-import qualified Data.Text as T-import GHC.Stack-import System.Environment-import System.Exit-import System.Process---autoOpenInEditor :: Maybe String -> (T.Text -> IO ()) -> SrcLoc -> IO ()-autoOpenInEditor terminalUIDefaultEditor debugFn (SrcLoc {..}) = do- maybeEditor' <- lookupEnv "EDITOR"- let maybeEditor = maybeEditor' <|> terminalUIDefaultEditor-- case maybeEditor of- Nothing -> return ()- Just editorString -> do- let editor = editorString- & T.pack- & T.replace "LINE" (T.pack $ show srcLocStartLine)- & T.replace "COLUMN" (T.pack $ show srcLocStartCol)- & fillInFile- & T.unpack-- debugFn ("Opening editor with command: " <> T.pack editor)-- (_, _, _, p) <- createProcess ((shell editor) { delegate_ctlc = True })- waitForProcess p >>= \case- ExitSuccess -> return ()- ExitFailure n -> debugFn ("Editor failed with exit code " <> T.pack (show n))-- where- fillInFile cmd- | "FILE" `T.isInfixOf` cmd = T.replace "FILE" (T.pack $ show srcLocFile) cmd- | otherwise = cmd <> " '" <> T.pack srcLocFile <> "'"---- elisp = [i|(progn--- (x-focus-frame (selected-frame))--- (raise-frame)--- (recenter)--- )|]
− unix-src/Test/Sandwich/Formatters/TerminalUI/Types.hs
@@ -1,135 +0,0 @@-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE ExistentialQuantification #-}--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-import Data.Time-import GHC.Stack-import Lens.Micro.TH-import Test.Sandwich.Formatters.TerminalUI.OpenInEditor-import Test.Sandwich.RunTree-import Test.Sandwich.Types.RunTree---data TerminalUIFormatter = TerminalUIFormatter {- terminalUIVisibilityThreshold :: Int- -- ^ The initial visibility threshold to use when the formatter starts.- , terminalUIInitialFolding :: InitialFolding- -- ^ The initial folding settings to use when the formatter starts.- , terminalUIShowRunTimes :: Bool- -- ^ Whether to show or hide run times.- , terminalUIShowFileLocations :: Bool- -- ^ Whether to show or hide the files in which tests are defined.- , terminalUIShowVisibilityThresholds :: Bool- -- ^ Whether to show or hide visibility thresholds next to nodes.- , terminalUILogLevel :: Maybe LogLevel- -- ^ Log level for test log displays.- , terminalUIRefreshPeriod :: Int- -- ^ Time in microseconds between UI refreshes. Defaults to 100ms. Can be increased if CPU usage of the UI is too high.- , terminalUIDefaultEditor :: Maybe String- -- ^ Default value to use for the EDITOR environment variable when one is not provided.- -- If 'Nothing' and EDITOR can't be found, edit commands will do nothing.- --- -- Here are some recommended values, depending on your preferred editor:- --- -- * Emacs: @export EDITOR="emacsclient --eval '(progn (find-file FILE) (goto-line LINE) (forward-char (- COLUMN 1)) (recenter))'"@- -- * Terminal Emacs: @export EDITOR="emacsclient -nw --eval '(progn (find-file FILE) (goto-line LINE) (forward-char (- COLUMN 1)) (recenter))'"@- -- * Vim: @export EDITOR="vim +LINE"@- , terminalUIOpenInEditor :: Maybe String -> (T.Text -> IO ()) -> SrcLoc -> IO ()- -- ^ Callback to open a source location in your editor. By default, finds the command in the EDITOR environment variable- -- 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- show (TerminalUIFormatter {}) = "<TerminalUIFormatter>"--data InitialFolding =- InitialFoldingAllOpen- | InitialFoldingAllClosed- | InitialFoldingTopNOpen Int- deriving (Show, Eq)---- | Default settings for the terminal UI formatter.-defaultTerminalUIFormatter :: TerminalUIFormatter-defaultTerminalUIFormatter = TerminalUIFormatter {- terminalUIVisibilityThreshold = 50- , terminalUIInitialFolding = InitialFoldingAllOpen- , terminalUIShowRunTimes = True- , terminalUIShowFileLocations = False- , terminalUIShowVisibilityThresholds = False- , terminalUILogLevel = Just LevelWarn- , terminalUIRefreshPeriod = 100000- , terminalUIDefaultEditor = Just "emacsclient +$((LINE+1)):COLUMN --no-wait"- , terminalUIOpenInEditor = autoOpenInEditor- , terminalUICustomExceptionFormatters = []- }--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>"--data MainListElem = MainListElem {- label :: String- , depth :: Int- , toggled :: Bool- , open :: Bool- , status :: Status- , logs :: Seq LogEntry- , visibilityLevel :: Int- , folderPath :: Maybe FilePath- , node :: RunNodeCommon- , ident :: Int- }--data SomeRunNode = forall context s l t. SomeRunNode { unSomeRunNode :: RunNodeWithStatus context s l t }--data ClickableName = ColorBar | ListRow Int | MainList | InnerViewport T.Text- deriving (Show, Ord, Eq)--data AppState = AppState {- _appRunTreeBase :: [RunNode BaseContext]- , _appRunTree :: [RunNodeFixed BaseContext]- , _appMainList :: L.List ClickableName MainListElem- , _appBaseContext :: BaseContext-- , _appStartTime :: UTCTime- , _appTimeSinceStart :: NominalDiffTime-- , _appVisibilityThresholdSteps :: [Int]- , _appVisibilityThreshold :: Int-- , _appLogLevel :: Maybe LogLevel- , _appShowRunTimes :: Bool- , _appShowFileLocations :: Bool- , _appShowVisibilityThresholds :: Bool-- , _appOpenInEditor :: SrcLoc -> IO ()- , _appDebug :: T.Text -> IO ()- , _appCustomExceptionFormatters :: CustomExceptionFormatters- }--makeLenses ''AppState---extractValues' :: (forall context s l t. RunNodeWithStatus context s l t -> a) -> SomeRunNode -> [a]-extractValues' f (SomeRunNode n@(RunNodeIt {})) = [f n]-extractValues' f (SomeRunNode n@(RunNodeIntroduce {runNodeChildrenAugmented})) = (f n) : (concatMap (extractValues f) runNodeChildrenAugmented)-extractValues' f (SomeRunNode n@(RunNodeIntroduceWith {runNodeChildrenAugmented})) = (f n) : (concatMap (extractValues f) runNodeChildrenAugmented)-extractValues' f (SomeRunNode n) = (f n) : (concatMap (extractValues f) (runNodeChildren n))