feat(users/Profpatsch/MyPrelude): add Pretty module
Change-Id: Id774963178ba358447699d0297a6a1fbef5ac8fe Reviewed-on: https://cl.tvl.fyi/c/depot/+/11240 Autosubmit: Profpatsch <mail@profpatsch.de> Tested-by: BuildkiteCI Reviewed-by: Profpatsch <mail@profpatsch.de>
This commit is contained in:
parent
72db9eb210
commit
0b78998509
7 changed files with 115 additions and 4 deletions
|
@ -79,7 +79,6 @@ executable mailbox-org
|
||||||
my-prelude,
|
my-prelude,
|
||||||
pa-prelude,
|
pa-prelude,
|
||||||
pa-label,
|
pa-label,
|
||||||
pa-pretty,
|
|
||||||
pa-error-tree,
|
pa-error-tree,
|
||||||
exec-helpers,
|
exec-helpers,
|
||||||
netencode,
|
netencode,
|
||||||
|
|
|
@ -11,6 +11,7 @@ pkgs.haskellPackages.mkDerivation {
|
||||||
./src/MyPrelude.hs
|
./src/MyPrelude.hs
|
||||||
./src/Test.hs
|
./src/Test.hs
|
||||||
./src/Parse.hs
|
./src/Parse.hs
|
||||||
|
./src/Pretty.hs
|
||||||
./src/Seconds.hs
|
./src/Seconds.hs
|
||||||
./src/Tool.hs
|
./src/Tool.hs
|
||||||
./src/ValidationParseT.hs
|
./src/ValidationParseT.hs
|
||||||
|
|
|
@ -65,6 +65,7 @@ library
|
||||||
Postgres.MonadPostgres
|
Postgres.MonadPostgres
|
||||||
ValidationParseT
|
ValidationParseT
|
||||||
Parse
|
Parse
|
||||||
|
Pretty
|
||||||
Seconds
|
Seconds
|
||||||
Tool
|
Tool
|
||||||
|
|
||||||
|
@ -112,3 +113,8 @@ library
|
||||||
, validation-selective
|
, validation-selective
|
||||||
, vector
|
, vector
|
||||||
, ghc-boot
|
, ghc-boot
|
||||||
|
-- for Pretty
|
||||||
|
, aeson-pretty
|
||||||
|
, hscolour
|
||||||
|
, ansi-terminal
|
||||||
|
, nicify-lib
|
||||||
|
|
108
users/Profpatsch/my-prelude/src/Pretty.hs
Normal file
108
users/Profpatsch/my-prelude/src/Pretty.hs
Normal file
|
@ -0,0 +1,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]
|
|
@ -21,7 +21,6 @@ let
|
||||||
pkgs.haskellPackages.pa-json
|
pkgs.haskellPackages.pa-json
|
||||||
pkgs.haskellPackages.pa-error-tree
|
pkgs.haskellPackages.pa-error-tree
|
||||||
pkgs.haskellPackages.pa-field-parser
|
pkgs.haskellPackages.pa-field-parser
|
||||||
pkgs.haskellPackages.pa-pretty
|
|
||||||
pkgs.haskellPackages.pa-run-command
|
pkgs.haskellPackages.pa-run-command
|
||||||
pkgs.haskellPackages.aeson-better-errors
|
pkgs.haskellPackages.aeson-better-errors
|
||||||
pkgs.haskellPackages.blaze-html
|
pkgs.haskellPackages.blaze-html
|
||||||
|
|
|
@ -69,7 +69,6 @@ library
|
||||||
pa-label,
|
pa-label,
|
||||||
pa-json,
|
pa-json,
|
||||||
pa-field-parser,
|
pa-field-parser,
|
||||||
pa-pretty,
|
|
||||||
pa-run-command,
|
pa-run-command,
|
||||||
aeson-better-errors,
|
aeson-better-errors,
|
||||||
aeson,
|
aeson,
|
||||||
|
|
|
@ -80,7 +80,6 @@ library
|
||||||
pa-label,
|
pa-label,
|
||||||
pa-json,
|
pa-json,
|
||||||
pa-field-parser,
|
pa-field-parser,
|
||||||
pa-pretty,
|
|
||||||
pa-run-command,
|
pa-run-command,
|
||||||
aeson-better-errors,
|
aeson-better-errors,
|
||||||
aeson,
|
aeson,
|
||||||
|
|
Loading…
Reference in a new issue