-- Copyright 2021 Google LLC
--
-- Licensed under the Apache License, Version 2.0 (the "License");
-- you may not use this file except in compliance with the License.
-- You may obtain a copy of the License at
--
-- http://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS,
-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
-- See the License for the specific language governing permissions and
-- limitations under the License.
-- | Provides rendering of 'Portrayal' to 'Doc'.
--
-- There are two intended uses of this module: firstly, to use @prettyprinter@'s
-- layout and rendering algorithms to render 'Portray' instances, 'Diff's, or
-- other 'Portrayal's; and secondly, to derive 'Pretty' instances based on
-- existing 'Portray' instances. I find the former more ergonomic, but in
-- established codebases that want to benefit from deriving, the latter may be
-- more achievable.
--
-- The first usage is for codebases with pervasive use of 'Portray', and
-- involves using e.g. 'pp' and 'ppd' in GHCi, or 'showPortrayal' or 'showDiff'
-- in application code. With this usage, anything you want to pretty-print
-- needs a 'Portray' instance, and the typeclass 'Pretty' is not involved in
-- any way. With this approach, pretty-printable types and the types they
-- include should derive only 'Portray', and pretty-printing should be done
-- with the aforementioned utility functions:
--
-- @
-- data MyRecord = MyRecord { anInt :: Int, anotherRecord :: MyOtherRecord }
-- deriving Generic
-- deriving Portray via Wrapped Generic MyRecord
--
-- example = 'showPortrayal' (MyRecord 2 ...)
-- @
--
-- This usage provides colorized pretty-printing by default with 'pp'. Note if
-- you don't like the default choice of colors or don't want colors at all, you
-- can roll your own 'pp' function with 'portray', 'toDocAssocPrec' and your
-- @prettyprinter@ rendering backend of choice.
--
-- The second usage is to use @portray@'s generic deriving to provide derived
-- 'Pretty' instances, in a codebase that uses 'Pretty' as the preferred
-- typeclass for pretty-printable values. With this usage, things you want to
-- pretty-print need 'Pretty' instances, and 'Portray' is needed for the
-- transitive closure of types included in types you want to derive 'Pretty'
-- instances for. This may result in many types needing both instances of both
-- 'Pretty' (for direct pretty-printing) and 'Portray' (for deriving 'Portray'
-- on downstream types) instances. Note that with this approach, types that
-- derive their 'Pretty' instances via 'Portray' will ignore any custom
-- 'Pretty' instances of nested types, since they recurse to nested 'Portray'
-- instances instead.
--
-- To derive an instance for a pretty-printable type, the type itself should
-- look like the following:
--
-- @
-- data MyRecord = MyRecord { anInt :: Int, anotherRecord :: MyOtherRecord }
-- deriving Generic
-- deriving Portray via Wrapped Generic MyRecord
-- deriving Pretty via WrappedPortray MyRecord
--
-- example = 'R.renderStrict' $ 'pretty' (MyRecord 2 ...)
-- @
--
-- And any types transitively included in it should look like the following:
--
-- @
-- data MyOtherRecord = MyOtherRecord
-- deriving Generic
-- deriving Portray via Wrapped Generic MyRecord
-- @
--
-- Since the 'Pretty' class requires a universally-quantified annotation type,
-- its instances cannot provide any annotations. As such, this usage cannot
-- provide automatic colorization.
--
-- This module also exports the underlying rendering functionality in a variety
-- of forms for more esoteric uses.
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.Portray.Prettyprinter
( -- * Pretty-Printing
showPortrayal, pp
-- * Diffing
, showDiff, ppd
-- * DerivingVia wrapper
, WrappedPortray(..)
-- * Rendering
-- ** Configuration
, Config, defaultConfig
-- *** Escape Sequences
, setShouldEscapeChar, escapeNonASCII, escapeSpecialOnly
-- ** Colorization
, SyntaxClass(..), LitKind(..)
, defaultStyling, subtleStyling, noStyling
-- ** With Associativity
, DocAssocPrec, toDocAssocPrecF, toDocAssocPrec
-- ** Convenience Functions
, 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 -- for ANSI
import qualified Prettyprinter as P
import Data.Portray
( Assoc(..), Infixity(..), FactorPortrayal(..)
, Ident(..), IdentKind(..)
, Portray, Portrayal(..), PortrayalF(..)
, cata, portray
)
import Data.Portray.Diff (Diff(..))
-- | Pretty-print a value to stdout using its 'Portray' instance.
--
-- This uses ANSI color codes, so take care not to use it in contexts where it
-- might output to something other than a terminal.
pp :: Portray a => a -> IO ()
pp = T.putStrLn . prettyShowPortrayal . portray
-- | Pretty-print a value using its 'Portray' instance.
--
-- This uses no ANSI terminal escape codes and escapes all non-ASCII characters.
showPortrayal :: Portray a => a -> Text
showPortrayal = basicShowPortrayal . portray
-- | Pretty-print a diff between two values to stdout using a 'Diff' instance.
--
-- This uses ANSI color codes, so take care not to use it in contexts where it
-- might output to something other than a terminal.
ppd :: Diff a => a -> a -> IO ()
ppd x = T.putStrLn . maybe "_" prettyShowPortrayal . diff x
-- | Pretty-print a diff between two values using a 'Diff' instance.
--
-- This uses no ANSI terminal escape codes and escapes all non-ASCII characters.
showDiff :: Diff a => a -> a -> Text
showDiff x = maybe "_" basicShowPortrayal . diff x
-- | A 'Doc' that varies according to associativity and precedence context.
type DocAssocPrec ann = Assoc -> Rational -> Doc ann
fixityCompatible :: Infixity -> Assoc -> Rational -> Bool
fixityCompatible (Infixity assoc p) assoc' p' = case compare p' p of
GT -> False -- Context has higher precedence than this binop.
EQ -> assoc == assoc'
LT -> True
matchCtx :: Assoc -> Assoc -> Assoc
matchCtx ctx assoc
| ctx == assoc = ctx
| otherwise = AssocNope
-- | The particular kind of literal represented by a 'Literal'.
data LitKind = IntLit | RatLit | CharLit | StrLit
-- | The kind of syntactic element represented by an annotated 'Doc'.
data SyntaxClass
= Identifier IdentKind
-- ^ Identifiers, whether alphanumeric names or operators.
| Literal LitKind
-- ^ Literals, including integers, floats/rationals, chars, and strings.
| EscapeSequence
-- ^ Escaped characters in strings and char literals.
| Keyword
-- ^ Alphanumeric keywords, e.g. @case@.
| Bracket
-- ^ Matched pairs of symbols that denote nesting, e.g. parens.
| Separator
-- ^ Syntactic separators/terminators, e.g. @,@ and @;@.
| Structural
-- ^ Other fixed syntactic symbols, e.g. @::@, @\@@, @->@, @\\@.
-- | A fairly arbitrary colorization style based on what looked good to me.
--
-- To use a custom color mapping, define it the same way this function is
-- defined, then use it as an argument to 'styleShowPortrayal'.
-- Consider also wrapping that up into a custom 'pp' function for use at the
-- REPL or even as the interactive print function.
defaultStyling :: SyntaxClass -> Maybe A.AnsiStyle
defaultStyling = Just . \case
Identifier k -> case k of
OpConIdent -> A.color A.Magenta
OpIdent -> A.colorDull A.Yellow
ConIdent -> mempty
VarIdent -> mempty
Literal k -> case k of
StrLit -> A.colorDull A.Blue
_ -> A.colorDull A.Cyan
EscapeSequence -> A.colorDull A.Red
Keyword -> A.colorDull A.Green
Bracket -> mempty
Separator -> mempty
Structural -> A.colorDull A.Green
-- | A subtler style that colorizes only operators (blue) and literals (cyan).
subtleStyling :: SyntaxClass -> Maybe A.AnsiStyle
subtleStyling = Just . \case
Identifier k -> case k of
OpConIdent -> A.colorDull A.Blue
OpIdent -> A.colorDull A.Blue
_ -> mempty
Literal _ -> A.colorDull A.Cyan
EscapeSequence -> A.colorDull A.Cyan
_ -> mempty
-- | Disable all syntax highlighting.
noStyling :: SyntaxClass -> Maybe A.AnsiStyle
noStyling = const Nothing
-- | An escape-sequence predicate to escape any non-ASCII character.
escapeNonASCII :: Char -> Bool
escapeNonASCII = not . isAscii
-- | An escape-sequence predicate to escape as little as possible.
escapeSpecialOnly :: Char -> Bool
escapeSpecialOnly = const False
-- | Configuration for the conversion to 'Doc'.
--
-- Includes the following:
--
-- * 'setShouldEscapeChar', a function determining whether an escapable
-- character should be escaped in a string or character literal. Unprintable
-- characters, backslashes, and the relevant quote for the current literal type
-- are always escaped, and anything that wouldn't be escaped by 'Show' is never
-- escaped.
--
-- For forwards-compatibility reasons, the field selectors and constructor of
-- this type are hidden; use the provided setters to build a config. For
-- example:
--
-- @
-- config =
-- defaultConfig
-- & setShouldEscapeChar (const True) -- Escape everything we can.
-- @
data Config = Config
{ _shouldEscapeChar :: Char -> Bool
}
-- | Set the predicate for whether to escape a given character; see 'Config'.
setShouldEscapeChar :: (Char -> Bool) -> Config -> Config
setShouldEscapeChar f _ = Config f
-- | A sensible default configuration to build on.
--
-- Uses 'escapeNonASCII'.
defaultConfig :: Config
defaultConfig = Config escapeNonASCII
-- | Convert a 'Portrayal' to a 'Doc'.
portrayalToDoc :: Config -> Portrayal -> Doc SyntaxClass
portrayalToDoc cfg t = toDocAssocPrec cfg t AssocNope (-1)
parens :: Doc SyntaxClass -> Doc SyntaxClass
parens d =
P.annotate Bracket (char '(') <> d <> P.annotate Bracket (char ')')
-- Conditionally wrap a document in parentheses.
maybeParens :: Bool -> Doc SyntaxClass -> Doc SyntaxClass
maybeParens = \case True -> parens; False -> id
-- Convert Text to a document; 'pretty' specialized to 'Text'.
text :: Text -> Doc ann
text = pretty
-- Convert a Char to a document; 'pretty' specialized to 'Char'.
char :: Char -> Doc ann
char = pretty
ppInfix :: Ident -> Doc SyntaxClass
ppInfix (Ident k nm) = case k of
OpConIdent -> nmDoc
OpIdent -> nmDoc
VarIdent -> wrappedNm
ConIdent -> wrappedNm
where
backquote = P.annotate Structural (char '`')
nmDoc = P.annotate (Identifier k) (text nm)
wrappedNm = backquote <> nmDoc <> backquote
ppPrefix :: Ident -> Doc SyntaxClass
ppPrefix (Ident k nm) = case k of
OpConIdent -> wrappedNm
OpIdent -> wrappedNm
VarIdent -> nmDoc
ConIdent -> nmDoc
where
nmDoc = P.annotate (Identifier k) (text nm)
wrappedNm = parens nmDoc
ppBinop
:: Ident
-> Infixity
-> DocAssocPrec SyntaxClass
-> DocAssocPrec SyntaxClass
-> DocAssocPrec SyntaxClass
ppBinop nm fx@(Infixity assoc opPrec) x y lr p =
maybeParens (not $ fixityCompatible fx lr p) $ P.nest 2 $ P.sep
[ x (matchCtx AssocL assoc) opPrec P.<+> ppInfix nm
, y (matchCtx AssocR assoc) opPrec
]
ppBulletList
:: Doc SyntaxClass -- ^ Open brace, e.g. { [ { (
-> Doc SyntaxClass -- ^ Separator, e.g. ; , , ,
-> Doc SyntaxClass -- ^ Close brace, e.g. } ] } )
-> [Doc SyntaxClass]
-> Doc SyntaxClass
ppBulletList o s c = \case
[] -> opener <> closer
(doc:docs) ->
P.group $
foldl01
(\x y -> x <> P.group (P.line' <> y))
id
mempty
(opener <> P.flatAlt " " "" <> doc :
zipWith (P.<+>) (repeat separator) docs) <>
P.line' <> closer
where
opener = P.annotate Bracket o
separator = P.annotate Separator s
closer = P.annotate Bracket c
foldl01 :: (b -> a -> b) -> (a -> b) -> b -> [a] -> b
foldl01 f g z = \case
[] -> z
(x:xs) -> foldl f (g x) xs
-- 'T.words' coalesces adjacent spaces, so it's not suitable for use in
-- 'ppStrLit'; roll our own that preserves the whitespace between words.
wordsSep :: Text -> [(Text, Text)]
wordsSep "" = []
wordsSep s =
let isWhitespace = (`elem` [' ', '\t'])
(word, rest) = T.break isWhitespace s
(sep, rest') = T.span isWhitespace rest
in (word, sep) : wordsSep rest'
-- 'T.lines' also fails to distinguish trailing newlines... ugh.
linesSep :: Text -> [Text]
linesSep "" = []
linesSep s0 = go s0
where
go s =
let (line, rest) = T.break (== '\n') s
in line : if T.null rest then [] else go (T.tail rest)
-- Returns True for characters that must always be escaped regardless of
-- configuration; this is unprintable characters and backlashes.
charAlwaysEscaped :: Char -> Bool
charAlwaysEscaped c = not (isPrint c) || c == '\\'
shouldEscapeChar :: Config -> Char -> Bool
shouldEscapeChar cfg c = charAlwaysEscaped c || _shouldEscapeChar cfg c
showLitEscapesChar :: Char -> Bool
showLitEscapesChar c = [c] /= showLitChar c ""
litCharIsEscaped :: Config -> Char -> Bool
litCharIsEscaped cfg = \case
'\'' -> True
c -> showLitEscapesChar c && shouldEscapeChar cfg c
strCharIsEscaped :: Config -> Char -> Bool
strCharIsEscaped cfg = \case
'"' -> True
c -> showLitEscapesChar c && shouldEscapeChar cfg c
-- Between a numeric escape and a digit, or between \SO and H, we need a \& to
-- terminate the escape; detect whether we're in one of those cases.
needsEmptyEscape :: Config -> Char -> Char -> Bool
needsEmptyEscape cfg c0 c1 =
strCharIsEscaped cfg c0 &&
case showLitChar c0 "" of
"\\SO" -> c1 == 'H'
('\\' : c : _) -> isDigit c && isDigit c1
_ -> False
escapeChar :: Config -> Char -> Text
escapeChar cfg c
| shouldEscapeChar cfg c = T.pack (showLitChar c "")
| otherwise = T.singleton c
escapeLitChar :: Config -> Char -> Text
escapeLitChar cfg = \case
'\'' -> "\\'"
c -> escapeChar cfg c
escapeStrChar :: Config -> Char -> Text
escapeStrChar cfg = \case
'"' -> "\\\""
c -> escapeChar cfg c
ppStrLit :: Config -> Text -> Doc SyntaxClass
ppStrLit cfg unescaped =
P.annotate (Literal StrLit) $
P.group $ -- Prefer putting the whole thing on this line whenever possible.
P.enclose "\"" "\"" $
-- Then prefer breaking on newlines when the next line doesn't fit.
foldl01
(\x l ->
x <> P.group (P.flatAlt (nl <> backslashBreak <> l) (nl <> l)))
id
mempty
(ppLine <$> escapedLinesOfWords)
where
nl = P.annotate EscapeSequence "\\n"
ppWord :: Text -> Doc SyntaxClass
ppWord "" = mempty
ppWord w =
let (toEscape, rest) = T.span (strCharIsEscaped cfg) w
(plain, rest') = T.break (strCharIsEscaped cfg) rest
sep =
-- Do we need to insert a \& to separate a numeric escape from a
-- following digit?
if not (T.null toEscape) &&
not (T.null plain) &&
needsEmptyEscape cfg (T.last toEscape) (T.head plain)
then "\\&"
else mempty
escaped = pretty (T.concatMap (escapeStrChar cfg) toEscape) <> sep
in P.annotate EscapeSequence escaped <> text plain <> ppWord rest'
escapedLinesOfWords :: [[(Doc SyntaxClass, Doc SyntaxClass)]]
escapedLinesOfWords =
map
(\ (w, ws) -> (ppWord w, ppWhitespace ws)) .
wordsSep <$>
linesSep unescaped
ppWhitespace :: Text -> Doc SyntaxClass
ppWhitespace =
P.annotate EscapeSequence .
text . T.concatMap (escapeStrChar cfg)
ppLine :: [(Doc SyntaxClass, Doc SyntaxClass)] -> Doc SyntaxClass
ppLine ws =
-- Finally, break at word boundaries if the next word doesn't fit.
P.group $ uncurry (<>) $ foldl01
(\(line, space) (w, space') ->
( line <> P.group (P.flatAlt (space <> backslashBreak) space <> w)
, space'
))
id
mempty
ws
backslashBreak = P.annotate EscapeSequence $ "\\" <> P.line' <> "\\"
-- | Render one layer of 'PortrayalF' to 'DocAssocPrec'.
toDocAssocPrecF
:: Config
-> PortrayalF (DocAssocPrec SyntaxClass)
-> DocAssocPrec SyntaxClass
toDocAssocPrecF cfg = \case
NameF nm -> \_ _ -> ppPrefix nm
LitIntF x -> \_ _ -> P.annotate (Literal IntLit) $ pretty x
LitRatF x -> \_ _ ->
P.annotate (Literal RatLit) $ pretty (fromRational x :: Double)
LitStrF x -> \_ _ -> ppStrLit cfg x
LitCharF x -> \_ _ ->
-- Likewise Char
P.annotate (Literal CharLit) $
P.enclose "'" "'" $
(if litCharIsEscaped cfg x then P.annotate EscapeSequence else id) $
text $ escapeLitChar cfg x
OpaqueF txt -> \_ _ -> text txt
ApplyF fn [] -> \_ _ -> fn AssocL 10
ApplyF fn xs -> \lr p ->
maybeParens (not $ fixityCompatible (Infixity AssocL 10) lr p) $
P.nest 2 $ P.sep
[ fn AssocL 10
, P.sep $ xs <&> \docprec -> docprec AssocR 10
]
BinopF nm fx x y -> ppBinop nm fx x y
TupleF xs -> \_ _ -> ppBulletList "(" "," ")" $ xs <&> \x -> x AssocNope (-1)
ListF xs -> \_ _ -> ppBulletList "[" "," "]" $ xs <&> \x -> x AssocNope (-1)
LambdaCaseF xs -> \_ p ->
maybeParens (p >= 10) $
P.nest 2 $ P.sep
[ P.annotate Structural "\\" <> P.annotate Keyword "case"
, ppBulletList "{" ";" "}"
[ P.nest 2 $ P.sep $
[ pat AssocNope 0 P.<+> P.annotate Structural "->"
, val AssocNope 0
]
| (pat, val) <- xs
]
]
RecordF con sels -> \_ _ -> case sels of
[] -> con AssocNope (-1)
_ -> P.nest 2 $ P.sep
[ con AssocNope 10
, ppBulletList "{" "," "}"
[ P.nest 4 $ P.sep
[ ppPrefix sel P.<+> P.annotate Structural "="
, val AssocNope 0
]
| FactorPortrayal sel val <- sels
]
]
TyAppF val ty -> \_ _ ->
P.nest 2 $ P.sep
[ val AssocNope 10
, P.annotate Structural "@" <> ty AssocNope 10
]
TySigF val ty -> \_ p -> maybeParens (p >= 0) $
P.nest 2 $ P.sep
[ val AssocNope 0
, P.annotate Structural "::" P.<+> ty AssocNope 0
]
QuotF nm content -> \_ _ ->
P.nest 2 $ P.sep
[ P.annotate Structural "[" <>
P.annotate (Identifier VarIdent) (text nm) <>
P.annotate Structural "|"
, content AssocNope (-1)
, P.annotate Structural "|]"
]
UnlinesF ls -> \_ _ -> P.vcat (ls <&> \l -> l AssocNope (-1))
NestF n x -> \_ _ -> P.nest n (x AssocNope (-1))
-- | Render a 'Portrayal' to a 'Doc' with support for operator associativity.
toDocAssocPrec :: Config -> Portrayal -> DocAssocPrec SyntaxClass
toDocAssocPrec cfg = cata (toDocAssocPrecF cfg) . unPortrayal
-- | Convenience function for rendering a 'Portrayal' to a 'Text'.
basicShowPortrayal :: Portrayal -> Text
basicShowPortrayal = styleShowPortrayal defaultConfig (const mempty)
-- | Convenience function for rendering a 'Portrayal' to colorized 'Text'.
prettyShowPortrayal :: Portrayal -> Text
prettyShowPortrayal =
styleShowPortrayal
(defaultConfig & setShouldEscapeChar escapeSpecialOnly)
defaultStyling
-- | Convenience function for rendering a 'Portrayal' to stylized 'Text'.
styleShowPortrayal
:: Config -> (SyntaxClass -> Maybe A.AnsiStyle) -> Portrayal -> Text
styleShowPortrayal cfg style p =
A.renderStrict $ P.alterAnnotationsS style $
P.layoutPretty P.defaultLayoutOptions $
toDocAssocPrec cfg p AssocNope (-1)
-- | A newtype providing a 'Pretty' instance via 'Portray', for @DerivingVia@.
--
-- Sadly we can't use @Wrapped@ since it would be an orphan instance. Oh well.
-- We'll just define a unique 'WrappedPortray' newtype in each
-- pretty-printer-integration package.
newtype WrappedPortray a = WrappedPortray { unWrappedPortray :: a }
deriving newtype (Eq, Ord, Show)
-- | Provide an instance for 'Pretty' by way of 'Portray'.
instance Portray a => Pretty (WrappedPortray a) where
pretty x =
P.unAnnotate $ portrayalToDoc defaultConfig (portray $ unWrappedPortray x)