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

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

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

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

-- | 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 -> 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  -- Context has higher precedence than this binop.
  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

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

-- | A subtler style that colorizes only operators (blue) and literals (cyan).
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

-- | Disable all syntax highlighting.
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

-- | An escape-sequence predicate to escape any non-ASCII character.
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

-- | An escape-sequence predicate to escape as little as possible.
escapeSpecialOnly :: Char -> Bool
escapeSpecialOnly :: Char -> Bool
escapeSpecialOnly = Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
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
  { Config -> Char -> Bool
_shouldEscapeChar :: Char -> Bool
  }

-- | Set the predicate for whether to escape a given character; see 'Config'.
setShouldEscapeChar :: (Char -> Bool) -> Config -> Config
setShouldEscapeChar :: (Char -> Bool) -> Config -> Config
setShouldEscapeChar Char -> Bool
f Config
_ = (Char -> Bool) -> Config
Config Char -> Bool
f

-- | A sensible default configuration to build on.
--
-- Uses 'escapeNonASCII'.
defaultConfig :: Config
defaultConfig :: Config
defaultConfig = (Char -> Bool) -> Config
Config Char -> Bool
escapeNonASCII

-- | Convert a 'Portrayal' to a 'Doc'.
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
')')

-- Conditionally wrap a document in parentheses.
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

-- Convert Text to a document; 'pretty' specialized to 'Text'.
text :: Text -> Doc ann
text :: Text -> Doc ann
text = Text -> Doc ann
forall a ann. Pretty a => a -> Doc ann
pretty

-- Convert a Char to a document; 'pretty' specialized to 'Char'.
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 -- ^ Open brace,  e.g. {  [  {  (
  -> Doc SyntaxClass -- ^ Separator,   e.g. ;  ,  ,  ,
  -> Doc SyntaxClass -- ^ Close brace, e.g. }  ]  }  )
  -> [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

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

-- 'T.lines' also fails to distinguish trailing newlines... ugh.
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)

-- Returns True for characters that must always be escaped regardless of
-- configuration; this is unprintable characters and backlashes.
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

-- 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 :: 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
$ -- Prefer putting the whole thing on this line whenever possible.
  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
$
  -- Then prefer breaking on newlines when the next line doesn't fit.
  (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 =
          -- Do we need to insert a \& to separate a numeric escape from a
          -- following digit?
          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 =
    -- Finally, break at word boundaries if the next word doesn't fit.
    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
"\\"

-- | Render one layer of 'PortrayalF' to 'DocAssocPrec'.
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
_ ->
    -- Likewise Char
    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))

-- | Render a 'Portrayal' to a 'Doc' with support for operator associativity.
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

-- | Convenience function for rendering a 'Portrayal' to a 'Text'.
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)

-- | Convenience function for rendering a 'Portrayal' to colorized 'Text'.
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

-- | Convenience function for rendering a 'Portrayal' to stylized 'Text'.
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)

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

-- | Provide an instance for 'Pretty' by way of 'Portray'.
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)