module Pretty
  ( -- * Pretty printing for error messages
    Err,
    showPretty,
    showPrettyJson,
    printPretty,
    -- 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 :: forall a. Show a => a -> IO ()
printPretty a
a =
  a
a forall a b. a -> (a -> b) -> b
& forall a. Show a => a -> Text
showPretty forall a b. a -> (a -> b) -> b
& Text -> IO ()
putStderrLn

showPretty :: Show a => a -> Text
showPretty :: forall a. Show a => a -> Text
showPretty a
a = a
a forall a b. a -> (a -> b) -> b
& forall a. Show a => a -> Err
pretty forall a b. a -> (a -> b) -> b
& (forall a. a -> [a] -> [a]
: []) forall a b. a -> (a -> b) -> b
& [Err] -> String
prettyErrs forall a b. a -> (a -> b) -> b
& String -> Text
stringToText

showPrettyJson :: Json.Value -> Text
showPrettyJson :: Value -> Text
showPrettyJson Value
val =
  Value
val
    forall a b. a -> (a -> b) -> b
& forall a. ToJSON a => a -> Builder
Aeson.Pretty.encodePrettyToTextBuilder
    forall a b. a -> (a -> b) -> b
& Builder -> Text
Text.Builder.toLazyText
    forall a b. a -> (a -> b) -> b
& Text -> Text
toStrict

-- | Display a list of 'Err's as a colored error message
-- and abort the test.
prettyErrs :: [Err] -> String
prettyErrs :: [Err] -> String
prettyErrs [Err]
errs = String
res
  where
    res :: String
res = forall a. [a] -> [[a]] -> [a]
List.intercalate String
"\n" forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Err -> String
one [Err]
errs
    one :: Err -> String
one = \case
      ErrMsg String
s -> Color -> String -> String
color Color
Red String
s
      ErrPrettyString String
s -> String -> String
prettyShowString String
s
    -- Pretty print a String that was produced by 'show'
    prettyShowString :: String -> String
    prettyShowString :: String -> String
prettyShowString = String -> String
hscolour' forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
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 :: Text -> Err
message = String -> Err
ErrMsg forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
textToString

-- | Plain message to display, as 'String'
messageString :: String -> Err
messageString :: String -> Err
messageString = String -> Err
ErrMsg

-- | Any 'Show'able to pretty print
pretty :: Show a => a -> Err
pretty :: forall a. Show a => a -> Err
pretty a
x = String -> Err
ErrPrettyString forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show a
x

-- | Pretty print a String that was produced by 'show'
prettyString :: String -> Err
prettyString :: String -> Err
prettyString String
s = String -> Err
ErrPrettyString String
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' :: String -> String
hscolour' =
  Output
-> ColourPrefs
-> Bool
-> Bool
-> String
-> Bool
-> String
-> String
hscolour (TerminalType -> Output
TTYg TerminalType
Ansi16Colour) ColourPrefs
defaultColourPrefs Bool
False Bool
False String
"" Bool
False

color :: Color -> String -> String
color :: Color -> String -> String
color Color
c String
s = [SGR] -> String
setSGRCode [ConsoleLayer -> ColorIntensity -> Color -> SGR
SetColor ConsoleLayer
Foreground ColorIntensity
Dull Color
c] forall a. [a] -> [a] -> [a]
++ String
s forall a. [a] -> [a] -> [a]
++ [SGR] -> String
setSGRCode [SGR
Reset]