diff options
author | Profpatsch <mail@profpatsch.de> | 2024-03-23T04·34+0100 |
---|---|---|
committer | clbot <clbot@tvl.fyi> | 2024-03-23T19·51+0000 |
commit | 0b78998509b54618ad08610e29a816336bb547be (patch) | |
tree | 2b046546e91147c044df7f966dad019124cf5628 | |
parent | 72db9eb21038b677014d3017094cfdd095f5c85c (diff) |
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>
-rw-r--r-- | users/Profpatsch/mailbox-org/mailbox-org.cabal | 1 | ||||
-rw-r--r-- | users/Profpatsch/my-prelude/default.nix | 1 | ||||
-rw-r--r-- | users/Profpatsch/my-prelude/my-prelude.cabal | 6 | ||||
-rw-r--r-- | users/Profpatsch/my-prelude/src/Pretty.hs | 108 | ||||
-rw-r--r-- | users/Profpatsch/openlab-tools/default.nix | 1 | ||||
-rw-r--r-- | users/Profpatsch/openlab-tools/openlab-tools.cabal | 1 | ||||
-rw-r--r-- | users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal | 1 |
7 files changed, 115 insertions, 4 deletions
diff --git a/users/Profpatsch/mailbox-org/mailbox-org.cabal b/users/Profpatsch/mailbox-org/mailbox-org.cabal index 8e5328907a9e..a1b041447bbb 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 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] diff --git a/users/Profpatsch/openlab-tools/default.nix b/users/Profpatsch/openlab-tools/default.nix index 0e4aa3ebfa96..82641989f7a0 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 461c53776746..b7d217e051a9 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 5f1e4246c022..672199600d32 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, |