diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,11 @@ ## Unreleased changes +## 0.1.1.0 + +* Be able to accept multiple `--filter/-f` arguments. A test must match all of them to be run. +* Windows support. + ## 0.1.0.11 * Initial release Test.Sandwich.Golden for golden testing. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,9 +1,6 @@ {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE CPP #-} module Main where @@ -18,7 +15,11 @@ 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 deriving Show diff --git a/discover/Main.hs b/discover/Main.hs --- a/discover/Main.hs +++ b/discover/Main.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE RecordWildCards #-} module Main where diff --git a/sandwich.cabal b/sandwich.cabal --- a/sandwich.cabal +++ b/sandwich.cabal @@ -3,11 +3,9 @@ -- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: eea544fa3b581852af314541fcc7874b15f46d425b1632e09e36eeaf60de11b3 name: sandwich -version: 0.1.0.11 +version: 0.1.1.0 synopsis: Yet another test framework for Haskell description: Please see the . category: Testing @@ -40,7 +38,6 @@ Test.Sandwich.Formatters.LogSaver Test.Sandwich.Formatters.Print Test.Sandwich.Formatters.Silent - Test.Sandwich.Formatters.TerminalUI Test.Sandwich.Internal Test.Sandwich.TH other-modules: @@ -57,17 +54,6 @@ 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.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 @@ -81,6 +67,7 @@ Test.Sandwich.ParallelN Test.Sandwich.RunTree Test.Sandwich.Shutdown + Test.Sandwich.Signals Test.Sandwich.TestTimer Test.Sandwich.TH.HasMainFunction Test.Sandwich.TH.ModuleMap @@ -94,13 +81,22 @@ Paths_sandwich hs-source-dirs: src + default-extensions: + OverloadedStrings + QuasiQuotes + NamedFieldPuns + RecordWildCards + ScopedTypeVariables + FlexibleContexts + FlexibleInstances + LambdaCase + ViewPatterns ghc-options: -W build-depends: aeson , ansi-terminal , async , base <5 - , brick , bytestring , colour , containers @@ -127,10 +123,30 @@ , time , transformers , transformers-base - , unix , unliftio-core , vector - , vty + if !os(windows) + build-depends: + brick + , unix + , vty + 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 default-language: Haskell2010 executable sandwich-demo @@ -139,13 +155,22 @@ Paths_sandwich hs-source-dirs: app + default-extensions: + OverloadedStrings + QuasiQuotes + NamedFieldPuns + RecordWildCards + ScopedTypeVariables + FlexibleContexts + FlexibleInstances + LambdaCase + ViewPatterns ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: aeson , ansi-terminal , async , base <5 - , brick , bytestring , colour , containers @@ -173,10 +198,13 @@ , time , transformers , transformers-base - , unix , unliftio-core , vector - , vty + if !os(windows) + build-depends: + brick + , unix + , vty default-language: Haskell2010 executable sandwich-discover @@ -185,13 +213,22 @@ Paths_sandwich hs-source-dirs: discover + default-extensions: + OverloadedStrings + QuasiQuotes + NamedFieldPuns + RecordWildCards + ScopedTypeVariables + FlexibleContexts + FlexibleInstances + LambdaCase + ViewPatterns ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: aeson , ansi-terminal , async , base <5 - , brick , bytestring , colour , containers @@ -219,10 +256,13 @@ , time , transformers , transformers-base - , unix , unliftio-core , vector - , vty + if !os(windows) + build-depends: + brick + , unix + , vty default-language: Haskell2010 executable sandwich-test @@ -236,13 +276,22 @@ Paths_sandwich hs-source-dirs: test + default-extensions: + OverloadedStrings + QuasiQuotes + NamedFieldPuns + RecordWildCards + ScopedTypeVariables + FlexibleContexts + FlexibleInstances + LambdaCase + ViewPatterns ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: aeson , ansi-terminal , async , base <5 - , brick , bytestring , colour , containers @@ -270,10 +319,13 @@ , time , transformers , transformers-base - , unix , unliftio-core , vector - , vty + if !os(windows) + build-depends: + brick + , unix + , vty default-language: Haskell2010 test-suite sandwich-test-suite @@ -288,13 +340,22 @@ Paths_sandwich hs-source-dirs: test + default-extensions: + OverloadedStrings + QuasiQuotes + NamedFieldPuns + RecordWildCards + ScopedTypeVariables + FlexibleContexts + FlexibleInstances + LambdaCase + ViewPatterns ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: aeson , ansi-terminal , async , base <5 - , brick , bytestring , colour , containers @@ -322,8 +383,11 @@ , time , transformers , transformers-base - , unix , unliftio-core , vector - , vty + if !os(windows) + build-depends: + brick + , unix + , vty default-language: Haskell2010 diff --git a/src/Test/Sandwich.hs b/src/Test/Sandwich.hs --- a/src/Test/Sandwich.hs +++ b/src/Test/Sandwich.hs @@ -1,15 +1,8 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE FlexibleContexts #-} module Test.Sandwich ( -- | Sandwich is a test framework for Haskell. See the for details and usage examples. @@ -90,7 +83,6 @@ import qualified Options.Applicative as OA import System.Environment import System.FilePath -import System.Posix.Signals import Test.Sandwich.ArgParsing import Test.Sandwich.Contexts import Test.Sandwich.Expectations @@ -107,6 +99,7 @@ import Test.Sandwich.ParallelN import Test.Sandwich.RunTree import Test.Sandwich.Shutdown +import Test.Sandwich.Signals import Test.Sandwich.TH import Test.Sandwich.TestTimer import Test.Sandwich.Types.ArgParsing @@ -197,12 +190,12 @@ exitReasonRef <- newIORef NormalExit - let shutdown = do - putStrLn "Shutting down..." + let shutdown info = do + putStrLn [i|Shutting down due to #{info}...|] writeIORef exitReasonRef InterruptExit forM_ rts cancelNode - _ <- installHandler sigINT (Catch shutdown) Nothing + _ <- installHandler sigINT shutdown -- Wait for the tree to finish mapM_ waitForTree rts 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 @@ -1,12 +1,7 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} module Test.Sandwich.ArgParsing where @@ -23,14 +18,17 @@ 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 @@ -88,7 +86,7 @@ <$> formatter <*> logLevel <*> optional (option auto (long "visibility-threshold" <> short 'v' <> showDefault <> help "Set the visibility threshold for formatters" <> metavar "INT")) - <*> optional (strOption (long "filter" <> short 'f' <> help "Filter test tree by string matching text example labels" <> metavar "STRING")) + <*> many (strOption (long "filter" <> short 'f' <> help "Filter test tree by string matching text example labels" <> metavar "STRING")) <*> option auto (long "repeat" <> short 'r' <> showDefault <> help "Repeat the test N times and report how many failures occur" <> value 1 <> metavar "INT") <*> optional (strOption (long "fixed-root" <> help "Store test artifacts at a fixed path" <> metavar "STRING")) <*> optional (flag False True (long "dry-run" <> help "Skip actually launching the tests. This is useful if you want to see the set of the tests that would be run, or start them manually in the terminal UI.")) @@ -115,7 +113,9 @@ 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") @@ -223,7 +223,6 @@ addOptionsFromArgs baseOptions (CommandLineOptions {..}) = do let printFormatter = SomeFormatter $ defaultPrintFormatter { printFormatterLogLevel = optLogLevel } let failureReportFormatter = SomeFormatter $ defaultFailureReportFormatter { failureReportLogLevel = optLogLevel } - let tuiFormatter = SomeFormatter $ defaultTerminalUIFormatter { terminalUILogLevel = optLogLevel } let silentFormatter = SomeFormatter defaultSilentFormatter maybeMainFormatter <- case (optRepeatCount, optFormatter) of @@ -234,7 +233,9 @@ -- 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 - (_, TUI) -> return $ Just tuiFormatter +#ifndef mingw32_HOST_OS + (_, TUI) -> return $ Just $ SomeFormatter $ defaultTerminalUIFormatter { terminalUILogLevel = optLogLevel } +#endif (_, Print) -> return $ Just printFormatter (_, PrintFailures) -> return $ Just failureReportFormatter (_, Silent) -> return $ Just silentFormatter @@ -251,7 +252,9 @@ optionsTestArtifactsDirectory = case optFixedRoot of Nothing -> TestArtifactsGeneratedDirectory "test_runs" (formatTime <$> getCurrentTime) Just path -> TestArtifactsFixedDirectory path - , optionsFilterTree = TreeFilter <$> optTreeFilter + , optionsFilterTree = case optTreeFilter of + [] -> Nothing + xs -> Just $ TreeFilter xs , optionsFormatters = finalFormatters , optionsDryRun = fromMaybe (optionsDryRun baseOptions) optDryRun } @@ -262,18 +265,27 @@ 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/Contexts.hs b/src/Test/Sandwich/Contexts.hs --- a/src/Test/Sandwich/Contexts.hs +++ b/src/Test/Sandwich/Contexts.hs @@ -1,6 +1,4 @@ {-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} -- | Functions for retrieving context information from within tests. diff --git a/src/Test/Sandwich/Expectations.hs b/src/Test/Sandwich/Expectations.hs --- a/src/Test/Sandwich/Expectations.hs +++ b/src/Test/Sandwich/Expectations.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -- | Functions for making assertions about test behavior. diff --git a/src/Test/Sandwich/Formatters/Common/Count.hs b/src/Test/Sandwich/Formatters/Common/Count.hs --- a/src/Test/Sandwich/Formatters/Common/Count.hs +++ b/src/Test/Sandwich/Formatters/Common/Count.hs @@ -1,6 +1,4 @@ {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -- | module Test.Sandwich.Formatters.Common.Count where 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 @@ -1,11 +1,4 @@ -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -- | The failure report formatter is like the print formatter, but it only shows failures. -- diff --git a/src/Test/Sandwich/Formatters/LogSaver.hs b/src/Test/Sandwich/Formatters/LogSaver.hs --- a/src/Test/Sandwich/Formatters/LogSaver.hs +++ b/src/Test/Sandwich/Formatters/LogSaver.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -- | A simple formatter that saves all logs from the test to a file. -- diff --git a/src/Test/Sandwich/Formatters/MarkdownSummary.hs b/src/Test/Sandwich/Formatters/MarkdownSummary.hs --- a/src/Test/Sandwich/Formatters/MarkdownSummary.hs +++ b/src/Test/Sandwich/Formatters/MarkdownSummary.hs @@ -1,11 +1,4 @@ -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} -- | The markdown summary report formatter appends Markdown summary information to a given file. -- 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 @@ -1,9 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE MultiWayIf #-} -- | The print formatter prints all results from the test tree from top to bottom, as they become available. diff --git a/src/Test/Sandwich/Formatters/Print/CallStacks.hs b/src/Test/Sandwich/Formatters/Print/CallStacks.hs --- a/src/Test/Sandwich/Formatters/Print/CallStacks.hs +++ b/src/Test/Sandwich/Formatters/Print/CallStacks.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} module Test.Sandwich.Formatters.Print.CallStacks where diff --git a/src/Test/Sandwich/Formatters/Print/Common.hs b/src/Test/Sandwich/Formatters/Print/Common.hs --- a/src/Test/Sandwich/Formatters/Print/Common.hs +++ b/src/Test/Sandwich/Formatters/Print/Common.hs @@ -1,7 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} module Test.Sandwich.Formatters.Print.Common where 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 @@ -1,8 +1,7 @@ +{-# LANGUAGE CPP #-} + -- | Pretty printing failure reasons -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} module Test.Sandwich.Formatters.Print.FailureReason ( printFailureReason @@ -25,8 +24,10 @@ 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/Logs.hs b/src/Test/Sandwich/Formatters/Print/Logs.hs --- a/src/Test/Sandwich/Formatters/Print/Logs.hs +++ b/src/Test/Sandwich/Formatters/Print/Logs.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE LambdaCase #-} module Test.Sandwich.Formatters.Print.Logs where diff --git a/src/Test/Sandwich/Formatters/Print/PrintPretty.hs b/src/Test/Sandwich/Formatters/Print/PrintPretty.hs --- a/src/Test/Sandwich/Formatters/Print/PrintPretty.hs +++ b/src/Test/Sandwich/Formatters/Print/PrintPretty.hs @@ -1,6 +1,4 @@ -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} -{-# LANGUAGE ViewPatterns #-} module Test.Sandwich.Formatters.Print.PrintPretty ( printPretty 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 @@ -1,5 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NamedFieldPuns #-} -- | Utility functions for printing diff --git a/src/Test/Sandwich/Formatters/Print/Util.hs b/src/Test/Sandwich/Formatters/Print/Util.hs --- a/src/Test/Sandwich/Formatters/Print/Util.hs +++ b/src/Test/Sandwich/Formatters/Print/Util.hs @@ -1,6 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} module Test.Sandwich.Formatters.Print.Util where diff --git a/src/Test/Sandwich/Formatters/Silent.hs b/src/Test/Sandwich/Formatters/Silent.hs --- a/src/Test/Sandwich/Formatters/Silent.hs +++ b/src/Test/Sandwich/Formatters/Silent.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} -- | The silent formatter does nothing except print the test root folder path, if present. -- diff --git a/src/Test/Sandwich/Formatters/TerminalUI.hs b/src/Test/Sandwich/Formatters/TerminalUI.hs deleted file mode 100644 --- a/src/Test/Sandwich/Formatters/TerminalUI.hs +++ /dev/null @@ -1,451 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE ViewPatterns #-} -{-# 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/src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs b/src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs deleted file mode 100644 --- a/src/Test/Sandwich/Formatters/TerminalUI/AttrMap.hs +++ /dev/null @@ -1,213 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# 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 deleted file mode 100644 --- a/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/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs b/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs deleted file mode 100644 --- a/src/Test/Sandwich/Formatters/TerminalUI/Draw.hs +++ /dev/null @@ -1,164 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# 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/src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs b/src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs deleted file mode 100644 --- a/src/Test/Sandwich/Formatters/TerminalUI/Draw/ColorProgressBar.hs +++ /dev/null @@ -1,106 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE QuasiQuotes #-} - -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/ToBrickWidget.hs b/src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs deleted file mode 100644 --- a/src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs +++ /dev/null @@ -1,193 +0,0 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE MultiWayIf #-} - -module Test.Sandwich.Formatters.TerminalUI.Draw.ToBrickWidget where - -import Brick -import Brick.Widgets.Border -import Control.Exception.Safe -import Control.Monad.Reader -import qualified Data.List as L -import Data.Maybe -import Data.String.Interpolate -import qualified Data.Text as T -import Data.Time.Clock -import GHC.Stack -import Safe -import Test.Sandwich.Formatters.Common.Util -import Test.Sandwich.Formatters.TerminalUI.AttrMap -import Test.Sandwich.Formatters.TerminalUI.Types -import Test.Sandwich.Types.RunTree -import Test.Sandwich.Types.Spec -import Text.Show.Pretty as P - - -class ToBrickWidget a where - toBrickWidget :: a -> 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/src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs b/src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs deleted file mode 100644 --- a/src/Test/Sandwich/Formatters/TerminalUI/Draw/TopBox.hs +++ /dev/null @@ -1,181 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# 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 deleted file mode 100644 --- a/src/Test/Sandwich/Formatters/TerminalUI/Draw/Util.hs +++ /dev/null @@ -1,35 +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/src/Test/Sandwich/Formatters/TerminalUI/Filter.hs b/src/Test/Sandwich/Formatters/TerminalUI/Filter.hs deleted file mode 100644 --- a/src/Test/Sandwich/Formatters/TerminalUI/Filter.hs +++ /dev/null @@ -1,94 +0,0 @@ -{-# LANGUAGE RecordWildCards #-} -{-# 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 deleted file mode 100644 --- a/src/Test/Sandwich/Formatters/TerminalUI/Keys.hs +++ /dev/null @@ -1,56 +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/src/Test/Sandwich/Formatters/TerminalUI/OpenInEditor.hs b/src/Test/Sandwich/Formatters/TerminalUI/OpenInEditor.hs deleted file mode 100644 --- a/src/Test/Sandwich/Formatters/TerminalUI/OpenInEditor.hs +++ /dev/null @@ -1,48 +0,0 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -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 deleted file mode 100644 --- a/src/Test/Sandwich/Formatters/TerminalUI/Types.hs +++ /dev/null @@ -1,136 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# 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)) diff --git a/src/Test/Sandwich/Golden.hs b/src/Test/Sandwich/Golden.hs --- a/src/Test/Sandwich/Golden.hs +++ b/src/Test/Sandwich/Golden.hs @@ -1,8 +1,4 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE LambdaCase #-} -- This module is based on Test.Hspec.Golden from hspec-golden-0.2.0.0, which is MIT licensed. diff --git a/src/Test/Sandwich/Golden/Update.hs b/src/Test/Sandwich/Golden/Update.hs --- a/src/Test/Sandwich/Golden/Update.hs +++ b/src/Test/Sandwich/Golden/Update.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE LambdaCase #-} {-| This module is based on hgold from hspec-golden-0.2.0.0, which is MIT licensed -} diff --git a/src/Test/Sandwich/Internal/Running.hs b/src/Test/Sandwich/Internal/Running.hs --- a/src/Test/Sandwich/Internal/Running.hs +++ b/src/Test/Sandwich/Internal/Running.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE RankNTypes #-} @@ -44,7 +39,7 @@ startSandwichTree' baseContext (Options {..}) spec' = do let spec = case optionsFilterTree of Nothing -> spec' - Just (TreeFilter match) -> filterTree match spec' + Just (TreeFilter matches) -> filterTree matches spec' runTree <- atomically $ specToRunTreeVariable baseContext spec diff --git a/src/Test/Sandwich/Interpreters/FilterTree.hs b/src/Test/Sandwich/Interpreters/FilterTree.hs --- a/src/Test/Sandwich/Interpreters/FilterTree.hs +++ b/src/Test/Sandwich/Interpreters/FilterTree.hs @@ -7,32 +7,28 @@ import qualified Data.List as L import Test.Sandwich.Types.Spec -filterTree :: String -> Free (SpecCommand context m) () -> Free (SpecCommand context m) () -filterTree match (Free (It'' loc no l ex next)) - | l `matches` match = Free (It'' loc no l ex (filterTree match next)) - | otherwise = filterTree match (filterTree match next) -filterTree match (Free (Introduce'' loc no l cl alloc cleanup subspec next)) - | l `matches` match = Free (Introduce'' loc no l cl alloc cleanup subspec (filterTree match next)) - | otherwise = case filterTree match subspec of - (Pure _) -> filterTree match next - x -> Free (Introduce'' loc no l cl alloc cleanup x (filterTree match next)) -filterTree match (Free (IntroduceWith'' loc no l cl action subspec next)) - | l `matches` match = Free (IntroduceWith'' loc no l cl action subspec (filterTree match next)) - | otherwise = case filterTree match subspec of - (Pure _) -> filterTree match next - x -> Free (IntroduceWith'' loc no l cl action x (filterTree match next)) -filterTree match (Free (Parallel'' loc no subspec next)) - | otherwise = case filterTree match subspec of - (Pure _) -> filterTree match next - x -> Free (Parallel'' loc no x (filterTree match next)) -filterTree match (Free x) - | label x `matches` match = Free (x { next = (filterTree match (next x)) }) - | otherwise = case filterTree match (subspec x) of - (Pure _) -> filterTree match (next x) +filterTree :: [String] -> Free (SpecCommand context m) () -> Free (SpecCommand context m) () +filterTree matches (Free (It'' loc no l ex next)) + | all (`L.isInfixOf` l) matches = Free (It'' loc no l ex (filterTree matches next)) + | otherwise = filterTree matches (filterTree matches next) +filterTree matches (Free (Introduce'' loc no l cl alloc cleanup subspec next)) + | all (`L.isInfixOf` l) matches = Free (Introduce'' loc no l cl alloc cleanup subspec (filterTree matches next)) + | otherwise = case filterTree matches subspec of + (Pure _) -> filterTree matches next + x -> Free (Introduce'' loc no l cl alloc cleanup x (filterTree matches next)) +filterTree matches (Free (IntroduceWith'' loc no l cl action subspec next)) + | all (`L.isInfixOf` l) matches = Free (IntroduceWith'' loc no l cl action subspec (filterTree matches next)) + | otherwise = case filterTree matches subspec of + (Pure _) -> filterTree matches next + x -> Free (IntroduceWith'' loc no l cl action x (filterTree matches next)) +filterTree matches (Free (Parallel'' loc no subspec next)) = + case filterTree matches subspec of + (Pure _) -> filterTree matches next + x -> Free (Parallel'' loc no x (filterTree matches next)) +filterTree matches (Free x) + | all (`L.isInfixOf` label x) matches = Free (x { next = (filterTree matches (next x)) }) + | otherwise = case filterTree matches (subspec x) of + (Pure _) -> filterTree matches (next x) subspec' -> Free (x { subspec = subspec' - , next = (filterTree match (next x)) }) + , next = (filterTree matches (next x)) }) filterTree _ (Pure x) = Pure x - - -matches :: String -> String -> Bool -matches l match = match `L.isInfixOf` l diff --git a/src/Test/Sandwich/Interpreters/FilterTreeModule.hs b/src/Test/Sandwich/Interpreters/FilterTreeModule.hs --- a/src/Test/Sandwich/Interpreters/FilterTreeModule.hs +++ b/src/Test/Sandwich/Interpreters/FilterTreeModule.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} -- | Filter a spec tree to match a module diff --git a/src/Test/Sandwich/Interpreters/PrettyShow.hs b/src/Test/Sandwich/Interpreters/PrettyShow.hs --- a/src/Test/Sandwich/Interpreters/PrettyShow.hs +++ b/src/Test/Sandwich/Interpreters/PrettyShow.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE FlexibleInstances #-} module Test.Sandwich.Interpreters.PrettyShow (prettyShow) where diff --git a/src/Test/Sandwich/Interpreters/RunTree.hs b/src/Test/Sandwich/Interpreters/RunTree.hs --- a/src/Test/Sandwich/Interpreters/RunTree.hs +++ b/src/Test/Sandwich/Interpreters/RunTree.hs @@ -1,12 +1,6 @@ {-# LANGUAGE TupleSections #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE QuasiQuotes #-} module Test.Sandwich.Interpreters.RunTree ( specToRunTree diff --git a/src/Test/Sandwich/Interpreters/RunTree/Util.hs b/src/Test/Sandwich/Interpreters/RunTree/Util.hs --- a/src/Test/Sandwich/Interpreters/RunTree/Util.hs +++ b/src/Test/Sandwich/Interpreters/RunTree/Util.hs @@ -1,9 +1,4 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} module Test.Sandwich.Interpreters.RunTree.Util where 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,10 +1,3 @@ -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} module Test.Sandwich.Interpreters.StartTree ( startTree diff --git a/src/Test/Sandwich/Logging.hs b/src/Test/Sandwich/Logging.hs --- a/src/Test/Sandwich/Logging.hs +++ b/src/Test/Sandwich/Logging.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE CPP #-} -- | Logging functions. diff --git a/src/Test/Sandwich/ParallelN.hs b/src/Test/Sandwich/ParallelN.hs --- a/src/Test/Sandwich/ParallelN.hs +++ b/src/Test/Sandwich/ParallelN.hs @@ -1,9 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ConstraintKinds #-} -- | Wrapper around 'parallel' for limiting the threads using a semaphore. 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 @@ -1,6 +1,3 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} module Test.Sandwich.RunTree where 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 @@ -1,5 +1,3 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} module Test.Sandwich.Shutdown where diff --git a/src/Test/Sandwich/Signals.hs b/src/Test/Sandwich/Signals.hs new file mode 100644 --- /dev/null +++ b/src/Test/Sandwich/Signals.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE CPP #-} + +module Test.Sandwich.Signals ( + installHandler + , sigINT + , sigTERM + ) where + +import Foreign.C.Types + +#ifdef mingw32_HOST_OS +import Control.Exception.Base (assert) +import Foreign +#else +import Control.Monad +import qualified System.Posix.Signals as Posix +#endif + + +type Signal = CInt + +type Handler = Signal -> IO () + +sigINT :: Signal +sigINT = 2 + +sigTERM :: Signal +sigTERM = 15 + +installHandler :: Signal -> Handler -> IO () +#ifdef mingw32_HOST_OS +foreign import ccall "wrapper" + genHandler:: Handler -> IO (FunPtr Handler) + +foreign import ccall safe "signal.h signal" + install:: Signal -> FunPtr Handler -> IO Signal + +installHandler signal handler = do + result <- install signal =<< genHandler handler + return $ assert (result == 0) () +#else +installHandler signal handler = void $ Posix.installHandler signal (Posix.CatchInfo (handler . Posix.siginfoSignal)) Nothing +#endif diff --git a/src/Test/Sandwich/TH.hs b/src/Test/Sandwich/TH.hs --- a/src/Test/Sandwich/TH.hs +++ b/src/Test/Sandwich/TH.hs @@ -1,10 +1,5 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE RecordWildCards #-} module Test.Sandwich.TH ( getSpecFromFolder diff --git a/src/Test/Sandwich/TH/HasMainFunction.hs b/src/Test/Sandwich/TH/HasMainFunction.hs --- a/src/Test/Sandwich/TH/HasMainFunction.hs +++ b/src/Test/Sandwich/TH/HasMainFunction.hs @@ -1,9 +1,5 @@ -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ViewPatterns #-} module Test.Sandwich.TH.HasMainFunction ( fileHasMainFunction diff --git a/src/Test/Sandwich/TH/ModuleMap.hs b/src/Test/Sandwich/TH/ModuleMap.hs --- a/src/Test/Sandwich/TH/ModuleMap.hs +++ b/src/Test/Sandwich/TH/ModuleMap.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} module Test.Sandwich.TH.ModuleMap where diff --git a/src/Test/Sandwich/TestTimer.hs b/src/Test/Sandwich/TestTimer.hs --- a/src/Test/Sandwich/TestTimer.hs +++ b/src/Test/Sandwich/TestTimer.hs @@ -1,13 +1,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MonoLocalBinds #-} -{-# LANGUAGE NamedFieldPuns #-} module Test.Sandwich.TestTimer where 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} @@ -10,18 +9,29 @@ -- * FormatterType -data FormatterType = Print | PrintFailures | TUI | Auto | Silent +data FormatterType = + Print +#ifndef mingw32_HOST_OS + | TUI +#endif + | PrintFailures + | Auto + | Silent 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 _ _ = [] @@ -47,7 +57,7 @@ optFormatter :: FormatterType , optLogLevel :: Maybe LogLevel , optVisibilityThreshold :: Maybe Int - , optTreeFilter :: Maybe String + , optTreeFilter :: [String] , optRepeatCount :: Int , optFixedRoot :: Maybe String , optDryRun :: Maybe Bool 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 @@ -1,12 +1,9 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-} module Test.Sandwich.Types.RunTree where @@ -208,7 +205,7 @@ } -- ^ Create a new test artifacts directory under '' test artifacts directory at the given path. -newtype TreeFilter = TreeFilter String +newtype TreeFilter = TreeFilter [String] type LogFn = Loc -> LogSource -> LogLevel -> LogStr -> IO () 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 @@ -1,14 +1,10 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -35,13 +31,17 @@ import Data.String.Interpolate import GHC.Stack import GHC.TypeLits -import Graphics.Vty.Image (Image) import Safe +#ifndef mingw32_HOST_OS +import Graphics.Vty.Image (Image) +#endif + #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail #endif + -- * ExampleM monad newtype ExampleT context m a = ExampleT { unExampleT :: ReaderT context (LoggingT m) a } @@ -102,9 +102,12 @@ , 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/src/Test/Sandwich/Types/TestTimer.hs b/src/Test/Sandwich/Types/TestTimer.hs --- a/src/Test/Sandwich/Types/TestTimer.hs +++ b/src/Test/Sandwich/Types/TestTimer.hs @@ -5,10 +5,6 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} module Test.Sandwich.Types.TestTimer where diff --git a/test/Around.hs b/test/Around.hs --- a/test/Around.hs +++ b/test/Around.hs @@ -1,10 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} module Around where diff --git a/test/Before.hs b/test/Before.hs --- a/test/Before.hs +++ b/test/Before.hs @@ -1,10 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} module Before where diff --git a/test/Describe.hs b/test/Describe.hs --- a/test/Describe.hs +++ b/test/Describe.hs @@ -1,10 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} module Describe where diff --git a/test/Introduce.hs b/test/Introduce.hs --- a/test/Introduce.hs +++ b/test/Introduce.hs @@ -1,10 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} module Introduce where diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,6 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} module Main where diff --git a/test/TestUtil.hs b/test/TestUtil.hs --- a/test/TestUtil.hs +++ b/test/TestUtil.hs @@ -1,10 +1,4 @@ {-# LANGUAGE DataKinds #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} module TestUtil where diff --git a/unix-src/Test/Sandwich/Formatters/TerminalUI.hs b/unix-src/Test/Sandwich/Formatters/TerminalUI.hs new file mode 100644 --- /dev/null +++ b/unix-src/Test/Sandwich/Formatters/TerminalUI.hs @@ -0,0 +1,444 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/unix-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/unix-src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs b/unix-src/Test/Sandwich/Formatters/TerminalUI/CrossPlatform.hs new file mode 100644 --- /dev/null +++ b/unix-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/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw.hs b/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw.hs new file mode 100644 --- /dev/null +++ b/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw.hs @@ -0,0 +1,161 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/unix-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/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs b/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs new file mode 100644 --- /dev/null +++ b/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/ToBrickWidget.hs @@ -0,0 +1,189 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/unix-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/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/Util.hs b/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/Util.hs new file mode 100644 --- /dev/null +++ b/unix-src/Test/Sandwich/Formatters/TerminalUI/Draw/Util.hs @@ -0,0 +1,35 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/unix-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/unix-src/Test/Sandwich/Formatters/TerminalUI/Keys.hs b/unix-src/Test/Sandwich/Formatters/TerminalUI/Keys.hs new file mode 100644 --- /dev/null +++ b/unix-src/Test/Sandwich/Formatters/TerminalUI/Keys.hs @@ -0,0 +1,56 @@ +-- | + +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 new file mode 100644 --- /dev/null +++ b/unix-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/unix-src/Test/Sandwich/Formatters/TerminalUI/Types.hs b/unix-src/Test/Sandwich/Formatters/TerminalUI/Types.hs new file mode 100644 --- /dev/null +++ b/unix-src/Test/Sandwich/Formatters/TerminalUI/Types.hs @@ -0,0 +1,135 @@ +{-# 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))