feat(users/Profpatsch/MyPrelude): add Pretty module r/7765

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>

3 files changed, 115 insertions, 0 deletions

diff --git a/users/Profpatsch/my-prelude/default.nix b/users/Profpatsch/my-prelude/default.nix
index 1f68cfd16e75..e44511541642 100644
--- a/users/Profpatsch/my-prelude/default.nix
+++ b/users/Profpatsch/my-prelude/default.nix
@@ -11,6 +11,7 @@ pkgs.haskellPackages.mkDerivation {
     ./src/MyPrelude.hs
     ./src/Test.hs
     ./src/Parse.hs
+    ./src/Pretty.hs
     ./src/Seconds.hs
     ./src/Tool.hs
     ./src/ValidationParseT.hs
diff --git a/users/Profpatsch/my-prelude/my-prelude.cabal b/users/Profpatsch/my-prelude/my-prelude.cabal
index 49746cd432c7..95a8399f370f 100644
--- a/users/Profpatsch/my-prelude/my-prelude.cabal
+++ b/users/Profpatsch/my-prelude/my-prelude.cabal
@@ -65,6 +65,7 @@ library
       Postgres.MonadPostgres
       ValidationParseT
       Parse
+      Pretty
       Seconds
       Tool
 
@@ -112,3 +113,8 @@ library
      , validation-selective
      , vector
      , ghc-boot
+     -- for Pretty
+     , aeson-pretty
+     , hscolour
+     , ansi-terminal
+     , nicify-lib
diff --git a/users/Profpatsch/my-prelude/src/Pretty.hs b/users/Profpatsch/my-prelude/src/Pretty.hs
new file mode 100644
index 000000000000..d9d4ce132b11
--- /dev/null
+++ b/users/Profpatsch/my-prelude/src/Pretty.hs
@@ -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]