-- | Utilities to pretty print 'Expr' and 'EditExpr'
module Test.StateMachine.TreeDiff.Pretty (
    -- * Explicit dictionary
    Pretty (..),
    ppExpr,
    ppEditExpr,
    ppEditExprCompact,
    -- * pretty
    prettyPretty,
    prettyExpr,
    prettyEditExpr,
    prettyEditExprCompact,
    -- * ansi-wl-pprint
    ansiWlPretty,
    ansiWlExpr,
    ansiWlEditExpr,
    ansiWlEditExprCompact,
    -- ** background
    ansiWlBgPretty,
    ansiWlBgExpr,
    ansiWlBgEditExpr,
    ansiWlBgEditExprCompact,
    -- * Utilities
    escapeName,
    ) where

import           Data.Char
                   (isAlphaNum, isPunctuation, isSymbol, ord)
import           Data.Either
                   (partitionEithers)
import           Numeric
                   (showHex)
import           Test.StateMachine.TreeDiff.Expr
import           Text.Read
                   (readMaybe)


import qualified Data.Map                        as Map
import qualified Text.PrettyPrint                as HJ
import qualified Text.PrettyPrint.ANSI.Leijen    as WL

-- | Because we don't want to commit to single pretty printing library,
-- we use explicit dictionary.
data Pretty doc = Pretty
    { forall doc. Pretty doc -> ConstructorName -> doc
ppCon    :: ConstructorName -> doc
    , forall doc. Pretty doc -> [(ConstructorName, doc)] -> doc
ppRec    :: [(FieldName, doc)] -> doc
    , forall doc. Pretty doc -> [doc] -> doc
ppLst    :: [doc] -> doc
    , forall doc. Pretty doc -> doc -> doc
ppCpy    :: doc -> doc
    , forall doc. Pretty doc -> doc -> doc
ppIns    :: doc -> doc
    , forall doc. Pretty doc -> doc -> doc
ppDel    :: doc -> doc
    , forall doc. Pretty doc -> [doc] -> doc
ppSep    :: [doc] -> doc
    , forall doc. Pretty doc -> doc -> doc
ppParens :: doc -> doc
    , forall doc. Pretty doc -> doc -> doc -> doc
ppHang   :: doc -> doc -> doc
    }

-- | Escape field or constructor name
--
-- >>> putStrLn $ escapeName "Foo"
-- Foo
--
-- >>> putStrLn $ escapeName "_×_"
-- _×_
--
-- >>> putStrLn $ escapeName "-3"
-- `-3`
--
-- >>> putStrLn $ escapeName "kebab-case"
-- kebab-case
--
-- >>> putStrLn $ escapeName "inner space"
-- `inner space`
--
-- >>> putStrLn $ escapeName $ show "looks like a string"
-- "looks like a string"
--
-- >>> putStrLn $ escapeName $ show "tricky" ++ "   "
-- `"tricky"   `
--
-- >>> putStrLn $ escapeName "[]"
-- `[]`
--
-- >>> putStrLn $ escapeName "_,_"
-- `_,_`
--
escapeName :: String -> String
escapeName :: ConstructorName -> ConstructorName
escapeName ConstructorName
n
    | ConstructorName -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ConstructorName
n                      = ConstructorName
"``"
    | ConstructorName -> Bool
isValidString ConstructorName
n             = ConstructorName
n
    | (Char -> Bool) -> ConstructorName -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
valid' ConstructorName
n Bool -> Bool -> Bool
&& ConstructorName -> Bool
headNotMP ConstructorName
n = ConstructorName
n
    | Bool
otherwise                   = ConstructorName
"`" ConstructorName -> ConstructorName -> ConstructorName
forall a. [a] -> [a] -> [a]
++ (Char -> ConstructorName) -> ConstructorName -> ConstructorName
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Char -> ConstructorName
e ConstructorName
n ConstructorName -> ConstructorName -> ConstructorName
forall a. [a] -> [a] -> [a]
++ ConstructorName
"`"
  where
    e :: Char -> ConstructorName
e Char
'`'               = ConstructorName
"\\`"
    e Char
'\\'              = ConstructorName
"\\\\"
    e Char
' '               = ConstructorName
" "
    e Char
c | Bool -> Bool
not (Char -> Bool
valid Char
c) = ConstructorName
"\\x" ConstructorName -> ConstructorName -> ConstructorName
forall a. [a] -> [a] -> [a]
++ Int -> ConstructorName -> ConstructorName
forall a. Integral a => a -> ConstructorName -> ConstructorName
showHex (Char -> Int
ord Char
c) ConstructorName
";"
    e Char
c                 = [Char
c]

    valid :: Char -> Bool
valid Char
c = Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char -> Bool
isSymbol Char
c Bool -> Bool -> Bool
|| Char -> Bool
isPunctuation Char
c
    valid' :: Char -> Bool
valid' Char
c = Char -> Bool
valid Char
c Bool -> Bool -> Bool
&& Char
c Char -> ConstructorName -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` ConstructorName
"[](){}`\","

    headNotMP :: ConstructorName -> Bool
headNotMP (Char
'-' : ConstructorName
_) = Bool
False
    headNotMP (Char
'+' : ConstructorName
_) = Bool
False
    headNotMP ConstructorName
_         = Bool
True

    isValidString :: ConstructorName -> Bool
isValidString ConstructorName
s
        | ConstructorName -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ConstructorName
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
2 Bool -> Bool -> Bool
&& ConstructorName -> Char
forall a. HasCallStack => [a] -> a
head ConstructorName
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' Bool -> Bool -> Bool
&& ConstructorName -> Char
forall a. HasCallStack => [a] -> a
last ConstructorName
s Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'"' =
            case ConstructorName -> Maybe ConstructorName
forall a. Read a => ConstructorName -> Maybe a
readMaybe ConstructorName
s :: Maybe String of
                Just ConstructorName
_  -> Bool
True
                Maybe ConstructorName
Nothing -> Bool
False
    isValidString ConstructorName
_         = Bool
False

-- | Pretty print an 'Expr' using explicit pretty-printing dictionary.
ppExpr :: Pretty doc -> Expr -> doc
ppExpr :: forall doc. Pretty doc -> Expr -> doc
ppExpr Pretty doc
p = Pretty doc -> Bool -> Expr -> doc
forall doc. Pretty doc -> Bool -> Expr -> doc
ppExpr' Pretty doc
p Bool
False

ppExpr' :: Pretty doc -> Bool -> Expr -> doc
ppExpr' :: forall doc. Pretty doc -> Bool -> Expr -> doc
ppExpr' Pretty doc
p = Bool -> Expr -> doc
impl where
    impl :: Bool -> Expr -> doc
impl Bool
_ (App ConstructorName
x []) = Pretty doc -> ConstructorName -> doc
forall doc. Pretty doc -> ConstructorName -> doc
ppCon Pretty doc
p (ConstructorName -> ConstructorName
escapeName ConstructorName
x)
    impl Bool
b (App ConstructorName
x [Expr]
xs) = Bool -> doc -> doc
ppParens' Bool
b (doc -> doc) -> doc -> doc
forall a b. (a -> b) -> a -> b
$ Pretty doc -> doc -> doc -> doc
forall doc. Pretty doc -> doc -> doc -> doc
ppHang Pretty doc
p (Pretty doc -> ConstructorName -> doc
forall doc. Pretty doc -> ConstructorName -> doc
ppCon Pretty doc
p (ConstructorName -> ConstructorName
escapeName ConstructorName
x)) (doc -> doc) -> doc -> doc
forall a b. (a -> b) -> a -> b
$
        Pretty doc -> [doc] -> doc
forall doc. Pretty doc -> [doc] -> doc
ppSep Pretty doc
p ([doc] -> doc) -> [doc] -> doc
forall a b. (a -> b) -> a -> b
$ (Expr -> doc) -> [Expr] -> [doc]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Expr -> doc
impl Bool
True) [Expr]
xs
    impl Bool
_ (Rec ConstructorName
x Map ConstructorName Expr
xs) = Pretty doc -> doc -> doc -> doc
forall doc. Pretty doc -> doc -> doc -> doc
ppHang Pretty doc
p (Pretty doc -> ConstructorName -> doc
forall doc. Pretty doc -> ConstructorName -> doc
ppCon Pretty doc
p (ConstructorName -> ConstructorName
escapeName ConstructorName
x)) (doc -> doc) -> doc -> doc
forall a b. (a -> b) -> a -> b
$ Pretty doc -> [(ConstructorName, doc)] -> doc
forall doc. Pretty doc -> [(ConstructorName, doc)] -> doc
ppRec Pretty doc
p ([(ConstructorName, doc)] -> doc)
-> [(ConstructorName, doc)] -> doc
forall a b. (a -> b) -> a -> b
$
        ((ConstructorName, Expr) -> (ConstructorName, doc))
-> [(ConstructorName, Expr)] -> [(ConstructorName, doc)]
forall a b. (a -> b) -> [a] -> [b]
map (ConstructorName, Expr) -> (ConstructorName, doc)
ppField' ([(ConstructorName, Expr)] -> [(ConstructorName, doc)])
-> [(ConstructorName, Expr)] -> [(ConstructorName, doc)]
forall a b. (a -> b) -> a -> b
$ Map ConstructorName Expr -> [(ConstructorName, Expr)]
forall k a. Map k a -> [(k, a)]
Map.toList Map ConstructorName Expr
xs
    impl Bool
_ (Lst [Expr]
xs)   = Pretty doc -> [doc] -> doc
forall doc. Pretty doc -> [doc] -> doc
ppLst Pretty doc
p ((Expr -> doc) -> [Expr] -> [doc]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Expr -> doc
impl Bool
False) [Expr]
xs)

    ppField' :: (ConstructorName, Expr) -> (ConstructorName, doc)
ppField' (ConstructorName
n, Expr
e) = (ConstructorName -> ConstructorName
escapeName ConstructorName
n, Bool -> Expr -> doc
impl Bool
False Expr
e)

    ppParens' :: Bool -> doc -> doc
ppParens' Bool
True  = Pretty doc -> doc -> doc
forall doc. Pretty doc -> doc -> doc
ppParens Pretty doc
p
    ppParens' Bool
False = doc -> doc
forall a. a -> a
id

-- | Pretty print an @'Edit' 'EditExpr'@ using explicit pretty-printing dictionary.
ppEditExpr :: Pretty doc -> Edit EditExpr -> doc
ppEditExpr :: forall doc. Pretty doc -> Edit EditExpr -> doc
ppEditExpr = Bool -> Pretty doc -> Edit EditExpr -> doc
forall doc. Bool -> Pretty doc -> Edit EditExpr -> doc
ppEditExpr' Bool
False

-- | Like 'ppEditExpr' but print unchanged parts only shallowly
ppEditExprCompact :: Pretty doc -> Edit EditExpr -> doc
ppEditExprCompact :: forall doc. Pretty doc -> Edit EditExpr -> doc
ppEditExprCompact = Bool -> Pretty doc -> Edit EditExpr -> doc
forall doc. Bool -> Pretty doc -> Edit EditExpr -> doc
ppEditExpr' Bool
True

ppEditExpr' :: Bool -> Pretty doc -> Edit EditExpr -> doc
ppEditExpr' :: forall doc. Bool -> Pretty doc -> Edit EditExpr -> doc
ppEditExpr' Bool
compact Pretty doc
p = Pretty doc -> [doc] -> doc
forall doc. Pretty doc -> [doc] -> doc
ppSep Pretty doc
p ([doc] -> doc) -> (Edit EditExpr -> [doc]) -> Edit EditExpr -> doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Edit EditExpr -> [doc]
ppEdit Bool
False
  where
    ppEdit :: Bool -> Edit EditExpr -> [doc]
ppEdit Bool
b (Cpy (EditExp Expr
expr)) = [ Pretty doc -> doc -> doc
forall doc. Pretty doc -> doc -> doc
ppCpy Pretty doc
p (doc -> doc) -> doc -> doc
forall a b. (a -> b) -> a -> b
$ Pretty doc -> Bool -> Expr -> doc
forall doc. Pretty doc -> Bool -> Expr -> doc
ppExpr' Pretty doc
p Bool
b Expr
expr ]
    ppEdit Bool
b (Cpy EditExpr
expr) = [ Bool -> EditExpr -> doc
ppEExpr Bool
b EditExpr
expr ]
    ppEdit Bool
b (Ins EditExpr
expr) = [ Pretty doc -> doc -> doc
forall doc. Pretty doc -> doc -> doc
ppIns Pretty doc
p (Bool -> EditExpr -> doc
ppEExpr Bool
b EditExpr
expr) ]
    ppEdit Bool
b (Del EditExpr
expr) = [ Pretty doc -> doc -> doc
forall doc. Pretty doc -> doc -> doc
ppDel Pretty doc
p (Bool -> EditExpr -> doc
ppEExpr Bool
b EditExpr
expr) ]
    ppEdit Bool
b (Swp EditExpr
x EditExpr
y) =
        [ Pretty doc -> doc -> doc
forall doc. Pretty doc -> doc -> doc
ppDel Pretty doc
p (Bool -> EditExpr -> doc
ppEExpr Bool
b EditExpr
x)
        , Pretty doc -> doc -> doc
forall doc. Pretty doc -> doc -> doc
ppIns Pretty doc
p (Bool -> EditExpr -> doc
ppEExpr Bool
b EditExpr
y)
        ]

    ppEExpr :: Bool -> EditExpr -> doc
ppEExpr Bool
_ (EditApp ConstructorName
x []) = Pretty doc -> ConstructorName -> doc
forall doc. Pretty doc -> ConstructorName -> doc
ppCon Pretty doc
p (ConstructorName -> ConstructorName
escapeName ConstructorName
x)
    ppEExpr Bool
b (EditApp ConstructorName
x [Edit EditExpr]
xs) = Bool -> doc -> doc
ppParens' Bool
b (doc -> doc) -> doc -> doc
forall a b. (a -> b) -> a -> b
$ Pretty doc -> doc -> doc -> doc
forall doc. Pretty doc -> doc -> doc -> doc
ppHang Pretty doc
p (Pretty doc -> ConstructorName -> doc
forall doc. Pretty doc -> ConstructorName -> doc
ppCon Pretty doc
p (ConstructorName -> ConstructorName
escapeName ConstructorName
x)) (doc -> doc) -> doc -> doc
forall a b. (a -> b) -> a -> b
$
        Pretty doc -> [doc] -> doc
forall doc. Pretty doc -> [doc] -> doc
ppSep Pretty doc
p ([doc] -> doc) -> [doc] -> doc
forall a b. (a -> b) -> a -> b
$ (Edit EditExpr -> [doc]) -> [Edit EditExpr] -> [doc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Bool -> Edit EditExpr -> [doc]
ppEdit Bool
True) [Edit EditExpr]
xs
    ppEExpr Bool
_ (EditRec ConstructorName
x Map ConstructorName (Edit EditExpr)
xs) = Pretty doc -> doc -> doc -> doc
forall doc. Pretty doc -> doc -> doc -> doc
ppHang Pretty doc
p (Pretty doc -> ConstructorName -> doc
forall doc. Pretty doc -> ConstructorName -> doc
ppCon Pretty doc
p (ConstructorName -> ConstructorName
escapeName ConstructorName
x)) (doc -> doc) -> doc -> doc
forall a b. (a -> b) -> a -> b
$ Pretty doc -> [(ConstructorName, doc)] -> doc
forall doc. Pretty doc -> [(ConstructorName, doc)] -> doc
ppRec Pretty doc
p ([(ConstructorName, doc)] -> doc)
-> [(ConstructorName, doc)] -> doc
forall a b. (a -> b) -> a -> b
$
        [(ConstructorName, doc)]
justs [(ConstructorName, doc)]
-> [(ConstructorName, doc)] -> [(ConstructorName, doc)]
forall a. [a] -> [a] -> [a]
++ [ (ConstructorName
n, Pretty doc -> ConstructorName -> doc
forall doc. Pretty doc -> ConstructorName -> doc
ppCon Pretty doc
p ConstructorName
"...") | ConstructorName
n <- Int -> [ConstructorName] -> [ConstructorName]
forall a. Int -> [a] -> [a]
take Int
1 [ConstructorName]
nothings ]
      where
        xs' :: [Either ConstructorName (ConstructorName, doc)]
xs' = ((ConstructorName, Edit EditExpr)
 -> Either ConstructorName (ConstructorName, doc))
-> [(ConstructorName, Edit EditExpr)]
-> [Either ConstructorName (ConstructorName, doc)]
forall a b. (a -> b) -> [a] -> [b]
map (ConstructorName, Edit EditExpr)
-> Either ConstructorName (ConstructorName, doc)
ppField' ([(ConstructorName, Edit EditExpr)]
 -> [Either ConstructorName (ConstructorName, doc)])
-> [(ConstructorName, Edit EditExpr)]
-> [Either ConstructorName (ConstructorName, doc)]
forall a b. (a -> b) -> a -> b
$ Map ConstructorName (Edit EditExpr)
-> [(ConstructorName, Edit EditExpr)]
forall k a. Map k a -> [(k, a)]
Map.toList Map ConstructorName (Edit EditExpr)
xs
        ([ConstructorName]
nothings, [(ConstructorName, doc)]
justs) = [Either ConstructorName (ConstructorName, doc)]
-> ([ConstructorName], [(ConstructorName, doc)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either ConstructorName (ConstructorName, doc)]
xs'

    ppEExpr Bool
_ (EditLst [Edit EditExpr]
xs)   = Pretty doc -> [doc] -> doc
forall doc. Pretty doc -> [doc] -> doc
ppLst Pretty doc
p ((Edit EditExpr -> [doc]) -> [Edit EditExpr] -> [doc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Bool -> Edit EditExpr -> [doc]
ppEdit Bool
False) [Edit EditExpr]
xs)
    ppEExpr Bool
b (EditExp Expr
x)    = Pretty doc -> Bool -> Expr -> doc
forall doc. Pretty doc -> Bool -> Expr -> doc
ppExpr' Pretty doc
p Bool
b Expr
x

    ppField' :: (ConstructorName, Edit EditExpr)
-> Either ConstructorName (ConstructorName, doc)
ppField' (ConstructorName
n, Cpy (EditExp Expr
e)) | Bool
compact, Bool -> Bool
not (Expr -> Bool
isScalar Expr
e) = ConstructorName -> Either ConstructorName (ConstructorName, doc)
forall a b. a -> Either a b
Left ConstructorName
n
    ppField' (ConstructorName
n, Edit EditExpr
e) = (ConstructorName, doc)
-> Either ConstructorName (ConstructorName, doc)
forall a b. b -> Either a b
Right (ConstructorName -> ConstructorName
escapeName ConstructorName
n, Pretty doc -> [doc] -> doc
forall doc. Pretty doc -> [doc] -> doc
ppSep Pretty doc
p ([doc] -> doc) -> [doc] -> doc
forall a b. (a -> b) -> a -> b
$ Bool -> Edit EditExpr -> [doc]
ppEdit Bool
False Edit EditExpr
e)

    ppParens' :: Bool -> doc -> doc
ppParens' Bool
True  = Pretty doc -> doc -> doc
forall doc. Pretty doc -> doc -> doc
ppParens Pretty doc
p
    ppParens' Bool
False = doc -> doc
forall a. a -> a
id

    isScalar :: Expr -> Bool
isScalar (App ConstructorName
_ []) = Bool
True
    isScalar Expr
_          = Bool
False

-------------------------------------------------------------------------------
-- pretty
-------------------------------------------------------------------------------

-- | 'Pretty' via @pretty@ library.
prettyPretty :: Pretty HJ.Doc
prettyPretty :: Pretty Doc
prettyPretty = Pretty
    { ppCon :: ConstructorName -> Doc
ppCon    = ConstructorName -> Doc
HJ.text
    , ppRec :: [(ConstructorName, Doc)] -> Doc
ppRec    = Doc -> Doc
HJ.braces (Doc -> Doc)
-> ([(ConstructorName, Doc)] -> Doc)
-> [(ConstructorName, Doc)]
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
HJ.sep ([Doc] -> Doc)
-> ([(ConstructorName, Doc)] -> [Doc])
-> [(ConstructorName, Doc)]
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
HJ.punctuate Doc
HJ.comma
               ([Doc] -> [Doc])
-> ([(ConstructorName, Doc)] -> [Doc])
-> [(ConstructorName, Doc)]
-> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ConstructorName, Doc) -> Doc)
-> [(ConstructorName, Doc)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(ConstructorName
fn, Doc
d) -> ConstructorName -> Doc
HJ.text ConstructorName
fn Doc -> Doc -> Doc
HJ.<+> Doc
HJ.equals Doc -> Doc -> Doc
HJ.<+> Doc
d)
    , ppLst :: [Doc] -> Doc
ppLst    = Doc -> Doc
HJ.brackets (Doc -> Doc) -> ([Doc] -> Doc) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
HJ.sep ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
HJ.punctuate Doc
HJ.comma
    , ppCpy :: Doc -> Doc
ppCpy    = Doc -> Doc
forall a. a -> a
id
    , ppIns :: Doc -> Doc
ppIns    = \Doc
d -> Char -> Doc
HJ.char Char
'+' Doc -> Doc -> Doc
HJ.<> Doc
d
    , ppDel :: Doc -> Doc
ppDel    = \Doc
d -> Char -> Doc
HJ.char Char
'-' Doc -> Doc -> Doc
HJ.<> Doc
d
    , ppSep :: [Doc] -> Doc
ppSep    = [Doc] -> Doc
HJ.sep
    , ppParens :: Doc -> Doc
ppParens = Doc -> Doc
HJ.parens
    , ppHang :: Doc -> Doc -> Doc
ppHang   = \Doc
d1 Doc
d2 -> Doc -> Int -> Doc -> Doc
HJ.hang Doc
d1 Int
2 Doc
d2
    }

-- | Pretty print 'Expr' using @pretty@.
--
-- >>> prettyExpr $ Rec "ex" (Map.fromList [("[]", App "bar" [])])
-- ex {`[]` = bar}
prettyExpr :: Expr -> HJ.Doc
prettyExpr :: Expr -> Doc
prettyExpr = Pretty Doc -> Expr -> Doc
forall doc. Pretty doc -> Expr -> doc
ppExpr Pretty Doc
prettyPretty

-- | Pretty print @'Edit' 'EditExpr'@ using @pretty@.
prettyEditExpr :: Edit EditExpr -> HJ.Doc
prettyEditExpr :: Edit EditExpr -> Doc
prettyEditExpr = Pretty Doc -> Edit EditExpr -> Doc
forall doc. Pretty doc -> Edit EditExpr -> doc
ppEditExpr Pretty Doc
prettyPretty

-- | Compact 'prettyEditExpr'.
prettyEditExprCompact :: Edit EditExpr -> HJ.Doc
prettyEditExprCompact :: Edit EditExpr -> Doc
prettyEditExprCompact = Pretty Doc -> Edit EditExpr -> Doc
forall doc. Pretty doc -> Edit EditExpr -> doc
ppEditExprCompact Pretty Doc
prettyPretty

-------------------------------------------------------------------------------
-- ansi-wl-pprint
-------------------------------------------------------------------------------

-- | 'Pretty' via @ansi-wl-pprint@ library (with colors).
ansiWlPretty :: Pretty WL.Doc
ansiWlPretty :: Pretty Doc
ansiWlPretty = Pretty
    { ppCon :: ConstructorName -> Doc
ppCon    = ConstructorName -> Doc
WL.text
    , ppRec :: [(ConstructorName, Doc)] -> Doc
ppRec    = Doc -> Doc -> Doc -> [Doc] -> Doc
WL.encloseSep Doc
WL.lbrace Doc
WL.rbrace Doc
WL.comma
               ([Doc] -> Doc)
-> ([(ConstructorName, Doc)] -> [Doc])
-> [(ConstructorName, Doc)]
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((ConstructorName, Doc) -> Doc)
-> [(ConstructorName, Doc)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(ConstructorName
fn, Doc
d) -> ConstructorName -> Doc
WL.text ConstructorName
fn Doc -> Doc -> Doc
WL.<+> Doc
WL.equals Doc -> Doc -> Doc
WL.</> Doc
d)
    , ppLst :: [Doc] -> Doc
ppLst    = [Doc] -> Doc
WL.list
    , ppCpy :: Doc -> Doc
ppCpy    = Doc -> Doc
WL.dullwhite
    , ppIns :: Doc -> Doc
ppIns    = \Doc
d -> Doc -> Doc
WL.green (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
WL.plain (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
WL.char Char
'+' Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
WL.<> Doc
d
    , ppDel :: Doc -> Doc
ppDel    = \Doc
d -> Doc -> Doc
WL.red   (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
WL.plain (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
WL.char Char
'-' Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
WL.<> Doc
d
    , ppSep :: [Doc] -> Doc
ppSep    = [Doc] -> Doc
WL.sep
    , ppParens :: Doc -> Doc
ppParens = Doc -> Doc
WL.parens
    , ppHang :: Doc -> Doc -> Doc
ppHang   = \Doc
d1 Doc
d2 -> Int -> Doc -> Doc
WL.hang Int
2 (Doc
d1 Doc -> Doc -> Doc
WL.</> Doc
d2)
    }

-- | Pretty print 'Expr' using @ansi-wl-pprint@.
ansiWlExpr :: Expr -> WL.Doc
ansiWlExpr :: Expr -> Doc
ansiWlExpr = Pretty Doc -> Expr -> Doc
forall doc. Pretty doc -> Expr -> doc
ppExpr Pretty Doc
ansiWlPretty

-- | Pretty print @'Edit' 'EditExpr'@ using @ansi-wl-pprint@.
ansiWlEditExpr :: Edit EditExpr -> WL.Doc
ansiWlEditExpr :: Edit EditExpr -> Doc
ansiWlEditExpr = Pretty Doc -> Edit EditExpr -> Doc
forall doc. Pretty doc -> Edit EditExpr -> doc
ppEditExpr Pretty Doc
ansiWlPretty

-- | Compact 'ansiWlEditExpr'
ansiWlEditExprCompact :: Edit EditExpr -> WL.Doc
ansiWlEditExprCompact :: Edit EditExpr -> Doc
ansiWlEditExprCompact = Pretty Doc -> Edit EditExpr -> Doc
forall doc. Pretty doc -> Edit EditExpr -> doc
ppEditExprCompact Pretty Doc
ansiWlPretty

-------------------------------------------------------------------------------
-- Background
-------------------------------------------------------------------------------

-- | Like 'ansiWlPretty' but color the background.
ansiWlBgPretty :: Pretty WL.Doc
ansiWlBgPretty :: Pretty Doc
ansiWlBgPretty = Pretty Doc
ansiWlPretty
    { ppIns    = \Doc
d -> Doc -> Doc
WL.ondullgreen (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
WL.white (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
WL.plain (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
WL.char Char
'+' Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
WL.<> Doc
d
    , ppDel    = \Doc
d -> Doc -> Doc
WL.ondullred   (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
WL.white (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc
WL.plain (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Char -> Doc
WL.char Char
'-' Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
WL.<> Doc
d
    }

-- | Pretty print 'Expr' using @ansi-wl-pprint@.
ansiWlBgExpr :: Expr -> WL.Doc
ansiWlBgExpr :: Expr -> Doc
ansiWlBgExpr = Pretty Doc -> Expr -> Doc
forall doc. Pretty doc -> Expr -> doc
ppExpr Pretty Doc
ansiWlBgPretty

-- | Pretty print @'Edit' 'EditExpr'@ using @ansi-wl-pprint@.
ansiWlBgEditExpr :: Edit EditExpr -> WL.Doc
ansiWlBgEditExpr :: Edit EditExpr -> Doc
ansiWlBgEditExpr = Pretty Doc -> Edit EditExpr -> Doc
forall doc. Pretty doc -> Edit EditExpr -> doc
ppEditExpr Pretty Doc
ansiWlBgPretty

-- | Compact 'ansiWlBgEditExpr'.
ansiWlBgEditExprCompact :: Edit EditExpr -> WL.Doc
ansiWlBgEditExprCompact :: Edit EditExpr -> Doc
ansiWlBgEditExprCompact = Pretty Doc -> Edit EditExpr -> Doc
forall doc. Pretty doc -> Edit EditExpr -> doc
ppEditExprCompact Pretty Doc
ansiWlBgPretty