patrickaldis/garnet
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Justify test time to right of terminal

Browse Source
This commit is contained in:
George Thomas 2026-01-06 22:52:43 +00:00
parent 2eecc653b8
commit 98acc016a6
2 changed files with 18 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
haskell/Main.hs
View File

@ -16,11 +16,14 @@ import Puzzles.Day6 qualified as Day6
import Puzzles.Day7 qualified as Day7 import Puzzles.Day7 qualified as Day7
import Puzzles.Day8 qualified as Day8 import Puzzles.Day8 qualified as Day8
import Puzzles.Day9 qualified as Day9 import Puzzles.Day9 qualified as Day9
import System.Console.ANSI (getTerminalSize)
main :: IO () main :: IO ()
main = do main = do
-- terminalWidth <- fmap snd <$> getTerminalSize -- TODO this doesn't work in GHCID or GHCIWatch...
terminalWidth <- pure $ Just 60
putStrLn $ drawTree $ show <$> getTestTree tests putStrLn $ drawTree $ show <$> getTestTree tests
TL.putStrLn . displayTestResultsConsole =<< runTests () tests TL.putStrLn . displayTestResultsConsole terminalWidth =<< runTests () tests
tests :: TestTree IO () tests :: TestTree IO ()
tests = tests =

21
haskell/Pre.hs
View File

@ -279,23 +279,23 @@ instance Show SomeExceptionLegalShow where
getTestTree :: TestTree m r -> Tree TestName getTestTree :: TestTree m r -> Tree TestName
getTestTree (TestTree name _ ts) = Node name $ map getTestTree ts getTestTree (TestTree name _ ts) = Node name $ map getTestTree ts
displayTestResultsConsole :: TestResult -> TL.Text displayTestResultsConsole :: Maybe Int -> TestResult -> TL.Text
displayTestResultsConsole testResult = displayTestResultsConsole terminalWidth testResult =
displayResult 0 testResult <> TL.pack (setSGRCode [Reset]) displayResult 0 testResult <> TL.pack (setSGRCode [Reset])
where where
displayResult indent = displayResult indent =
(TL.replicate indent " " <>) . \case (TL.replicate (fromIntegral indent) " " <>) . \case
Pass (TestName name) dt children -> Pass (TestName name) dt children ->
TL.fromStrict (header Green '✓' name (Just dt)) TL.fromStrict (header Green '✓' name indent (Just dt))
<> TL.concat (map (displayResult (indent + 1)) children) <> TL.concat (map (displayResult (indent + 1)) children)
Fail (TestName name) (SomeExceptionLegalShow e) -> Fail (TestName name) (SomeExceptionLegalShow e) ->
TL.fromStrict TL.fromStrict
( header Red '✗' name Nothing ( header Red '✗' name indent Nothing
<> setColour Vivid Red <> setColour Vivid Red
) )
<> TL.show e <> TL.show e
<> "\n" <> "\n"
header colour icon name time = header colour icon name indent time =
setColour Vivid colour setColour Vivid colour
<> T.singleton icon <> T.singleton icon
<> " " <> " "
@ -304,7 +304,14 @@ displayTestResultsConsole testResult =
<> maybe <> maybe
mempty mempty
( \_t@(showTime -> tt) -> ( \_t@(showTime -> tt) ->
" " T.replicate
( fromIntegral $
maybe
3
(\n -> n - (2 * indent + length name + T.length tt + 2))
terminalWidth
)
" "
<> setColour Dull Black <> setColour Dull Black
<> tt <> tt
) )