1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
|
module Pretty
( -- * Pretty printing for error messages
Err,
showPretty,
showPrettyJson,
showedStringPretty,
printPretty,
printShowedStringPretty,
-- constructors hidden
prettyErrs,
message,
messageString,
pretty,
prettyString,
hscolour',
)
where
import Data.Aeson qualified as Json
import Data.Aeson.Encode.Pretty qualified as Aeson.Pretty
import Data.List qualified as List
import Data.Text.Lazy.Builder qualified as Text.Builder
import Language.Haskell.HsColour
( Output (TTYg),
hscolour,
)
import Language.Haskell.HsColour.ANSI (TerminalType (..))
import Language.Haskell.HsColour.Colourise
( defaultColourPrefs,
)
import PossehlAnalyticsPrelude
import System.Console.ANSI (setSGRCode)
import System.Console.ANSI.Types
( Color (Red),
ColorIntensity (Dull),
ConsoleLayer (Foreground),
SGR (Reset, SetColor),
)
import Text.Nicify (nicify)
-- | Print any 'Show'able type to stderr, formatted nicely and in color. Very helpful for debugging.
printPretty :: (Show a) => a -> IO ()
printPretty a =
a & showPretty & putStderrLn
showPretty :: (Show a) => a -> Text
showPretty a = a & pretty & (: []) & prettyErrs & stringToText
-- | Pretty-print a string that was produced by `show` to stderr, formatted nicely and in color.
printShowedStringPretty :: String -> IO ()
printShowedStringPretty s = s & showedStringPretty & putStderrLn
-- | Pretty-print a string that was produced by `show`
showedStringPretty :: String -> Text
showedStringPretty s = s & ErrPrettyString & (: []) & prettyErrs & stringToText
showPrettyJson :: Json.Value -> Text
showPrettyJson val =
val
& Aeson.Pretty.encodePrettyToTextBuilder
& Text.Builder.toLazyText
& toStrict
-- | Display a list of 'Err's as a colored error message
-- and abort the test.
prettyErrs :: [Err] -> String
prettyErrs errs = res
where
res = List.intercalate "\n" $ map one errs
one = \case
ErrMsg s -> color Red s
ErrPrettyString s -> prettyShowString s
-- Pretty print a String that was produced by 'show'
prettyShowString :: String -> String
prettyShowString = hscolour' . nicify
-- | Small DSL for pretty-printing errors
data Err
= -- | Message to display in the error
ErrMsg String
| -- | Pretty print a String that was produced by 'show'
ErrPrettyString String
-- | Plain message to display, as 'Text'
message :: Text -> Err
message = ErrMsg . textToString
-- | Plain message to display, as 'String'
messageString :: String -> Err
messageString = ErrMsg
-- | Any 'Show'able to pretty print
pretty :: (Show a) => a -> Err
pretty x = ErrPrettyString $ show x
-- | Pretty print a String that was produced by 'show'
prettyString :: String -> Err
prettyString s = ErrPrettyString s
-- Prettifying Helpers, mostly stolen from
-- https://hackage.haskell.org/package/hspec-expectations-pretty-diff-0.7.2.5/docs/src/Test.Hspec.Expectations.Pretty.html#prettyColor
hscolour' :: String -> String
hscolour' =
hscolour (TTYg Ansi16Colour) defaultColourPrefs False False "" False
color :: Color -> String -> String
color c s = setSGRCode [SetColor Foreground Dull c] ++ s ++ setSGRCode [Reset]
|
