{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.Portray.Pretty
(
showPortrayal, pp
, showDiff, ppd
, WrappedPortray(..)
, DocAssocPrec, toDocAssocPrecF, toDocAssocPrec
, portrayalToDocPrecF, portrayalToDocPrec
, portrayalToDoc
, prettyShowPortrayal
, pPrintPortrayal
) where
import Data.Functor ((<&>))
import qualified Data.Text as T
import Text.PrettyPrint (Doc)
import qualified Text.PrettyPrint as P
import qualified Text.PrettyPrint.HughesPJ as P (maybeParens)
import Text.PrettyPrint.HughesPJClass (Pretty(..), PrettyLevel, prettyNormal)
import Data.Portray
( Assoc(..), Infixity(..), FactorPortrayal(..)
, Portray, Portrayal(..), PortrayalF(..)
, cata, portray
)
import Data.Portray.Diff (Diff(..))
pp :: Portray a => a -> IO ()
pp :: a -> IO ()
pp = String -> IO ()
putStrLn (String -> IO ()) -> (a -> String) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> String
forall a. Portray a => a -> String
showPortrayal
showPortrayal :: Portray a => a -> String
showPortrayal :: a -> String
showPortrayal = Portrayal -> String
prettyShowPortrayal (Portrayal -> String) -> (a -> Portrayal) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Portrayal
forall a. Portray a => a -> Portrayal
portray
ppd :: Diff a => a -> a -> IO ()
ppd :: a -> a -> IO ()
ppd a
x = String -> IO ()
putStrLn (String -> IO ()) -> (a -> String) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> String
forall a. Diff a => a -> a -> String
showDiff a
x
showDiff :: Diff a => a -> a -> String
showDiff :: a -> a -> String
showDiff a
x = String -> (Portrayal -> String) -> Maybe Portrayal -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"_" Portrayal -> String
prettyShowPortrayal (Maybe Portrayal -> String)
-> (a -> Maybe Portrayal) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> a -> Maybe Portrayal
forall a. Diff a => a -> a -> Maybe Portrayal
diff a
x
type DocAssocPrec = Assoc -> Rational -> Doc
fixityCompatible :: Infixity -> Assoc -> Rational -> Bool
fixityCompatible :: Infixity -> Assoc -> Rational -> Bool
fixityCompatible (Infixity Assoc
assoc Rational
p) Assoc
assoc' Rational
p' = case Rational -> Rational -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Rational
p' Rational
p of
Ordering
GT -> Bool
False
Ordering
EQ -> Assoc
assoc Assoc -> Assoc -> Bool
forall a. Eq a => a -> a -> Bool
== Assoc
assoc'
Ordering
LT -> Bool
True
matchCtx :: Assoc -> Assoc -> Assoc
matchCtx :: Assoc -> Assoc -> Assoc
matchCtx Assoc
ctx Assoc
assoc
| Assoc
ctx Assoc -> Assoc -> Bool
forall a. Eq a => a -> a -> Bool
== Assoc
assoc = Assoc
ctx
| Bool
otherwise = Assoc
AssocNope
portrayalToDoc :: Portrayal -> Doc
portrayalToDoc :: Portrayal -> Doc
portrayalToDoc Portrayal
t = Portrayal -> PrettyLevel -> Rational -> Doc
portrayalToDocPrec Portrayal
t PrettyLevel
prettyNormal (-Rational
1)
ppBinop
:: String
-> Infixity
-> DocAssocPrec -> DocAssocPrec -> DocAssocPrec
ppBinop :: String -> Infixity -> DocAssocPrec -> DocAssocPrec -> DocAssocPrec
ppBinop String
nm fx :: Infixity
fx@(Infixity Assoc
assoc Rational
opPrec) DocAssocPrec
x DocAssocPrec
y Assoc
lr Rational
p =
Bool -> Doc -> Doc
P.maybeParens (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Infixity -> Assoc -> Rational -> Bool
fixityCompatible Infixity
fx Assoc
lr Rational
p) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
P.sep
[ DocAssocPrec
x (Assoc -> Assoc -> Assoc
matchCtx Assoc
AssocL Assoc
assoc) Rational
opPrec Doc -> Doc -> Doc
P.<+> String -> Doc
P.text String
nm
, Int -> Doc -> Doc
P.nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ DocAssocPrec
y (Assoc -> Assoc -> Assoc
matchCtx Assoc
AssocR Assoc
assoc) Rational
opPrec
]
ppBulletList
:: Doc
-> Doc
-> Doc
-> [Doc]
-> Doc
ppBulletList :: Doc -> Doc -> Doc -> [Doc] -> Doc
ppBulletList Doc
opener Doc
_ Doc
closer [] = Doc
opener Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
closer
ppBulletList Doc
opener Doc
separator Doc
closer [Doc]
docs =
[Doc] -> Doc
P.sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
[ [Doc] -> Doc
P.fcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Doc -> Doc -> Doc) -> [Doc] -> [Doc] -> [Doc]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Doc -> Doc -> Doc
(P.<+>) (Doc
opener Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: Doc -> [Doc]
forall a. a -> [a]
repeat Doc
separator) [Doc]
docs
, Doc
closer
]
toDocAssocPrecF :: PortrayalF DocAssocPrec -> DocAssocPrec
toDocAssocPrecF :: PortrayalF DocAssocPrec -> DocAssocPrec
toDocAssocPrecF = \case
AtomF Text
txt -> \Assoc
_ Rational
_ -> String -> Doc
P.text (Text -> String
T.unpack Text
txt)
ApplyF DocAssocPrec
fn [DocAssocPrec]
xs -> \Assoc
lr Rational
p ->
Bool -> Doc -> Doc
P.maybeParens (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Infixity -> Assoc -> Rational -> Bool
fixityCompatible (Assoc -> Rational -> Infixity
Infixity Assoc
AssocL Rational
10) Assoc
lr Rational
p) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
P.sep
[ DocAssocPrec
fn Assoc
AssocL Rational
10
, Int -> Doc -> Doc
P.nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
P.sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [DocAssocPrec]
xs [DocAssocPrec] -> (DocAssocPrec -> Doc) -> [Doc]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \DocAssocPrec
docprec -> DocAssocPrec
docprec Assoc
AssocR Rational
10
]
BinopF Text
nm Infixity
fx DocAssocPrec
x DocAssocPrec
y -> String -> Infixity -> DocAssocPrec -> DocAssocPrec -> DocAssocPrec
ppBinop (Text -> String
T.unpack Text
nm) Infixity
fx DocAssocPrec
x DocAssocPrec
y
TupleF [DocAssocPrec]
xs -> \Assoc
_ Rational
_ -> Doc -> Doc -> Doc -> [Doc] -> Doc
ppBulletList Doc
"(" Doc
"," Doc
")" ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [DocAssocPrec]
xs [DocAssocPrec] -> (DocAssocPrec -> Doc) -> [Doc]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \DocAssocPrec
x -> DocAssocPrec
x Assoc
AssocNope (-Rational
1)
ListF [DocAssocPrec]
xs -> \Assoc
_ Rational
_ -> Doc -> Doc -> Doc -> [Doc] -> Doc
ppBulletList Doc
"[" Doc
"," Doc
"]" ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ [DocAssocPrec]
xs [DocAssocPrec] -> (DocAssocPrec -> Doc) -> [Doc]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \DocAssocPrec
x -> DocAssocPrec
x Assoc
AssocNope (-Rational
1)
LambdaCaseF [(DocAssocPrec, DocAssocPrec)]
xs -> \Assoc
_ Rational
p ->
Bool -> Doc -> Doc
P.maybeParens (Rational
p Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= Rational
10) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
P.sep
[ Doc
"\\case"
, Int -> Doc -> Doc
P.nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc -> [Doc] -> Doc
ppBulletList Doc
"{" Doc
";" Doc
"}"
[ [Doc] -> Doc
P.sep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$
[ DocAssocPrec
pat Assoc
AssocNope Rational
0 Doc -> Doc -> Doc
P.<+> Doc
"->"
, Int -> Doc -> Doc
P.nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ DocAssocPrec
val Assoc
AssocNope Rational
0
]
| (DocAssocPrec
pat, DocAssocPrec
val) <- [(DocAssocPrec, DocAssocPrec)]
xs
]
]
RecordF DocAssocPrec
con [FactorPortrayal DocAssocPrec]
sels -> \Assoc
_ Rational
_ -> case [FactorPortrayal DocAssocPrec]
sels of
[] -> DocAssocPrec
con Assoc
AssocNope (-Rational
1)
[FactorPortrayal DocAssocPrec]
_ -> [Doc] -> Doc
P.sep
[ DocAssocPrec
con Assoc
AssocNope Rational
10
, Int -> Doc -> Doc
P.nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc -> Doc -> Doc -> [Doc] -> Doc
ppBulletList Doc
"{" Doc
"," Doc
"}"
[ [Doc] -> Doc
P.sep
[ String -> Doc
P.text (Text -> String
T.unpack Text
sel) Doc -> Doc -> Doc
P.<+> Doc
"="
, Int -> Doc -> Doc
P.nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ DocAssocPrec
val Assoc
AssocNope Rational
0
]
| FactorPortrayal Text
sel DocAssocPrec
val <- [FactorPortrayal DocAssocPrec]
sels
]
]
TyAppF DocAssocPrec
val DocAssocPrec
ty -> \Assoc
_ Rational
_ ->
[Doc] -> Doc
P.sep [DocAssocPrec
val Assoc
AssocNope Rational
10, Int -> Doc -> Doc
P.nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"@" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> DocAssocPrec
ty Assoc
AssocNope Rational
10]
TySigF DocAssocPrec
val DocAssocPrec
ty -> \Assoc
_ Rational
p -> Bool -> Doc -> Doc
P.maybeParens (Rational
p Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= Rational
0) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$
[Doc] -> Doc
P.sep [DocAssocPrec
val Assoc
AssocNope Rational
0, Int -> Doc -> Doc
P.nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Doc
"::" Doc -> Doc -> Doc
P.<+> DocAssocPrec
ty Assoc
AssocNope Rational
0]
QuotF Text
nm DocAssocPrec
content -> \Assoc
_ Rational
_ ->
[Doc] -> Doc
P.sep
[ Char -> Doc
P.char Char
'[' Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
P.text (Text -> String
T.unpack Text
nm) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Char -> Doc
P.char Char
'|'
, Int -> Doc -> Doc
P.nest Int
2 (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ DocAssocPrec
content Assoc
AssocNope (-Rational
1)
, Doc
"|]"
]
UnlinesF [DocAssocPrec]
ls -> \Assoc
_ Rational
_ -> [Doc] -> Doc
P.vcat ([DocAssocPrec]
ls [DocAssocPrec] -> (DocAssocPrec -> Doc) -> [Doc]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \DocAssocPrec
l -> DocAssocPrec
l Assoc
AssocNope (-Rational
1))
NestF Int
n DocAssocPrec
x -> \Assoc
_ Rational
_ -> Int -> Doc -> Doc
P.nest Int
n (DocAssocPrec
x Assoc
AssocNope (-Rational
1))
toDocPrec :: DocAssocPrec -> PrettyLevel -> Rational -> Doc
toDocPrec :: DocAssocPrec -> PrettyLevel -> Rational -> Doc
toDocPrec DocAssocPrec
dap PrettyLevel
_l = DocAssocPrec
dap Assoc
AssocNope (Rational -> Doc) -> (Rational -> Rational) -> Rational -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rational -> Rational -> Rational
forall a. Num a => a -> a -> a
subtract Rational
1
portrayalToDocPrecF
:: PortrayalF DocAssocPrec -> PrettyLevel -> Rational -> Doc
portrayalToDocPrecF :: PortrayalF DocAssocPrec -> PrettyLevel -> Rational -> Doc
portrayalToDocPrecF = DocAssocPrec -> PrettyLevel -> Rational -> Doc
toDocPrec (DocAssocPrec -> PrettyLevel -> Rational -> Doc)
-> (PortrayalF DocAssocPrec -> DocAssocPrec)
-> PortrayalF DocAssocPrec
-> PrettyLevel
-> Rational
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PortrayalF DocAssocPrec -> DocAssocPrec
toDocAssocPrecF
toDocAssocPrec :: Portrayal -> DocAssocPrec
toDocAssocPrec :: Portrayal -> DocAssocPrec
toDocAssocPrec = (PortrayalF DocAssocPrec -> DocAssocPrec)
-> Fix PortrayalF -> DocAssocPrec
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
cata PortrayalF DocAssocPrec -> DocAssocPrec
toDocAssocPrecF (Fix PortrayalF -> DocAssocPrec)
-> (Portrayal -> Fix PortrayalF) -> Portrayal -> DocAssocPrec
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Portrayal -> Fix PortrayalF
unPortrayal
portrayalToDocPrec :: Portrayal -> PrettyLevel -> Rational -> Doc
portrayalToDocPrec :: Portrayal -> PrettyLevel -> Rational -> Doc
portrayalToDocPrec = DocAssocPrec -> PrettyLevel -> Rational -> Doc
toDocPrec (DocAssocPrec -> PrettyLevel -> Rational -> Doc)
-> (Portrayal -> DocAssocPrec)
-> Portrayal
-> PrettyLevel
-> Rational
-> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Portrayal -> DocAssocPrec
toDocAssocPrec
pPrintPortrayal :: PrettyLevel -> Rational -> Portrayal -> Doc
pPrintPortrayal :: PrettyLevel -> Rational -> Portrayal -> Doc
pPrintPortrayal PrettyLevel
l Rational
p Portrayal
x = Portrayal -> PrettyLevel -> Rational -> Doc
portrayalToDocPrec Portrayal
x PrettyLevel
l Rational
p
prettyShowPortrayal :: Portrayal -> String
prettyShowPortrayal :: Portrayal -> String
prettyShowPortrayal Portrayal
p = Doc -> String
forall a. Show a => a -> String
show (Portrayal -> DocAssocPrec
toDocAssocPrec Portrayal
p Assoc
AssocNope (-Rational
1))
newtype WrappedPortray a = WrappedPortray { WrappedPortray a -> a
unWrappedPortray :: a }
deriving newtype (WrappedPortray a -> WrappedPortray a -> Bool
(WrappedPortray a -> WrappedPortray a -> Bool)
-> (WrappedPortray a -> WrappedPortray a -> Bool)
-> Eq (WrappedPortray a)
forall a. Eq a => WrappedPortray a -> WrappedPortray a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WrappedPortray a -> WrappedPortray a -> Bool
$c/= :: forall a. Eq a => WrappedPortray a -> WrappedPortray a -> Bool
== :: WrappedPortray a -> WrappedPortray a -> Bool
$c== :: forall a. Eq a => WrappedPortray a -> WrappedPortray a -> Bool
Eq, Eq (WrappedPortray a)
Eq (WrappedPortray a)
-> (WrappedPortray a -> WrappedPortray a -> Ordering)
-> (WrappedPortray a -> WrappedPortray a -> Bool)
-> (WrappedPortray a -> WrappedPortray a -> Bool)
-> (WrappedPortray a -> WrappedPortray a -> Bool)
-> (WrappedPortray a -> WrappedPortray a -> Bool)
-> (WrappedPortray a -> WrappedPortray a -> WrappedPortray a)
-> (WrappedPortray a -> WrappedPortray a -> WrappedPortray a)
-> Ord (WrappedPortray a)
WrappedPortray a -> WrappedPortray a -> Bool
WrappedPortray a -> WrappedPortray a -> Ordering
WrappedPortray a -> WrappedPortray a -> WrappedPortray a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (WrappedPortray a)
forall a. Ord a => WrappedPortray a -> WrappedPortray a -> Bool
forall a. Ord a => WrappedPortray a -> WrappedPortray a -> Ordering
forall a.
Ord a =>
WrappedPortray a -> WrappedPortray a -> WrappedPortray a
min :: WrappedPortray a -> WrappedPortray a -> WrappedPortray a
$cmin :: forall a.
Ord a =>
WrappedPortray a -> WrappedPortray a -> WrappedPortray a
max :: WrappedPortray a -> WrappedPortray a -> WrappedPortray a
$cmax :: forall a.
Ord a =>
WrappedPortray a -> WrappedPortray a -> WrappedPortray a
>= :: WrappedPortray a -> WrappedPortray a -> Bool
$c>= :: forall a. Ord a => WrappedPortray a -> WrappedPortray a -> Bool
> :: WrappedPortray a -> WrappedPortray a -> Bool
$c> :: forall a. Ord a => WrappedPortray a -> WrappedPortray a -> Bool
<= :: WrappedPortray a -> WrappedPortray a -> Bool
$c<= :: forall a. Ord a => WrappedPortray a -> WrappedPortray a -> Bool
< :: WrappedPortray a -> WrappedPortray a -> Bool
$c< :: forall a. Ord a => WrappedPortray a -> WrappedPortray a -> Bool
compare :: WrappedPortray a -> WrappedPortray a -> Ordering
$ccompare :: forall a. Ord a => WrappedPortray a -> WrappedPortray a -> Ordering
$cp1Ord :: forall a. Ord a => Eq (WrappedPortray a)
Ord, Int -> WrappedPortray a -> ShowS
[WrappedPortray a] -> ShowS
WrappedPortray a -> String
(Int -> WrappedPortray a -> ShowS)
-> (WrappedPortray a -> String)
-> ([WrappedPortray a] -> ShowS)
-> Show (WrappedPortray a)
forall a. Show a => Int -> WrappedPortray a -> ShowS
forall a. Show a => [WrappedPortray a] -> ShowS
forall a. Show a => WrappedPortray a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [WrappedPortray a] -> ShowS
$cshowList :: forall a. Show a => [WrappedPortray a] -> ShowS
show :: WrappedPortray a -> String
$cshow :: forall a. Show a => WrappedPortray a -> String
showsPrec :: Int -> WrappedPortray a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> WrappedPortray a -> ShowS
Show)
instance Portray a => Pretty (WrappedPortray a) where
pPrintPrec :: PrettyLevel -> Rational -> WrappedPortray a -> Doc
pPrintPrec PrettyLevel
l Rational
p WrappedPortray a
x = Portrayal -> PrettyLevel -> Rational -> Doc
portrayalToDocPrec (a -> Portrayal
forall a. Portray a => a -> Portrayal
portray (a -> Portrayal) -> a -> Portrayal
forall a b. (a -> b) -> a -> b
$ WrappedPortray a -> a
forall a. WrappedPortray a -> a
unWrappedPortray WrappedPortray a
x) PrettyLevel
l Rational
p