{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE CPP #-} module Test.Sandwich.Formatters.TerminalUI.Draw where import Brick import Brick.Widgets.Border import Brick.Widgets.Center import qualified Brick.Widgets.List as L import Control.Monad import Control.Monad.Logger import Control.Monad.Reader import Data.Foldable import qualified Data.List as L import Data.Maybe import qualified Data.Sequence as Seq import Data.String.Interpolate import qualified Data.Text.Encoding as E import Data.Time.Clock import GHC.Stack import Lens.Micro import Safe import Test.Sandwich.Formatters.Common.Count import Test.Sandwich.Formatters.Common.Util import Test.Sandwich.Formatters.TerminalUI.AttrMap import Test.Sandwich.Formatters.TerminalUI.Draw.ColorProgressBar import Test.Sandwich.Formatters.TerminalUI.Draw.RunTimes import Test.Sandwich.Formatters.TerminalUI.Draw.ToBrickWidget import Test.Sandwich.Formatters.TerminalUI.Draw.TopBox import Test.Sandwich.Formatters.TerminalUI.Draw.Util import Test.Sandwich.Formatters.TerminalUI.Types import Test.Sandwich.Types.RunTree import Test.Sandwich.Types.Spec drawUI :: AppState -> [Widget ClickableName] drawUI app = [ui] where ui = vBox [ topBox app , borderWithCounts app , mainList app , clickable ColorBar $ bottomProgressBarColored app ] mainList app = hCenter $ padAll 1 $ L.renderListWithIndex listDrawElement True (app ^. appMainList) where listDrawElement ix isSelected x@(MainListElem {..}) = clickable (ListRow ix) $ padLeft (Pad (4 * depth)) $ (if isSelected then border else id) $ vBox $ catMaybes [ Just $ renderLine isSelected x , do guard toggled let infoWidgets = getInfoWidgets x guard (not $ L.null infoWidgets) return $ padLeft (Pad 4) $ fixedHeightOrViewportPercent (InnerViewport [i|viewport_#{ident}|]) 33 $ vBox infoWidgets ] renderLine _isSelected (MainListElem {..}) = hBox $ catMaybes [ Just $ withAttr openMarkerAttr $ str (if open then "[-] " else "[+] ") , Just $ withAttr (chooseAttr status) (str label) , if not (app ^. appShowFileLocations) then Nothing else case runTreeLoc node of Nothing -> Nothing Just loc -> Just $ hBox [str " [" , withAttr logFilenameAttr $ str $ srcLocFile loc , str ":" , withAttr logLineAttr $ str $ show $ srcLocStartLine loc , str "]"] , if not (app ^. appShowVisibilityThresholds) then Nothing else Just $ hBox [str " [" , withAttr visibilityThresholdIndicatorMutedAttr $ str "V=" , withAttr visibilityThresholdIndicatorAttr $ str $ show visibilityLevel , str "]"] , Just $ padRight Max $ withAttr toggleMarkerAttr $ str (if toggled then " [-]" else " [+]") , if not (app ^. appShowRunTimes) then Nothing else case status of Running {..} -> Just $ getRunTimes app statusStartTime (app ^. appCurrentTime) statusSetupTime Nothing True Done {..} -> Just $ getRunTimes app statusStartTime statusEndTime statusSetupTime statusTeardownTime False _ -> Nothing ] getInfoWidgets mle@(MainListElem {..}) = catMaybes [Just $ runReader (toBrickWidget status) (app ^. appCustomExceptionFormatters), callStackWidget mle, logWidget mle] callStackWidget (MainListElem {..}) = do cs <- getCallStackFromStatus (app ^. appCustomExceptionFormatters) status return $ borderWithLabel (padLeftRight 1 $ str "Callstack") $ runReader (toBrickWidget cs) (app ^. appCustomExceptionFormatters) logWidget (MainListElem {..}) = do let filteredLogs = case app ^. appLogLevel of Nothing -> mempty Just logLevel -> Seq.filter (\x -> logEntryLevel x >= logLevel) logs guard (not $ Seq.null filteredLogs) return $ borderWithLabel (padLeftRight 1 $ str "Logs") $ vBox $ toList $ fmap logEntryWidget filteredLogs logEntryWidget (LogEntry {..}) = hBox [ withAttr logTimestampAttr $ str (show logEntryTime) , str " " , logLevelWidget logEntryLevel , str " " , logLocWidget logEntryLoc , str " " , txtWrap (E.decodeUtf8 $ fromLogStr logEntryStr) ] logLocWidget (Loc {loc_start=(line, ch), ..}) = hBox [ str "[" , withAttr logFilenameAttr $ str loc_filename , str ":" , withAttr logLineAttr $ str (show line) , str ":" , withAttr logChAttr $ str (show ch) , str "]" ] logLevelWidget LevelDebug = withAttr debugAttr $ str "(DEBUG)" logLevelWidget LevelInfo = withAttr infoAttr $ str "(INFO)" logLevelWidget LevelWarn = withAttr infoAttr $ str "(WARN)" logLevelWidget LevelError = withAttr infoAttr $ str "(ERROR)" logLevelWidget (LevelOther x) = withAttr infoAttr $ str [i|#{x}|] borderWithCounts app = hBorderWithLabel $ padLeftRight 1 $ hBox (L.intercalate [str ", "] countWidgets <> [str [i| of |] , withAttr totalAttr $ str $ show totalNumTests , str [i| in |] , withAttr timeAttr $ str $ formatNominalDiffTime (diffUTCTime (app ^. appCurrentTime) (app ^. appStartTime))]) where countWidgets = (if totalSucceededTests > 0 then [[withAttr successAttr $ str $ show totalSucceededTests, str " succeeded"]] else mempty) <> (if totalFailedTests > 0 then [[withAttr failureAttr $ str $ show totalFailedTests, str " failed"]] else mempty) <> (if totalPendingTests > 0 then [[withAttr pendingAttr $ str $ show totalPendingTests, str " pending"]] else mempty) <> (if totalRunningTests > 0 then [[withAttr runningAttr $ str $ show totalRunningTests, str " running"]] else mempty) <> (if totalNotStartedTests > 0 then [[str $ show totalNotStartedTests, str " not started"]] else mempty) totalNumTests = countWhere isItBlock (app ^. appRunTree) totalSucceededTests = countWhere isSuccessItBlock (app ^. appRunTree) totalPendingTests = countWhere isPendingItBlock (app ^. appRunTree) totalFailedTests = countWhere isFailedItBlock (app ^. appRunTree) totalRunningTests = countWhere isRunningItBlock (app ^. appRunTree) totalNotStartedTests = countWhere isNotStartedItBlock (app ^. appRunTree) getCallStackFromStatus :: CustomExceptionFormatters -> Status -> Maybe CallStack getCallStackFromStatus cef (Done {statusResult=(Failure reason@(GotException _ _ (SomeExceptionWithEq baseException)))}) = case headMay $ catMaybes [x baseException | x <- cef] of Just (CustomTUIExceptionMessageAndCallStack _ maybeCs) -> maybeCs _ -> failureCallStack reason getCallStackFromStatus _ (Done {statusResult=(Failure reason)}) = failureCallStack reason getCallStackFromStatus _ _ = Nothing