-- | Utilities to pretty print 'Expr' and 'EditExpr'
module Data.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 Data.TreeDiff.Expr
import Numeric            (showHex)
import Text.Read          (readMaybe)

import qualified Data.TreeDiff.OMap           as OMap
import qualified Text.PrettyPrint             as HJ
import qualified Text.PrettyPrint.ANSI.Leijen as WL

-- $setup
-- >>> import qualified Data.TreeDiff.OMap as OMap
-- >>> import Data.TreeDiff.Expr

-- | 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            -- ^ Display 'ConstructorName'
    , forall doc. Pretty doc -> doc -> [doc] -> doc
ppApp    :: doc -> [doc] -> doc               -- ^ Display 'App'
    , forall doc. Pretty doc -> doc -> [(ConstructorName, doc)] -> doc
ppRec    :: doc -> [(FieldName, doc)] -> doc  -- ^ Display 'Rec'
    , forall doc. Pretty doc -> [doc] -> doc
ppLst    :: [doc] -> doc                      -- ^ Display 'Lst'
    , forall doc. Pretty doc -> doc -> doc
ppCpy    :: doc -> doc                        -- ^ Display unchanged parts
    , forall doc. Pretty doc -> doc -> doc
ppIns    :: doc -> doc                        -- ^ Display added parts
    , forall doc. Pretty doc -> doc -> doc
ppDel    :: doc -> doc                        -- ^ Display removed parts
    , forall doc. Pretty doc -> [doc] -> doc
ppEdits  :: [doc] -> doc                      -- ^ Combined edits (usually some @sep@ combinator)
    , forall doc. Pretty doc -> doc
ppEllip  :: doc                               -- ^ Ellipsis
    , forall doc. Pretty doc -> doc -> doc
ppParens :: doc -> doc                        -- ^ Parens an expression
    }

-- | 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
ppApp Pretty doc
p (Pretty doc -> ConstructorName -> doc
forall doc. Pretty doc -> ConstructorName -> doc
ppCon Pretty doc
p (ConstructorName -> ConstructorName
escapeName ConstructorName
x)) ((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 OMap ConstructorName Expr
xs) = Pretty doc -> doc -> [(ConstructorName, doc)] -> doc
forall doc. Pretty doc -> doc -> [(ConstructorName, doc)] -> doc
ppRec Pretty doc
p (Pretty doc -> ConstructorName -> doc
forall doc. Pretty doc -> ConstructorName -> doc
ppCon Pretty doc
p (ConstructorName -> ConstructorName
escapeName ConstructorName
x)) ([(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
$ OMap ConstructorName Expr -> [(ConstructorName, Expr)]
forall k v. OMap k v -> [(k, v)]
OMap.toList OMap 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 = Edit EditExpr -> doc
go
  where
    go :: Edit EditExpr -> doc
go = Pretty doc -> [doc] -> doc
forall doc. Pretty doc -> [doc] -> doc
ppEdits 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

    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
ppApp Pretty doc
p (Pretty doc -> ConstructorName -> doc
forall doc. Pretty doc -> ConstructorName -> doc
ppCon Pretty doc
p (ConstructorName -> ConstructorName
escapeName ConstructorName
x)) ((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 OMap ConstructorName (Edit EditExpr)
xs) = Pretty doc -> doc -> [(ConstructorName, doc)] -> doc
forall doc. Pretty doc -> doc -> [(ConstructorName, doc)] -> doc
ppRec Pretty doc
p (Pretty doc -> ConstructorName -> doc
forall doc. Pretty doc -> ConstructorName -> doc
ppCon Pretty doc
p (ConstructorName -> ConstructorName
escapeName ConstructorName
x)) ([(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 -> doc
forall doc. Pretty doc -> doc
ppEllip Pretty doc
p) | 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
$ OMap ConstructorName (Edit EditExpr)
-> [(ConstructorName, Edit EditExpr)]
forall k v. OMap k v -> [(k, v)]
OMap.toList OMap 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, Edit EditExpr -> doc
go 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 :: Doc -> [(ConstructorName, Doc)] -> Doc
ppRec    = \Doc
c [(ConstructorName, Doc)]
xs -> Doc -> Doc -> [Doc] -> Doc
prettyGroup (Doc
c Doc -> Doc -> Doc
HJ.<+> Char -> Doc
HJ.char Char
'{') (Char -> Doc
HJ.char Char
'}')
               ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ((ConstructorName, Doc) -> Doc)
-> [(ConstructorName, Doc)] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\(ConstructorName
fn, Doc
d) -> [Doc] -> Doc
HJ.sep [ConstructorName -> Doc
HJ.text ConstructorName
fn Doc -> Doc -> Doc
HJ.<+> Doc
HJ.equals, Doc
d]) [(ConstructorName, Doc)]
xs
    , ppLst :: [Doc] -> Doc
ppLst    = Doc -> Doc -> [Doc] -> Doc
prettyGroup (Char -> Doc
HJ.char Char
'[') (Char -> Doc
HJ.char Char
']')
    , 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
    , ppEdits :: [Doc] -> Doc
ppEdits  = [Doc] -> Doc
HJ.sep
    , ppEllip :: Doc
ppEllip  = ConstructorName -> Doc
HJ.text ConstructorName
"..."
    , ppApp :: Doc -> [Doc] -> Doc
ppApp    = \Doc
f [Doc]
xs -> [Doc] -> Doc
HJ.sep [ Doc
f, Int -> Doc -> Doc
HJ.nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
HJ.sep [Doc]
xs ]
    , ppParens :: Doc -> Doc
ppParens = Doc -> Doc
HJ.parens
    }

prettyGroup :: HJ.Doc -> HJ.Doc -> [HJ.Doc] -> HJ.Doc
prettyGroup :: Doc -> Doc -> [Doc] -> Doc
prettyGroup Doc
l Doc
r [Doc]
xs = [Doc] -> Doc
HJ.cat [Doc
l, [Doc] -> Doc
HJ.sep ((Doc -> Doc) -> [Doc] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Doc -> Doc
HJ.nest Int
2) (Doc -> Doc -> [Doc] -> [Doc]
prettyPunct (Char -> Doc
HJ.char Char
',') Doc
r [Doc]
xs))]

prettyPunct :: HJ.Doc -> HJ.Doc -> [HJ.Doc] -> [HJ.Doc]
prettyPunct :: Doc -> Doc -> [Doc] -> [Doc]
prettyPunct Doc
_   Doc
end []     = [Doc
end]
prettyPunct Doc
_   Doc
end [Doc
x]    = [Doc
x Doc -> Doc -> Doc
HJ.<> Doc
end]
prettyPunct Doc
sep Doc
end (Doc
x:[Doc]
xs) = (Doc
x Doc -> Doc -> Doc
HJ.<> Doc
sep) Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: Doc -> Doc -> [Doc] -> [Doc]
prettyPunct Doc
sep Doc
end [Doc]
xs

-- | Pretty print 'Expr' using @pretty@.
--
-- >>> prettyExpr $ Rec "ex" (OMap.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 :: Doc -> [(ConstructorName, Doc)] -> Doc
ppRec    = \Doc
c [(ConstructorName, Doc)]
xs -> Doc -> Doc -> [Doc] -> Doc
ansiGroup (Doc
c Doc -> Doc -> Doc
WL.<+> Doc
WL.lbrace) Doc
WL.rbrace
               ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ ((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) [(ConstructorName, Doc)]
xs
    , ppLst :: [Doc] -> Doc
ppLst    = Doc -> Doc -> [Doc] -> Doc
ansiGroup Doc
WL.lbracket Doc
WL.rbracket
    , 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
    , ppApp :: Doc -> [Doc] -> Doc
ppApp    = \Doc
f [Doc]
xs -> Doc -> Doc
WL.group (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Doc -> Doc
WL.nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
f Doc -> Doc -> Doc
WL.<$> [Doc] -> Doc
WL.vsep [Doc]
xs
    , ppEdits :: [Doc] -> Doc
ppEdits  = [Doc] -> Doc
WL.sep
    , ppEllip :: Doc
ppEllip  = ConstructorName -> Doc
WL.text ConstructorName
"..."
    , ppParens :: Doc -> Doc
ppParens = Doc -> Doc
WL.parens
    }

ansiGroup :: WL.Doc -> WL.Doc -> [WL.Doc] -> WL.Doc
ansiGroup :: Doc -> Doc -> [Doc] -> Doc
ansiGroup Doc
l Doc
r [Doc]
xs = Doc -> Doc
WL.group (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Int -> Doc -> Doc
WL.nest Int
2 (Doc
l Doc -> Doc -> Doc
WL.<$$> [Doc] -> Doc
WL.vsep (Doc -> [Doc] -> [Doc]
WL.punctuate Doc
WL.comma [Doc]
xs) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
WL.<> Doc
r)

-- | 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