From 0b78998509b54618ad08610e29a816336bb547be Mon Sep 17 00:00:00 2001 From: Profpatsch Date: Sat, 23 Mar 2024 05:34:13 +0100 Subject: feat(users/Profpatsch/MyPrelude): add Pretty module Change-Id: Id774963178ba358447699d0297a6a1fbef5ac8fe Reviewed-on: https://cl.tvl.fyi/c/depot/+/11240 Autosubmit: Profpatsch Tested-by: BuildkiteCI Reviewed-by: Profpatsch --- users/Profpatsch/mailbox-org/mailbox-org.cabal | 1 - users/Profpatsch/my-prelude/default.nix | 1 + users/Profpatsch/my-prelude/my-prelude.cabal | 6 ++ users/Profpatsch/my-prelude/src/Pretty.hs | 108 +++++++++++++++++++++ users/Profpatsch/openlab-tools/default.nix | 1 - users/Profpatsch/openlab-tools/openlab-tools.cabal | 1 - .../whatcd-resolver/whatcd-resolver.cabal | 1 - 7 files changed, 115 insertions(+), 4 deletions(-) create mode 100644 users/Profpatsch/my-prelude/src/Pretty.hs diff --git a/users/Profpatsch/mailbox-org/mailbox-org.cabal b/users/Profpatsch/mailbox-org/mailbox-org.cabal index 8e5328907a..a1b041447b 100644 --- a/users/Profpatsch/mailbox-org/mailbox-org.cabal +++ b/users/Profpatsch/mailbox-org/mailbox-org.cabal @@ -79,7 +79,6 @@ executable mailbox-org my-prelude, pa-prelude, pa-label, - pa-pretty, pa-error-tree, exec-helpers, netencode, diff --git a/users/Profpatsch/my-prelude/default.nix b/users/Profpatsch/my-prelude/default.nix index 1f68cfd16e..e445115416 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 49746cd432..95a8399f37 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 0000000000..d9d4ce132b --- /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] diff --git a/users/Profpatsch/openlab-tools/default.nix b/users/Profpatsch/openlab-tools/default.nix index 0e4aa3ebfa..82641989f7 100644 --- a/users/Profpatsch/openlab-tools/default.nix +++ b/users/Profpatsch/openlab-tools/default.nix @@ -21,7 +21,6 @@ let pkgs.haskellPackages.pa-json pkgs.haskellPackages.pa-error-tree pkgs.haskellPackages.pa-field-parser - pkgs.haskellPackages.pa-pretty pkgs.haskellPackages.pa-run-command pkgs.haskellPackages.aeson-better-errors pkgs.haskellPackages.blaze-html diff --git a/users/Profpatsch/openlab-tools/openlab-tools.cabal b/users/Profpatsch/openlab-tools/openlab-tools.cabal index 461c537767..b7d217e051 100644 --- a/users/Profpatsch/openlab-tools/openlab-tools.cabal +++ b/users/Profpatsch/openlab-tools/openlab-tools.cabal @@ -69,7 +69,6 @@ library pa-label, pa-json, pa-field-parser, - pa-pretty, pa-run-command, aeson-better-errors, aeson, diff --git a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal index 5f1e4246c0..672199600d 100644 --- a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal +++ b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal @@ -80,7 +80,6 @@ library pa-label, pa-json, pa-field-parser, - pa-pretty, pa-run-command, aeson-better-errors, aeson, -- cgit 1.4.1