0 | module Test.Async.Spec.Report
  1 |
  2 | import Data.Linear.Ref1
  3 | import Data.String
  4 | import Derive.Prelude
  5 | import Test.Async.Spec.TestEnv
  6 | import Test.Async.Spec.TestResult
  7 | import Text.PrettyPrint.Bernardy.ANSI
  8 | import Text.Show.Diff
  9 |
 10 | %language ElabReflection
 11 | %default total
 12 |
 13 | public export
 14 | data Markup =
 15 |     FailedIcon
 16 |   | FailedText
 17 |   | SuccessIcon
 18 |   | SuccessText
 19 |   | Summary
 20 |   | Title Nat
 21 |   | DiffRemoved
 22 |   | DiffAdded
 23 |   | NoMarkup
 24 |
 25 | %runElab derive "Markup" [Show,Eq,Ord]
 26 |
 27 | color : Color -> List SGR
 28 | color c = [SetForeground c]
 29 |
 30 | toAnsi : Markup -> List SGR
 31 | toAnsi Summary      = color Blue
 32 | toAnsi (Title 0)    = color Blue
 33 | toAnsi (Title _)    = color BrightBlue
 34 | toAnsi DiffAdded    = color Green
 35 | toAnsi DiffRemoved  = color Red
 36 | toAnsi FailedIcon   = color BrightRed
 37 | toAnsi FailedText   = color BrightRed
 38 | toAnsi SuccessIcon  = color Green
 39 | toAnsi SuccessText  = color Green
 40 | toAnsi NoMarkup     = []
 41 |
 42 | testCount : Nat -> String
 43 | testCount 1 = "1 test"
 44 | testCount n = "\{show n} tests"
 45 |
 46 | parameters {auto te : TestEnv}
 47 |
 48 |   markup : Markup -> Doc te.layout -> Doc te.layout
 49 |   markup m d = case te.useColor of
 50 |     False => d
 51 |     True  => decorate (toAnsi m) d
 52 |
 53 |   %inline markupLine : Markup -> String -> Doc te.layout
 54 |   markupLine m = markup m . line
 55 |
 56 |   icon : Markup -> Char -> Doc te.layout -> Doc te.layout
 57 |   icon m i x = markup m (symbol i) <++> x
 58 |
 59 |   lineDiff : LineDiff -> Doc te.layout
 60 |   lineDiff (LineSame x)    = "  " <+> pretty x
 61 |   lineDiff (LineRemoved x) = markup DiffRemoved $ "- " <+> pretty x
 62 |   lineDiff (LineAdded x)   = markup DiffAdded   $ "+ " <+> pretty x
 63 |
 64 |   diff : Diff -> List (Doc te.layout)
 65 |   diff (MkDiff pre removed inf added suffix df) =
 66 |     ( markup NoMarkup    (line pre)     <+>
 67 |       markup DiffRemoved (line removed) <+>
 68 |       markup NoMarkup    (line inf)     <+>
 69 |       markup DiffAdded   (line added)   <+>
 70 |       markup NoMarkup    (line suffix)
 71 |     ) :: map lineDiff (toLineDiff df)
 72 |
 73 |   textLines : String -> List (Doc te.layout)
 74 |   textLines = map line . lines
 75 |
 76 |   printDoc : HasIO io => Doc te.layout -> io ()
 77 |   printDoc doc = do
 78 |     dpt <- runIO (read1 te.depth)
 79 |     putStr $ renderDoc $ indent (dpt * 2) doc
 80 |
 81 |   export
 82 |   fail : HasIO io => (desc : String) -> Maybe Diff -> String -> io ()
 83 |   fail desc md msg = Prelude.do
 84 |     addFailure
 85 |     addTest
 86 |     printDoc . vsep $
 87 |       [ icon FailedIcon '✗' (markup FailedText (vsep $ textLines desc))
 88 |       , indent 2 $ vsep $
 89 |           map (markup FailedText) (textLines msg) ++ maybe [] diff md
 90 |       ]
 91 |
 92 | export
 93 | succeeded : HasIO io => (te : TestEnv) => (desc : String) -> io ()
 94 | succeeded desc = do
 95 |   addTest
 96 |   printDoc $
 97 |     icon SuccessIcon '✓' (markup SuccessText (vsep $ textLines desc))
 98 |
 99 | export
100 | report : HasIO io => TestEnv => (desc : String) -> TestResult -> io ()
101 | report desc (Failure md msg) = fail desc md msg
102 | report desc Success          = succeeded desc
103 |
104 | export
105 | summary : HasIO io => TestEnv => (ts,fs : Nat) -> io ()
106 | summary ts 0 = printDoc $ markup Summary (line "\{testCount ts} passed")
107 | summary ts n =
108 |   printDoc $ markup FailedText (line "\{show n} of \{testCount ts} failed")
109 |
110 | export
111 | printName : HasIO io => (te : TestEnv) => String -> io ()
112 | printName str = do
113 |   n <- runIO (read1 te.depth)
114 |   printDoc . markup (Title n) . vsep $ textLines str
115 |