{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module Control.Teardown.Internal.Printer where
import RIO hiding ((<>))
import Data.Typeable (typeOf)
import qualified RIO.Text as Text
import Data.Text.Prettyprint.Doc
import Control.Teardown.Internal.Types
treeTrunk :: Int -> Int -> Doc ann
treeTrunk start level = hcat (map (\_ -> " ") [1 .. start])
<> hcat (map (\_ -> " |") [start .. level - 1])
prettyTeardownResult :: TeardownResult -> Doc ann
prettyTeardownResult result = render 0 0 result <> hardline
where
renderError start level (SomeException err) =
let
(fstErrLine, errLines) = case Text.lines (tshow err) of
[] ->
error "Expecting reported error to have a line of content, got none"
(fstErrLine' : errLines') -> (fstErrLine', errLines')
errorReport =
treeTrunk (start - 1) (level + 1)
<> ">"
<> indent 2 (pretty (show (typeOf err)) <> ":")
<+> pretty (Text.unpack fstErrLine)
: map
(\l -> treeTrunk (start - 1) (level + 1) <> ">" <> indent
2
(pretty $ Text.unpack l)
)
errLines
in
vcat errorReport
renderTree start level disposeResults = case disposeResults of
[] -> mempty
[lastResult] ->
treeTrunk start (level + 1) <> render (start + 1) (level + 1) lastResult
(r : results) ->
treeTrunk start (level + 1)
<> render start (level + 1) r
<> hardline
<> renderTree start level results
render start level disposeResult = case disposeResult of
EmptyResult desc ->
"`-" <+> "✓" <+> pretty (Text.unpack desc) <+> "(empty)"
LeafResult desc elapsed Nothing ->
"`-" <+> "✓" <+> pretty (Text.unpack desc) <+> pretty
("(" <> show elapsed <> ")")
LeafResult desc elapsed (Just err) ->
"`-"
<+> "✘"
<+> pretty (Text.unpack desc)
<+> pretty ("(" <> show elapsed <> ")")
<> hardline
<> renderError start level err
BranchResult desc elapsed didFail results -> vcat
[ "`-"
<+> (if didFail then "✘" else "✓")
<+> pretty (Text.unpack desc)
<+> parens (pretty $ show elapsed)
, renderTree start level results
]