{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.Portray.Prettyprinter
(
showPortrayal, pp
, showDiff, ppd
, WrappedPortray(..)
, Config, defaultConfig
, setShouldEscapeChar, escapeNonASCII, escapeSpecialOnly
, SyntaxClass(..), LitKind(..)
, defaultStyling, subtleStyling, noStyling
, DocAssocPrec, toDocAssocPrecF, toDocAssocPrec
, portrayalToDoc
, styleShowPortrayal, prettyShowPortrayal, basicShowPortrayal
) where
import Data.Char (isAscii, isDigit, isPrint)
import Data.Function ((&))
import Data.Functor ((<&>))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T (putStrLn)
import GHC.Show (showLitChar)
import Prettyprinter (Doc, Pretty(..))
import qualified Prettyprinter.Render.Terminal as A
import qualified Prettyprinter as P
import Data.Portray
( Assoc(..), Infixity(..), FactorPortrayal(..)
, Ident(..), IdentKind(..)
, Portray, Portrayal(..), PortrayalF(..)
, cata, portray
)
import Data.Portray.Diff (Diff(..))
pp :: Portray a => a -> IO ()
pp :: a -> IO ()
pp = Text -> IO ()
T.putStrLn (Text -> IO ()) -> (a -> Text) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Portrayal -> Text
prettyShowPortrayal (Portrayal -> Text) -> (a -> Portrayal) -> a -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Portrayal
forall a. Portray a => a -> Portrayal
portray
showPortrayal :: Portray a => a -> Text
showPortrayal :: a -> Text
showPortrayal = Portrayal -> Text
basicShowPortrayal (Portrayal -> Text) -> (a -> Portrayal) -> a -> Text
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 = Text -> IO ()
T.putStrLn (Text -> IO ()) -> (a -> Text) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> (Portrayal -> Text) -> Maybe Portrayal -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"_" Portrayal -> Text
prettyShowPortrayal (Maybe Portrayal -> Text) -> (a -> Maybe Portrayal) -> a -> Text
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
showDiff :: Diff a => a -> a -> Text
showDiff :: a -> a -> Text
showDiff a
x = Text -> (Portrayal -> Text) -> Maybe Portrayal -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"_" Portrayal -> Text
basicShowPortrayal (Maybe Portrayal -> Text) -> (a -> Maybe Portrayal) -> a -> Text
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 ann = Assoc -> Rational -> Doc ann
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
data LitKind = IntLit | RatLit | CharLit | StrLit
data SyntaxClass
= Identifier IdentKind
| Literal LitKind
| EscapeSequence
| Keyword
| Bracket
| Separator
| Structural
defaultStyling :: SyntaxClass -> Maybe A.AnsiStyle
defaultStyling :: SyntaxClass -> Maybe AnsiStyle
defaultStyling = AnsiStyle -> Maybe AnsiStyle
forall a. a -> Maybe a
Just (AnsiStyle -> Maybe AnsiStyle)
-> (SyntaxClass -> AnsiStyle) -> SyntaxClass -> Maybe AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
Identifier IdentKind
k -> case IdentKind
k of
IdentKind
OpConIdent -> Color -> AnsiStyle
A.color Color
A.Magenta
IdentKind
OpIdent -> Color -> AnsiStyle
A.colorDull Color
A.Yellow
IdentKind
ConIdent -> AnsiStyle
forall a. Monoid a => a
mempty
IdentKind
VarIdent -> AnsiStyle
forall a. Monoid a => a
mempty
Literal LitKind
k -> case LitKind
k of
LitKind
StrLit -> Color -> AnsiStyle
A.colorDull Color
A.Blue
LitKind
_ -> Color -> AnsiStyle
A.colorDull Color
A.Cyan
SyntaxClass
EscapeSequence -> Color -> AnsiStyle
A.colorDull Color
A.Red
SyntaxClass
Keyword -> Color -> AnsiStyle
A.colorDull Color
A.Green
SyntaxClass
Bracket -> AnsiStyle
forall a. Monoid a => a
mempty
SyntaxClass
Separator -> AnsiStyle
forall a. Monoid a => a
mempty
SyntaxClass
Structural -> Color -> AnsiStyle
A.colorDull Color
A.Green
subtleStyling :: SyntaxClass -> Maybe A.AnsiStyle
subtleStyling :: SyntaxClass -> Maybe AnsiStyle
subtleStyling = AnsiStyle -> Maybe AnsiStyle
forall a. a -> Maybe a
Just (AnsiStyle -> Maybe AnsiStyle)
-> (SyntaxClass -> AnsiStyle) -> SyntaxClass -> Maybe AnsiStyle
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
Identifier IdentKind
k -> case IdentKind
k of
IdentKind
OpConIdent -> Color -> AnsiStyle
A.colorDull Color
A.Blue
IdentKind
OpIdent -> Color -> AnsiStyle
A.colorDull Color
A.Blue
IdentKind
_ -> AnsiStyle
forall a. Monoid a => a
mempty
Literal LitKind
_ -> Color -> AnsiStyle
A.colorDull Color
A.Cyan
SyntaxClass
EscapeSequence -> Color -> AnsiStyle
A.colorDull Color
A.Cyan
SyntaxClass
_ -> AnsiStyle
forall a. Monoid a => a
mempty
noStyling :: SyntaxClass -> Maybe A.AnsiStyle
noStyling :: SyntaxClass -> Maybe AnsiStyle
noStyling = Maybe AnsiStyle -> SyntaxClass -> Maybe AnsiStyle
forall a b. a -> b -> a
const Maybe AnsiStyle
forall a. Maybe a
Nothing
escapeNonASCII :: Char -> Bool
escapeNonASCII :: Char -> Bool
escapeNonASCII = Bool -> Bool
not (Bool -> Bool) -> (Char -> Bool) -> Char -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Bool
isAscii
escapeSpecialOnly :: Char -> Bool
escapeSpecialOnly :: Char -> Bool
escapeSpecialOnly = Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
False
data Config = Config
{ Config -> Char -> Bool
_shouldEscapeChar :: Char -> Bool
}
setShouldEscapeChar :: (Char -> Bool) -> Config -> Config
setShouldEscapeChar :: (Char -> Bool) -> Config -> Config
setShouldEscapeChar Char -> Bool
f Config
_ = (Char -> Bool) -> Config
Config Char -> Bool
f
defaultConfig :: Config
defaultConfig :: Config
defaultConfig = (Char -> Bool) -> Config
Config Char -> Bool
escapeNonASCII
portrayalToDoc :: Config -> Portrayal -> Doc SyntaxClass
portrayalToDoc :: Config -> Portrayal -> Doc SyntaxClass
portrayalToDoc Config
cfg Portrayal
t = Config -> Portrayal -> DocAssocPrec SyntaxClass
toDocAssocPrec Config
cfg Portrayal
t Assoc
AssocNope (-Rational
1)
parens :: Doc SyntaxClass -> Doc SyntaxClass
parens :: Doc SyntaxClass -> Doc SyntaxClass
parens Doc SyntaxClass
d =
SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Bracket (Char -> Doc SyntaxClass
forall ann. Char -> Doc ann
char Char
'(') Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
d Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Bracket (Char -> Doc SyntaxClass
forall ann. Char -> Doc ann
char Char
')')
maybeParens :: Bool -> Doc SyntaxClass -> Doc SyntaxClass
maybeParens :: Bool -> Doc SyntaxClass -> Doc SyntaxClass
maybeParens = \case Bool
True -> Doc SyntaxClass -> Doc SyntaxClass
parens; Bool
False -> Doc SyntaxClass -> Doc SyntaxClass
forall a. a -> a
id
text :: Text -> Doc ann
text :: Text -> Doc ann
text = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty
char :: Char -> Doc ann
char :: Char -> Doc ann
char = Char -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty
ppInfix :: Ident -> Doc SyntaxClass
ppInfix :: Ident -> Doc SyntaxClass
ppInfix (Ident IdentKind
k Text
nm) = case IdentKind
k of
IdentKind
OpConIdent -> Doc SyntaxClass
nmDoc
IdentKind
OpIdent -> Doc SyntaxClass
nmDoc
IdentKind
VarIdent -> Doc SyntaxClass
wrappedNm
IdentKind
ConIdent -> Doc SyntaxClass
wrappedNm
where
backquote :: Doc SyntaxClass
backquote = SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Structural (Char -> Doc SyntaxClass
forall ann. Char -> Doc ann
char Char
'`')
nmDoc :: Doc SyntaxClass
nmDoc = SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate (IdentKind -> SyntaxClass
Identifier IdentKind
k) (Text -> Doc SyntaxClass
forall ann. Text -> Doc ann
text Text
nm)
wrappedNm :: Doc SyntaxClass
wrappedNm = Doc SyntaxClass
backquote Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
nmDoc Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
backquote
ppPrefix :: Ident -> Doc SyntaxClass
ppPrefix :: Ident -> Doc SyntaxClass
ppPrefix (Ident IdentKind
k Text
nm) = case IdentKind
k of
IdentKind
OpConIdent -> Doc SyntaxClass
wrappedNm
IdentKind
OpIdent -> Doc SyntaxClass
wrappedNm
IdentKind
VarIdent -> Doc SyntaxClass
nmDoc
IdentKind
ConIdent -> Doc SyntaxClass
nmDoc
where
nmDoc :: Doc SyntaxClass
nmDoc = SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate (IdentKind -> SyntaxClass
Identifier IdentKind
k) (Text -> Doc SyntaxClass
forall ann. Text -> Doc ann
text Text
nm)
wrappedNm :: Doc SyntaxClass
wrappedNm = Doc SyntaxClass -> Doc SyntaxClass
parens Doc SyntaxClass
nmDoc
ppBinop
:: Ident
-> Infixity
-> DocAssocPrec SyntaxClass
-> DocAssocPrec SyntaxClass
-> DocAssocPrec SyntaxClass
ppBinop :: Ident
-> Infixity
-> DocAssocPrec SyntaxClass
-> DocAssocPrec SyntaxClass
-> DocAssocPrec SyntaxClass
ppBinop Ident
nm fx :: Infixity
fx@(Infixity Assoc
assoc Rational
opPrec) DocAssocPrec SyntaxClass
x DocAssocPrec SyntaxClass
y Assoc
lr Rational
p =
Bool -> Doc SyntaxClass -> Doc SyntaxClass
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 SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$ Int -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Int -> Doc ann -> Doc ann
P.nest Int
2 (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$ [Doc SyntaxClass] -> Doc SyntaxClass
forall ann. [Doc ann] -> Doc ann
P.sep
[ DocAssocPrec SyntaxClass
x (Assoc -> Assoc -> Assoc
matchCtx Assoc
AssocL Assoc
assoc) Rational
opPrec Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Doc ann -> Doc ann -> Doc ann
P.<+> Ident -> Doc SyntaxClass
ppInfix Ident
nm
, DocAssocPrec SyntaxClass
y (Assoc -> Assoc -> Assoc
matchCtx Assoc
AssocR Assoc
assoc) Rational
opPrec
]
ppBulletList
:: Doc SyntaxClass
-> Doc SyntaxClass
-> Doc SyntaxClass
-> [Doc SyntaxClass]
-> Doc SyntaxClass
ppBulletList :: Doc SyntaxClass
-> Doc SyntaxClass
-> Doc SyntaxClass
-> [Doc SyntaxClass]
-> Doc SyntaxClass
ppBulletList Doc SyntaxClass
o Doc SyntaxClass
s Doc SyntaxClass
c = \case
[] -> Doc SyntaxClass
opener Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
closer
(Doc SyntaxClass
doc:[Doc SyntaxClass]
docs) ->
Doc SyntaxClass -> Doc SyntaxClass
forall ann. Doc ann -> Doc ann
P.group (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$
(Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass)
-> (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass
-> [Doc SyntaxClass]
-> Doc SyntaxClass
forall b a. (b -> a -> b) -> (a -> b) -> b -> [a] -> b
foldl01
(\Doc SyntaxClass
x Doc SyntaxClass
y -> Doc SyntaxClass
x Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Doc ann -> Doc ann
P.group (Doc SyntaxClass
forall ann. Doc ann
P.line' Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
y))
Doc SyntaxClass -> Doc SyntaxClass
forall a. a -> a
id
Doc SyntaxClass
forall a. Monoid a => a
mempty
(Doc SyntaxClass
opener Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Doc ann -> Doc ann -> Doc ann
P.flatAlt Doc SyntaxClass
" " Doc SyntaxClass
"" Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
doc Doc SyntaxClass -> [Doc SyntaxClass] -> [Doc SyntaxClass]
forall a. a -> [a] -> [a]
:
(Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass)
-> [Doc SyntaxClass] -> [Doc SyntaxClass] -> [Doc SyntaxClass]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Doc ann -> Doc ann -> Doc ann
(P.<+>) (Doc SyntaxClass -> [Doc SyntaxClass]
forall a. a -> [a]
repeat Doc SyntaxClass
separator) [Doc SyntaxClass]
docs) Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<>
Doc SyntaxClass
forall ann. Doc ann
P.line' Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
closer
where
opener :: Doc SyntaxClass
opener = SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Bracket Doc SyntaxClass
o
separator :: Doc SyntaxClass
separator = SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Separator Doc SyntaxClass
s
closer :: Doc SyntaxClass
closer = SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Bracket Doc SyntaxClass
c
foldl01 :: (b -> a -> b) -> (a -> b) -> b -> [a] -> b
foldl01 :: (b -> a -> b) -> (a -> b) -> b -> [a] -> b
foldl01 b -> a -> b
f a -> b
g b
z = \case
[] -> b
z
(a
x:[a]
xs) -> (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl b -> a -> b
f (a -> b
g a
x) [a]
xs
wordsSep :: Text -> [(Text, Text)]
wordsSep :: Text -> [(Text, Text)]
wordsSep Text
"" = []
wordsSep Text
s =
let isWhitespace :: Char -> Bool
isWhitespace = (Char -> [Char] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Char
' ', Char
'\t'])
(Text
word, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isWhitespace Text
s
(Text
sep, Text
rest') = (Char -> Bool) -> Text -> (Text, Text)
T.span Char -> Bool
isWhitespace Text
rest
in (Text
word, Text
sep) (Text, Text) -> [(Text, Text)] -> [(Text, Text)]
forall a. a -> [a] -> [a]
: Text -> [(Text, Text)]
wordsSep Text
rest'
linesSep :: Text -> [Text]
linesSep :: Text -> [Text]
linesSep Text
"" = []
linesSep Text
s0 = Text -> [Text]
go Text
s0
where
go :: Text -> [Text]
go Text
s =
let (Text
line, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\n') Text
s
in Text
line Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: if Text -> Bool
T.null Text
rest then [] else Text -> [Text]
go (Text -> Text
T.tail Text
rest)
charAlwaysEscaped :: Char -> Bool
charAlwaysEscaped :: Char -> Bool
charAlwaysEscaped Char
c = Bool -> Bool
not (Char -> Bool
isPrint Char
c) Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\'
shouldEscapeChar :: Config -> Char -> Bool
shouldEscapeChar :: Config -> Char -> Bool
shouldEscapeChar Config
cfg Char
c = Char -> Bool
charAlwaysEscaped Char
c Bool -> Bool -> Bool
|| Config -> Char -> Bool
_shouldEscapeChar Config
cfg Char
c
showLitEscapesChar :: Char -> Bool
showLitEscapesChar :: Char -> Bool
showLitEscapesChar Char
c = [Char
c] [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= Char -> ShowS
showLitChar Char
c [Char]
""
litCharIsEscaped :: Config -> Char -> Bool
litCharIsEscaped :: Config -> Char -> Bool
litCharIsEscaped Config
cfg = \case
Char
'\'' -> Bool
True
Char
c -> Char -> Bool
showLitEscapesChar Char
c Bool -> Bool -> Bool
&& Config -> Char -> Bool
shouldEscapeChar Config
cfg Char
c
strCharIsEscaped :: Config -> Char -> Bool
strCharIsEscaped :: Config -> Char -> Bool
strCharIsEscaped Config
cfg = \case
Char
'"' -> Bool
True
Char
c -> Char -> Bool
showLitEscapesChar Char
c Bool -> Bool -> Bool
&& Config -> Char -> Bool
shouldEscapeChar Config
cfg Char
c
needsEmptyEscape :: Config -> Char -> Char -> Bool
needsEmptyEscape :: Config -> Char -> Char -> Bool
needsEmptyEscape Config
cfg Char
c0 Char
c1 =
Config -> Char -> Bool
strCharIsEscaped Config
cfg Char
c0 Bool -> Bool -> Bool
&&
case Char -> ShowS
showLitChar Char
c0 [Char]
"" of
[Char]
"\\SO" -> Char
c1 Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'H'
(Char
'\\' : Char
c : [Char]
_) -> Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
c1
[Char]
_ -> Bool
False
escapeChar :: Config -> Char -> Text
escapeChar :: Config -> Char -> Text
escapeChar Config
cfg Char
c
| Config -> Char -> Bool
shouldEscapeChar Config
cfg Char
c = [Char] -> Text
T.pack (Char -> ShowS
showLitChar Char
c [Char]
"")
| Bool
otherwise = Char -> Text
T.singleton Char
c
escapeLitChar :: Config -> Char -> Text
escapeLitChar :: Config -> Char -> Text
escapeLitChar Config
cfg = \case
Char
'\'' -> Text
"\\'"
Char
c -> Config -> Char -> Text
escapeChar Config
cfg Char
c
escapeStrChar :: Config -> Char -> Text
escapeStrChar :: Config -> Char -> Text
escapeStrChar Config
cfg = \case
Char
'"' -> Text
"\\\""
Char
c -> Config -> Char -> Text
escapeChar Config
cfg Char
c
ppStrLit :: Config -> Text -> Doc SyntaxClass
ppStrLit :: Config -> Text -> Doc SyntaxClass
ppStrLit Config
cfg Text
unescaped =
SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate (LitKind -> SyntaxClass
Literal LitKind
StrLit) (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$
Doc SyntaxClass -> Doc SyntaxClass
forall ann. Doc ann -> Doc ann
P.group (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$
Doc SyntaxClass
-> Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
P.enclose Doc SyntaxClass
"\"" Doc SyntaxClass
"\"" (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$
(Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass)
-> (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass
-> [Doc SyntaxClass]
-> Doc SyntaxClass
forall b a. (b -> a -> b) -> (a -> b) -> b -> [a] -> b
foldl01
(\Doc SyntaxClass
x Doc SyntaxClass
l ->
Doc SyntaxClass
x Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Doc ann -> Doc ann
P.group (Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Doc ann -> Doc ann -> Doc ann
P.flatAlt (Doc SyntaxClass
nl Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
backslashBreak Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
l) (Doc SyntaxClass
nl Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
l)))
Doc SyntaxClass -> Doc SyntaxClass
forall a. a -> a
id
Doc SyntaxClass
forall a. Monoid a => a
mempty
([(Doc SyntaxClass, Doc SyntaxClass)] -> Doc SyntaxClass
ppLine ([(Doc SyntaxClass, Doc SyntaxClass)] -> Doc SyntaxClass)
-> [[(Doc SyntaxClass, Doc SyntaxClass)]] -> [Doc SyntaxClass]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(Doc SyntaxClass, Doc SyntaxClass)]]
escapedLinesOfWords)
where
nl :: Doc SyntaxClass
nl = SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
EscapeSequence Doc SyntaxClass
"\\n"
ppWord :: Text -> Doc SyntaxClass
ppWord :: Text -> Doc SyntaxClass
ppWord Text
"" = Doc SyntaxClass
forall a. Monoid a => a
mempty
ppWord Text
w =
let (Text
toEscape, Text
rest) = (Char -> Bool) -> Text -> (Text, Text)
T.span (Config -> Char -> Bool
strCharIsEscaped Config
cfg) Text
w
(Text
plain, Text
rest') = (Char -> Bool) -> Text -> (Text, Text)
T.break (Config -> Char -> Bool
strCharIsEscaped Config
cfg) Text
rest
sep :: Doc SyntaxClass
sep =
if Bool -> Bool
not (Text -> Bool
T.null Text
toEscape) Bool -> Bool -> Bool
&&
Bool -> Bool
not (Text -> Bool
T.null Text
plain) Bool -> Bool -> Bool
&&
Config -> Char -> Char -> Bool
needsEmptyEscape Config
cfg (Text -> Char
T.last Text
toEscape) (Text -> Char
T.head Text
plain)
then Doc SyntaxClass
"\\&"
else Doc SyntaxClass
forall a. Monoid a => a
mempty
escaped :: Doc SyntaxClass
escaped = Text -> Doc SyntaxClass
forall a ann. Pretty a => a -> Doc ann
pretty ((Char -> Text) -> Text -> Text
T.concatMap (Config -> Char -> Text
escapeStrChar Config
cfg) Text
toEscape) Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
sep
in SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
EscapeSequence Doc SyntaxClass
escaped Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Text -> Doc SyntaxClass
forall ann. Text -> Doc ann
text Text
plain Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Text -> Doc SyntaxClass
ppWord Text
rest'
escapedLinesOfWords :: [[(Doc SyntaxClass, Doc SyntaxClass)]]
escapedLinesOfWords :: [[(Doc SyntaxClass, Doc SyntaxClass)]]
escapedLinesOfWords =
((Text, Text) -> (Doc SyntaxClass, Doc SyntaxClass))
-> [(Text, Text)] -> [(Doc SyntaxClass, Doc SyntaxClass)]
forall a b. (a -> b) -> [a] -> [b]
map
(\ (Text
w, Text
ws) -> (Text -> Doc SyntaxClass
ppWord Text
w, Text -> Doc SyntaxClass
ppWhitespace Text
ws)) ([(Text, Text)] -> [(Doc SyntaxClass, Doc SyntaxClass)])
-> (Text -> [(Text, Text)])
-> Text
-> [(Doc SyntaxClass, Doc SyntaxClass)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Text -> [(Text, Text)]
wordsSep (Text -> [(Doc SyntaxClass, Doc SyntaxClass)])
-> [Text] -> [[(Doc SyntaxClass, Doc SyntaxClass)]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Text -> [Text]
linesSep Text
unescaped
ppWhitespace :: Text -> Doc SyntaxClass
ppWhitespace :: Text -> Doc SyntaxClass
ppWhitespace =
SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
EscapeSequence (Doc SyntaxClass -> Doc SyntaxClass)
-> (Text -> Doc SyntaxClass) -> Text -> Doc SyntaxClass
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Text -> Doc SyntaxClass
forall ann. Text -> Doc ann
text (Text -> Doc SyntaxClass)
-> (Text -> Text) -> Text -> Doc SyntaxClass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Text) -> Text -> Text
T.concatMap (Config -> Char -> Text
escapeStrChar Config
cfg)
ppLine :: [(Doc SyntaxClass, Doc SyntaxClass)] -> Doc SyntaxClass
ppLine :: [(Doc SyntaxClass, Doc SyntaxClass)] -> Doc SyntaxClass
ppLine [(Doc SyntaxClass, Doc SyntaxClass)]
ws =
Doc SyntaxClass -> Doc SyntaxClass
forall ann. Doc ann -> Doc ann
P.group (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$ (Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass)
-> (Doc SyntaxClass, Doc SyntaxClass) -> Doc SyntaxClass
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
(<>) ((Doc SyntaxClass, Doc SyntaxClass) -> Doc SyntaxClass)
-> (Doc SyntaxClass, Doc SyntaxClass) -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$ ((Doc SyntaxClass, Doc SyntaxClass)
-> (Doc SyntaxClass, Doc SyntaxClass)
-> (Doc SyntaxClass, Doc SyntaxClass))
-> ((Doc SyntaxClass, Doc SyntaxClass)
-> (Doc SyntaxClass, Doc SyntaxClass))
-> (Doc SyntaxClass, Doc SyntaxClass)
-> [(Doc SyntaxClass, Doc SyntaxClass)]
-> (Doc SyntaxClass, Doc SyntaxClass)
forall b a. (b -> a -> b) -> (a -> b) -> b -> [a] -> b
foldl01
(\(Doc SyntaxClass
line, Doc SyntaxClass
space) (Doc SyntaxClass
w, Doc SyntaxClass
space') ->
( Doc SyntaxClass
line Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Doc ann -> Doc ann
P.group (Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Doc ann -> Doc ann -> Doc ann
P.flatAlt (Doc SyntaxClass
space Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
backslashBreak) Doc SyntaxClass
space Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
w)
, Doc SyntaxClass
space'
))
(Doc SyntaxClass, Doc SyntaxClass)
-> (Doc SyntaxClass, Doc SyntaxClass)
forall a. a -> a
id
(Doc SyntaxClass, Doc SyntaxClass)
forall a. Monoid a => a
mempty
[(Doc SyntaxClass, Doc SyntaxClass)]
ws
backslashBreak :: Doc SyntaxClass
backslashBreak = SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
EscapeSequence (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$ Doc SyntaxClass
"\\" Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
forall ann. Doc ann
P.line' Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
"\\"
toDocAssocPrecF
:: Config
-> PortrayalF (DocAssocPrec SyntaxClass)
-> DocAssocPrec SyntaxClass
toDocAssocPrecF :: Config
-> PortrayalF (DocAssocPrec SyntaxClass)
-> DocAssocPrec SyntaxClass
toDocAssocPrecF Config
cfg = \case
NameF Ident
nm -> \Assoc
_ Rational
_ -> Ident -> Doc SyntaxClass
ppPrefix Ident
nm
LitIntF Integer
x -> \Assoc
_ Rational
_ -> SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate (LitKind -> SyntaxClass
Literal LitKind
IntLit) (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$ Integer -> Doc SyntaxClass
forall a ann. Pretty a => a -> Doc ann
pretty Integer
x
LitRatF Rational
x -> \Assoc
_ Rational
_ ->
SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate (LitKind -> SyntaxClass
Literal LitKind
RatLit) (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$ Double -> Doc SyntaxClass
forall a ann. Pretty a => a -> Doc ann
pretty (Rational -> Double
forall a. Fractional a => Rational -> a
fromRational Rational
x :: Double)
LitStrF Text
x -> \Assoc
_ Rational
_ -> Config -> Text -> Doc SyntaxClass
ppStrLit Config
cfg Text
x
LitCharF Char
x -> \Assoc
_ Rational
_ ->
SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate (LitKind -> SyntaxClass
Literal LitKind
CharLit) (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$
Doc SyntaxClass
-> Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
P.enclose Doc SyntaxClass
"'" Doc SyntaxClass
"'" (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$
(if Config -> Char -> Bool
litCharIsEscaped Config
cfg Char
x then SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
EscapeSequence else Doc SyntaxClass -> Doc SyntaxClass
forall a. a -> a
id) (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$
Text -> Doc SyntaxClass
forall ann. Text -> Doc ann
text (Text -> Doc SyntaxClass) -> Text -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$ Config -> Char -> Text
escapeLitChar Config
cfg Char
x
OpaqueF Text
txt -> \Assoc
_ Rational
_ -> Text -> Doc SyntaxClass
forall ann. Text -> Doc ann
text Text
txt
ApplyF DocAssocPrec SyntaxClass
fn [] -> \Assoc
_ Rational
_ -> DocAssocPrec SyntaxClass
fn Assoc
AssocL Rational
10
ApplyF DocAssocPrec SyntaxClass
fn [DocAssocPrec SyntaxClass]
xs -> \Assoc
lr Rational
p ->
Bool -> Doc SyntaxClass -> Doc SyntaxClass
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 SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$
Int -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Int -> Doc ann -> Doc ann
P.nest Int
2 (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$ [Doc SyntaxClass] -> Doc SyntaxClass
forall ann. [Doc ann] -> Doc ann
P.sep
[ DocAssocPrec SyntaxClass
fn Assoc
AssocL Rational
10
, [Doc SyntaxClass] -> Doc SyntaxClass
forall ann. [Doc ann] -> Doc ann
P.sep ([Doc SyntaxClass] -> Doc SyntaxClass)
-> [Doc SyntaxClass] -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$ [DocAssocPrec SyntaxClass]
xs [DocAssocPrec SyntaxClass]
-> (DocAssocPrec SyntaxClass -> Doc SyntaxClass)
-> [Doc SyntaxClass]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \DocAssocPrec SyntaxClass
docprec -> DocAssocPrec SyntaxClass
docprec Assoc
AssocR Rational
10
]
BinopF Ident
nm Infixity
fx DocAssocPrec SyntaxClass
x DocAssocPrec SyntaxClass
y -> Ident
-> Infixity
-> DocAssocPrec SyntaxClass
-> DocAssocPrec SyntaxClass
-> DocAssocPrec SyntaxClass
ppBinop Ident
nm Infixity
fx DocAssocPrec SyntaxClass
x DocAssocPrec SyntaxClass
y
TupleF [DocAssocPrec SyntaxClass]
xs -> \Assoc
_ Rational
_ -> Doc SyntaxClass
-> Doc SyntaxClass
-> Doc SyntaxClass
-> [Doc SyntaxClass]
-> Doc SyntaxClass
ppBulletList Doc SyntaxClass
"(" Doc SyntaxClass
"," Doc SyntaxClass
")" ([Doc SyntaxClass] -> Doc SyntaxClass)
-> [Doc SyntaxClass] -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$ [DocAssocPrec SyntaxClass]
xs [DocAssocPrec SyntaxClass]
-> (DocAssocPrec SyntaxClass -> Doc SyntaxClass)
-> [Doc SyntaxClass]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \DocAssocPrec SyntaxClass
x -> DocAssocPrec SyntaxClass
x Assoc
AssocNope (-Rational
1)
ListF [DocAssocPrec SyntaxClass]
xs -> \Assoc
_ Rational
_ -> Doc SyntaxClass
-> Doc SyntaxClass
-> Doc SyntaxClass
-> [Doc SyntaxClass]
-> Doc SyntaxClass
ppBulletList Doc SyntaxClass
"[" Doc SyntaxClass
"," Doc SyntaxClass
"]" ([Doc SyntaxClass] -> Doc SyntaxClass)
-> [Doc SyntaxClass] -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$ [DocAssocPrec SyntaxClass]
xs [DocAssocPrec SyntaxClass]
-> (DocAssocPrec SyntaxClass -> Doc SyntaxClass)
-> [Doc SyntaxClass]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \DocAssocPrec SyntaxClass
x -> DocAssocPrec SyntaxClass
x Assoc
AssocNope (-Rational
1)
LambdaCaseF [(DocAssocPrec SyntaxClass, DocAssocPrec SyntaxClass)]
xs -> \Assoc
_ Rational
p ->
Bool -> Doc SyntaxClass -> Doc SyntaxClass
maybeParens (Rational
p Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= Rational
10) (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$
Int -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Int -> Doc ann -> Doc ann
P.nest Int
2 (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$ [Doc SyntaxClass] -> Doc SyntaxClass
forall ann. [Doc ann] -> Doc ann
P.sep
[ SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Structural Doc SyntaxClass
"\\" Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Keyword Doc SyntaxClass
"case"
, Doc SyntaxClass
-> Doc SyntaxClass
-> Doc SyntaxClass
-> [Doc SyntaxClass]
-> Doc SyntaxClass
ppBulletList Doc SyntaxClass
"{" Doc SyntaxClass
";" Doc SyntaxClass
"}"
[ Int -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Int -> Doc ann -> Doc ann
P.nest Int
2 (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$ [Doc SyntaxClass] -> Doc SyntaxClass
forall ann. [Doc ann] -> Doc ann
P.sep ([Doc SyntaxClass] -> Doc SyntaxClass)
-> [Doc SyntaxClass] -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$
[ DocAssocPrec SyntaxClass
pat Assoc
AssocNope Rational
0 Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Doc ann -> Doc ann -> Doc ann
P.<+> SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Structural Doc SyntaxClass
"->"
, DocAssocPrec SyntaxClass
val Assoc
AssocNope Rational
0
]
| (DocAssocPrec SyntaxClass
pat, DocAssocPrec SyntaxClass
val) <- [(DocAssocPrec SyntaxClass, DocAssocPrec SyntaxClass)]
xs
]
]
RecordF DocAssocPrec SyntaxClass
con [FactorPortrayal (DocAssocPrec SyntaxClass)]
sels -> \Assoc
_ Rational
_ -> case [FactorPortrayal (DocAssocPrec SyntaxClass)]
sels of
[] -> DocAssocPrec SyntaxClass
con Assoc
AssocNope (-Rational
1)
[FactorPortrayal (DocAssocPrec SyntaxClass)]
_ -> Int -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Int -> Doc ann -> Doc ann
P.nest Int
2 (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$ [Doc SyntaxClass] -> Doc SyntaxClass
forall ann. [Doc ann] -> Doc ann
P.sep
[ DocAssocPrec SyntaxClass
con Assoc
AssocNope Rational
10
, Doc SyntaxClass
-> Doc SyntaxClass
-> Doc SyntaxClass
-> [Doc SyntaxClass]
-> Doc SyntaxClass
ppBulletList Doc SyntaxClass
"{" Doc SyntaxClass
"," Doc SyntaxClass
"}"
[ Int -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Int -> Doc ann -> Doc ann
P.nest Int
4 (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$ [Doc SyntaxClass] -> Doc SyntaxClass
forall ann. [Doc ann] -> Doc ann
P.sep
[ Ident -> Doc SyntaxClass
ppPrefix Ident
sel Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Doc ann -> Doc ann -> Doc ann
P.<+> SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Structural Doc SyntaxClass
"="
, DocAssocPrec SyntaxClass
val Assoc
AssocNope Rational
0
]
| FactorPortrayal Ident
sel DocAssocPrec SyntaxClass
val <- [FactorPortrayal (DocAssocPrec SyntaxClass)]
sels
]
]
TyAppF DocAssocPrec SyntaxClass
val DocAssocPrec SyntaxClass
ty -> \Assoc
_ Rational
_ ->
Int -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Int -> Doc ann -> Doc ann
P.nest Int
2 (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$ [Doc SyntaxClass] -> Doc SyntaxClass
forall ann. [Doc ann] -> Doc ann
P.sep
[ DocAssocPrec SyntaxClass
val Assoc
AssocNope Rational
10
, SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Structural Doc SyntaxClass
"@" Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<> DocAssocPrec SyntaxClass
ty Assoc
AssocNope Rational
10
]
TySigF DocAssocPrec SyntaxClass
val DocAssocPrec SyntaxClass
ty -> \Assoc
_ Rational
p -> Bool -> Doc SyntaxClass -> Doc SyntaxClass
maybeParens (Rational
p Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
>= Rational
0) (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$
Int -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Int -> Doc ann -> Doc ann
P.nest Int
2 (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$ [Doc SyntaxClass] -> Doc SyntaxClass
forall ann. [Doc ann] -> Doc ann
P.sep
[ DocAssocPrec SyntaxClass
val Assoc
AssocNope Rational
0
, SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Structural Doc SyntaxClass
"::" Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Doc ann -> Doc ann -> Doc ann
P.<+> DocAssocPrec SyntaxClass
ty Assoc
AssocNope Rational
0
]
QuotF Text
nm DocAssocPrec SyntaxClass
content -> \Assoc
_ Rational
_ ->
Int -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Int -> Doc ann -> Doc ann
P.nest Int
2 (Doc SyntaxClass -> Doc SyntaxClass)
-> Doc SyntaxClass -> Doc SyntaxClass
forall a b. (a -> b) -> a -> b
$ [Doc SyntaxClass] -> Doc SyntaxClass
forall ann. [Doc ann] -> Doc ann
P.sep
[ SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Structural Doc SyntaxClass
"[" Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<>
SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate (IdentKind -> SyntaxClass
Identifier IdentKind
VarIdent) (Text -> Doc SyntaxClass
forall ann. Text -> Doc ann
text Text
nm) Doc SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall a. Semigroup a => a -> a -> a
<>
SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Structural Doc SyntaxClass
"|"
, DocAssocPrec SyntaxClass
content Assoc
AssocNope (-Rational
1)
, SyntaxClass -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Structural Doc SyntaxClass
"|]"
]
UnlinesF [DocAssocPrec SyntaxClass]
ls -> \Assoc
_ Rational
_ -> [Doc SyntaxClass] -> Doc SyntaxClass
forall ann. [Doc ann] -> Doc ann
P.vcat ([DocAssocPrec SyntaxClass]
ls [DocAssocPrec SyntaxClass]
-> (DocAssocPrec SyntaxClass -> Doc SyntaxClass)
-> [Doc SyntaxClass]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \DocAssocPrec SyntaxClass
l -> DocAssocPrec SyntaxClass
l Assoc
AssocNope (-Rational
1))
NestF Int
n DocAssocPrec SyntaxClass
x -> \Assoc
_ Rational
_ -> Int -> Doc SyntaxClass -> Doc SyntaxClass
forall ann. Int -> Doc ann -> Doc ann
P.nest Int
n (DocAssocPrec SyntaxClass
x Assoc
AssocNope (-Rational
1))
toDocAssocPrec :: Config -> Portrayal -> DocAssocPrec SyntaxClass
toDocAssocPrec :: Config -> Portrayal -> DocAssocPrec SyntaxClass
toDocAssocPrec Config
cfg = (PortrayalF (DocAssocPrec SyntaxClass) -> DocAssocPrec SyntaxClass)
-> Fix PortrayalF -> DocAssocPrec SyntaxClass
forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
cata (Config
-> PortrayalF (DocAssocPrec SyntaxClass)
-> DocAssocPrec SyntaxClass
toDocAssocPrecF Config
cfg) (Fix PortrayalF -> DocAssocPrec SyntaxClass)
-> (Portrayal -> Fix PortrayalF)
-> Portrayal
-> DocAssocPrec SyntaxClass
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Portrayal -> Fix PortrayalF
unPortrayal
basicShowPortrayal :: Portrayal -> Text
basicShowPortrayal :: Portrayal -> Text
basicShowPortrayal = Config -> (SyntaxClass -> Maybe AnsiStyle) -> Portrayal -> Text
styleShowPortrayal Config
defaultConfig (Maybe AnsiStyle -> SyntaxClass -> Maybe AnsiStyle
forall a b. a -> b -> a
const Maybe AnsiStyle
forall a. Monoid a => a
mempty)
prettyShowPortrayal :: Portrayal -> Text
prettyShowPortrayal :: Portrayal -> Text
prettyShowPortrayal =
Config -> (SyntaxClass -> Maybe AnsiStyle) -> Portrayal -> Text
styleShowPortrayal
(Config
defaultConfig Config -> (Config -> Config) -> Config
forall a b. a -> (a -> b) -> b
& (Char -> Bool) -> Config -> Config
setShouldEscapeChar Char -> Bool
escapeSpecialOnly)
SyntaxClass -> Maybe AnsiStyle
defaultStyling
styleShowPortrayal
:: Config -> (SyntaxClass -> Maybe A.AnsiStyle) -> Portrayal -> Text
styleShowPortrayal :: Config -> (SyntaxClass -> Maybe AnsiStyle) -> Portrayal -> Text
styleShowPortrayal Config
cfg SyntaxClass -> Maybe AnsiStyle
style Portrayal
p =
SimpleDocStream AnsiStyle -> Text
A.renderStrict (SimpleDocStream AnsiStyle -> Text)
-> SimpleDocStream AnsiStyle -> Text
forall a b. (a -> b) -> a -> b
$ (SyntaxClass -> Maybe AnsiStyle)
-> SimpleDocStream SyntaxClass -> SimpleDocStream AnsiStyle
forall ann ann'.
(ann -> Maybe ann') -> SimpleDocStream ann -> SimpleDocStream ann'
P.alterAnnotationsS SyntaxClass -> Maybe AnsiStyle
style (SimpleDocStream SyntaxClass -> SimpleDocStream AnsiStyle)
-> SimpleDocStream SyntaxClass -> SimpleDocStream AnsiStyle
forall a b. (a -> b) -> a -> b
$
LayoutOptions -> Doc SyntaxClass -> SimpleDocStream SyntaxClass
forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
P.layoutPretty LayoutOptions
P.defaultLayoutOptions (Doc SyntaxClass -> SimpleDocStream SyntaxClass)
-> Doc SyntaxClass -> SimpleDocStream SyntaxClass
forall a b. (a -> b) -> a -> b
$
Config -> Portrayal -> DocAssocPrec SyntaxClass
toDocAssocPrec Config
cfg 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 -> [Char]
(Int -> WrappedPortray a -> ShowS)
-> (WrappedPortray a -> [Char])
-> ([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 -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [WrappedPortray a] -> ShowS
$cshowList :: forall a. Show a => [WrappedPortray a] -> ShowS
show :: WrappedPortray a -> [Char]
$cshow :: forall a. Show a => WrappedPortray a -> [Char]
showsPrec :: Int -> WrappedPortray a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> WrappedPortray a -> ShowS
Show)
instance Portray a => Pretty (WrappedPortray a) where
pretty :: WrappedPortray a -> Doc ann
pretty WrappedPortray a
x =
Doc SyntaxClass -> Doc ann
forall ann xxx. Doc ann -> Doc xxx
P.unAnnotate (Doc SyntaxClass -> Doc ann) -> Doc SyntaxClass -> Doc ann
forall a b. (a -> b) -> a -> b
$ Config -> Portrayal -> Doc SyntaxClass
portrayalToDoc Config
defaultConfig (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)