diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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" } diff --git a/sandwich.cabal b/sandwich.cabal --- a/sandwich.cabal +++ b/sandwich.cabal @@ -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 . 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 diff --git a/src/Test/Sandwich/ArgParsing.hs b/src/Test/Sandwich/ArgParsing.hs --- a/src/Test/Sandwich/ArgParsing.hs +++ b/src/Test/Sandwich/ArgParsing.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/Common/Util.hs b/src/Test/Sandwich/Formatters/Common/Util.hs --- a/src/Test/Sandwich/Formatters/Common/Util.hs +++ b/src/Test/Sandwich/Formatters/Common/Util.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/FailureReport.hs b/src/Test/Sandwich/Formatters/FailureReport.hs --- a/src/Test/Sandwich/Formatters/FailureReport.hs +++ b/src/Test/Sandwich/Formatters/FailureReport.hs @@ -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)) diff --git a/src/Test/Sandwich/Formatters/Print.hs b/src/Test/Sandwich/Formatters/Print.hs --- a/src/Test/Sandwich/Formatters/Print.hs +++ b/src/Test/Sandwich/Formatters/Print.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/Print/FailureReason.hs b/src/Test/Sandwich/Formatters/Print/FailureReason.hs --- a/src/Test/Sandwich/Formatters/Print/FailureReason.hs +++ b/src/Test/Sandwich/Formatters/Print/FailureReason.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/Print/Printing.hs b/src/Test/Sandwich/Formatters/Print/Printing.hs --- a/src/Test/Sandwich/Formatters/Print/Printing.hs +++ b/src/Test/Sandwich/Formatters/Print/Printing.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/Print/Types.hs b/src/Test/Sandwich/Formatters/Print/Types.hs --- a/src/Test/Sandwich/Formatters/Print/Types.hs +++ b/src/Test/Sandwich/Formatters/Print/Types.hs @@ -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 } diff --git a/src/Test/Sandwich/Formatters/TerminalUI.hs b/src/Test/Sandwich/Formatters/TerminalUI.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandwich/Formatters/TerminalUI.hs @@ -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) diff --git a/src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs b/src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs b/src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs @@ -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]) "" diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs b/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs b/src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs @@ -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) diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Draw/RunTimes.hs b/src/Test/Sandwich/Formatters/TerminalUI/Draw/RunTimes.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandwich/Formatters/TerminalUI/Draw/RunTimes.hs @@ -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) diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs b/src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs @@ -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 diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs b/src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs @@ -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) diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Draw/Util.hs b/src/Test/Sandwich/Formatters/TerminalUI/Draw/Util.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandwich/Formatters/TerminalUI/Draw/Util.hs @@ -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) diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Filter.hs b/src/Test/Sandwich/Formatters/TerminalUI/Filter.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandwich/Formatters/TerminalUI/Filter.hs @@ -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) diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Keys.hs b/src/Test/Sandwich/Formatters/TerminalUI/Keys.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandwich/Formatters/TerminalUI/Keys.hs @@ -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 _ = '?' diff --git a/src/Test/Sandwich/Formatters/TerminalUI/OpenInEditor.hs b/src/Test/Sandwich/Formatters/TerminalUI/OpenInEditor.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandwich/Formatters/TerminalUI/OpenInEditor.hs @@ -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) +-- )|] diff --git a/src/Test/Sandwich/Formatters/TerminalUI/Types.hs b/src/Test/Sandwich/Formatters/TerminalUI/Types.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandwich/Formatters/TerminalUI/Types.hs @@ -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 {}) = "" + +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 {}) = "" + show (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)) diff --git a/src/Test/Sandwich/Interpreters/StartTree.hs b/src/Test/Sandwich/Interpreters/StartTree.hs --- a/src/Test/Sandwich/Interpreters/StartTree.hs +++ b/src/Test/Sandwich/Interpreters/StartTree.hs @@ -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) diff --git a/src/Test/Sandwich/Options.hs b/src/Test/Sandwich/Options.hs --- a/src/Test/Sandwich/Options.hs +++ b/src/Test/Sandwich/Options.hs @@ -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 diff --git a/src/Test/Sandwich/RunTree.hs b/src/Test/Sandwich/RunTree.hs --- a/src/Test/Sandwich/RunTree.hs +++ b/src/Test/Sandwich/RunTree.hs @@ -118,7 +118,7 @@ isRunning _ = False isFailureStatus :: Status -> Bool -isFailureStatus (Done _ _ stat) = isFailure stat +isFailureStatus (Done _ _ _ _ stat) = isFailure stat isFailureStatus _ = False isFailure :: Result -> Bool diff --git a/src/Test/Sandwich/Shutdown.hs b/src/Test/Sandwich/Shutdown.hs --- a/src/Test/Sandwich/Shutdown.hs +++ b/src/Test/Sandwich/Shutdown.hs @@ -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 () diff --git a/src/Test/Sandwich/Types/ArgParsing.hs b/src/Test/Sandwich/Types/ArgParsing.hs --- a/src/Test/Sandwich/Types/ArgParsing.hs +++ b/src/Test/Sandwich/Types/ArgParsing.hs @@ -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 _ _ = [] diff --git a/src/Test/Sandwich/Types/RunTree.hs b/src/Test/Sandwich/Types/RunTree.hs --- a/src/Test/Sandwich/Types/RunTree.hs +++ b/src/Test/Sandwich/Types/RunTree.hs @@ -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) diff --git a/src/Test/Sandwich/Types/Spec.hs b/src/Test/Sandwich/Types/Spec.hs --- a/src/Test/Sandwich/Types/Spec.hs +++ b/src/Test/Sandwich/Types/Spec.hs @@ -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 diff --git a/test/TestUtil.hs b/test/TestUtil.hs --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -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 diff --git a/unix-src/Test/Sandwich/Formatters/TerminalUI.hs b/unix-src/Test/Sandwich/Formatters/TerminalUI.hs deleted file mode 100644 --- a/unix-src/Test/Sandwich/Formatters/TerminalUI.hs +++ /dev/null @@ -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) diff --git a/unix-src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs b/unix-src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs deleted file mode 100644 --- a/unix-src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs +++ /dev/null @@ -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 diff --git a/unix-src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs b/unix-src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs deleted file mode 100644 --- a/unix-src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs +++ /dev/null @@ -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]) "" diff --git a/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw.hs b/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw.hs deleted file mode 100644 --- a/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw.hs +++ /dev/null @@ -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 diff --git a/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs b/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs deleted file mode 100644 --- a/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs +++ /dev/null @@ -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) diff --git a/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs b/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs deleted file mode 100644 --- a/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs +++ /dev/null @@ -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 diff --git a/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs b/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs deleted file mode 100644 --- a/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs +++ /dev/null @@ -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) diff --git a/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/Util.hs b/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/Util.hs deleted file mode 100644 --- a/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/Util.hs +++ /dev/null @@ -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) diff --git a/unix-src/Test/Sandwich/Formatters/TerminalUI/Filter.hs b/unix-src/Test/Sandwich/Formatters/TerminalUI/Filter.hs deleted file mode 100644 --- a/unix-src/Test/Sandwich/Formatters/TerminalUI/Filter.hs +++ /dev/null @@ -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) diff --git a/unix-src/Test/Sandwich/Formatters/TerminalUI/Keys.hs b/unix-src/Test/Sandwich/Formatters/TerminalUI/Keys.hs deleted file mode 100644 --- a/unix-src/Test/Sandwich/Formatters/TerminalUI/Keys.hs +++ /dev/null @@ -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 _ = '?' diff --git a/unix-src/Test/Sandwich/Formatters/TerminalUI/OpenInEditor.hs b/unix-src/Test/Sandwich/Formatters/TerminalUI/OpenInEditor.hs deleted file mode 100644 --- a/unix-src/Test/Sandwich/Formatters/TerminalUI/OpenInEditor.hs +++ /dev/null @@ -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) --- )|] diff --git a/unix-src/Test/Sandwich/Formatters/TerminalUI/Types.hs b/unix-src/Test/Sandwich/Formatters/TerminalUI/Types.hs deleted file mode 100644 --- a/unix-src/Test/Sandwich/Formatters/TerminalUI/Types.hs +++ /dev/null @@ -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 {}) = "" - -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 {}) = "" - -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))