-- Copyright 2021 Google LLC
-- Copyright 2022 Andrew Pritchard
--
-- 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 CPP #-}
{-# 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, prettyConfig
           -- *** Escape Sequences
         , setShouldEscapeChar, escapeNonASCII, escapeSpecialOnly
           -- *** Numeric Literals
         , setTrimTrailingFloatZeros, setScientificNotationThreshold
         , setSeparatorGroupSizes
           -- ** Colorization
         , SyntaxClass(..), LitKind(..)
         , defaultStyling, subtleStyling, noStyling
           -- ** With Associativity
         , DocAssocPrec, toDocAssocPrecF, toDocAssocPrec
           -- ** Convenience Functions
         , portrayalToDoc
         , styleShowPortrayal, styleShowPortrayalLazy
         , prettyShowPortrayal, prettyShowPortrayalLazy
         , 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.Lazy as TL
import qualified Data.Text.Lazy.IO as T (putStrLn)
import GHC.Show (showLitChar)

#if MIN_VERSION_prettyprinter(1, 7, 0)
#define Prettyprinter_ Prettyprinter
#else
#define Prettyprinter_ Data.Text.Prettyprint.Doc
#endif

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
         , Base(..), FloatLiteral(..)
         , formatIntLit, formatFloatLit, formatSpecialFloat
         , normalizeFloatLit, trimFloatLit
         )
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 :: forall a. Portray a => a -> IO ()
pp = Text -> IO ()
T.putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. Portrayal -> Text
prettyShowPortrayalLazy forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. Portray a => a -> Text
showPortrayal = Portrayal -> Text
basicShowPortrayal forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. Diff a => a -> a -> IO ()
ppd a
x = Text -> IO ()
T.putStrLn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"_" Portrayal -> Text
prettyShowPortrayalLazy forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall a. Diff a => a -> a -> Text
showDiff a
x = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"_" Portrayal -> Text
basicShowPortrayal forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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 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 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 = forall a. a -> Maybe a
Just 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 -> forall a. Monoid a => a
mempty
    IdentKind
VarIdent -> 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 -> forall a. Monoid a => a
mempty
  SyntaxClass
Separator -> 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 = forall a. a -> Maybe a
Just 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
_ -> 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
_ -> forall a. Monoid a => a
mempty

-- | Disable all syntax highlighting.
noStyling :: SyntaxClass -> Maybe A.AnsiStyle
noStyling :: SyntaxClass -> Maybe AnsiStyle
noStyling = forall a b. a -> b -> a
const 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 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 = 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.
--
-- * 'setTrimTrailingFloatZeros', whether to trim trailing zeros in
-- floating-point literals.
--
-- * 'setScientificNotationThreshold', a limit on the number of padding
-- (non-precision) zeros in floating-point literals before switching to
-- scientific notation.
--
-- * 'setSeparatorGroupSizes', configuration of where to place underscores in
-- the whole-number part of integral and fractional literals.
--
-- 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.
--     & setTrimTrailingFloatZeros True
-- @
data Config = Config
  { Config -> Char -> Bool
_shouldEscapeChar :: Char -> Bool
  , Config -> Int
_scientificNotationThreshold :: Int
  , Config -> Bool
_trimTrailingFloatZeros :: Bool
  , Config -> Base -> [Int]
_separatorGroupSizes :: Base -> [Int]
  }

-- | 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
c = Config
c { _shouldEscapeChar :: Char -> Bool
_shouldEscapeChar = Char -> Bool
f }

-- | Configure trimming of trailing zeros from floating-point literals.
--
-- @since 0.2.1
setTrimTrailingFloatZeros :: Bool -> Config -> Config
setTrimTrailingFloatZeros :: Bool -> Config -> Config
setTrimTrailingFloatZeros Bool
b Config
c = Config
c { _trimTrailingFloatZeros :: Bool
_trimTrailingFloatZeros = Bool
b }

-- | Configure the number of zeros to pad with before using scientific notation.
--
-- If the radix point is within or adjaecent to the specified digits in a float
-- literal, it's considered to need no padding zeros.  If the radix point is
-- outside the specified digits, we can either materialize extra zeros to cover
-- the gap between the specified digits and the radix point, or use scientific
-- notation to move the radix point into the specified digits.  A single
-- placeholder zero to the left of the radix point is not considered to be a
-- padding zero.
--
-- @
--     FloatLiteral False "1234" (-4) = _.____1 234
--                                    = 0.00001 234 -- 4 padding 0s
--                                    =       1.234e-5
-- @
--
-- @
--     FloatLiteral False "1234" 8    = 1 234____._
--                                    = 1 2340000   -- 4 padding 0s
--                                    = 1.234e7
-- @
--
-- Trailing that are part of the specified digits are not considered to be
-- padding (if not trimmed by 'setTrimTrailingFloatZeros'):
--
-- @
--     FloatLiteral False "100" 4     = 1 00_._
--                                    = 1 000 -- 1 padding 0
--                                    = 1.000e3
-- @
--
-- This threshold determines how many padding zeros to tolerate before
-- switching over to scientific notation.  Choosing a very high threshold
-- naturally means scientific notation will ~never be used.  Choosing a
-- negative threshold naturally means scientific notation will always be used.
--
-- Deciding based on the number of padding zeros rather than the absolute
-- magnitude of the number means we won't needlessly format @1234567@ as
-- @1.234567e6@ when doing so doesn't actually make the representation more
-- compact.
--
-- @since 0.2.1
setScientificNotationThreshold :: Int -> Config -> Config
setScientificNotationThreshold :: Int -> Config -> Config
setScientificNotationThreshold Int
n Config
c = Config
c { _scientificNotationThreshold :: Int
_scientificNotationThreshold = Int
n }

-- | Set the separator spacing for NumericUnderscores, or disable underscores.
--
-- The list of group sizes is used working leftwards from the radix point.  If
-- the list runs out, no further separators will be inserted.
--
-- @
--     [4, 3, 2, 2] : 123456000000 => 1_23_45_600_0000
--     repeat 3     : 123456000000 => 123_456_000_000
--     [1]          : 123456000000 => 12345600000_0
-- @
--
-- This allows both the conventional US separator placement of every three
-- digits by providing @cycle 3@, as well as more complex spacings such as
-- @3 : repeat 2@ reportedly used in India.
--
-- Backends should not cache these lists, and should attempt to use them in a
-- single-use, streaming manner, so that large portions of infinite lists are
-- not held in memory.  Clients should assume returning infinite lists is fine.
--
-- @since 0.2.1
setSeparatorGroupSizes :: (Base -> [Int]) -> Config -> Config
setSeparatorGroupSizes :: (Base -> [Int]) -> Config -> Config
setSeparatorGroupSizes Base -> [Int]
f Config
c = Config
c { _separatorGroupSizes :: Base -> [Int]
_separatorGroupSizes = Base -> [Int]
f }

-- | A sensible, conservative default configuration to build on.
--
-- * Uses 'escapeNonASCII' to escape everything but printable ASCII characters.
-- * Preserves any trailing zeros in float literals.
-- * Uses scientific notation when any padding zeros would be needed.
-- * Does not use numeric underscores.
defaultConfig :: Config
defaultConfig :: Config
defaultConfig = (Char -> Bool) -> Int -> Bool -> (Base -> [Int]) -> Config
Config Char -> Bool
escapeNonASCII Int
0 Bool
False (forall a b. a -> b -> a
const [])

-- | A default "pretty" config with more opinionated choices.
--
-- This using numeric underscores, slightly less scientific notation, and less
-- escaping compared to 'defaultConfig'.
--
-- @since 0.2.1
prettyConfig :: Config
prettyConfig :: Config
prettyConfig =
  Config
defaultConfig
    forall a b. a -> (a -> b) -> b
& (Char -> Bool) -> Config -> Config
setShouldEscapeChar Char -> Bool
escapeSpecialOnly
    forall a b. a -> (a -> b) -> b
& Int -> Config -> Config
setScientificNotationThreshold Int
2
    forall a b. a -> (a -> b) -> b
& (Base -> [Int]) -> Config -> Config
setSeparatorGroupSizes
        (\case
          Base
Decimal -> forall a. a -> [a]
repeat Int
3 -- Conventional US spacing: powers of 1,000.
          Base
Binary -> forall a. a -> [a]
repeat Int
8  -- 8-bit groups.
          Base
Octal ->  []        -- /shrug/ doesn't divide bytes evenly.
          Base
Hex -> forall a. a -> [a]
repeat Int
8)    -- 32-bit groups.

-- | 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 =
  forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Bracket (forall ann. Char -> Doc ann
char Char
'(') forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
d forall a. Semigroup a => a -> a -> a
<> forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Bracket (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 -> forall a. a -> a
id

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

-- Convert a Char to a document; 'pretty' specialized to 'Char'.
char :: Char -> Doc ann
char :: forall ann. Char -> Doc ann
char = 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 = forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Structural (forall ann. Char -> Doc ann
char Char
'`')
  nmDoc :: Doc SyntaxClass
nmDoc = forall ann. ann -> Doc ann -> Doc ann
P.annotate (IdentKind -> SyntaxClass
Identifier IdentKind
k) (forall ann. Text -> Doc ann
text Text
nm)
  wrappedNm :: Doc SyntaxClass
wrappedNm = Doc SyntaxClass
backquote forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
nmDoc 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 = forall ann. ann -> Doc ann -> Doc ann
P.annotate (IdentKind -> SyntaxClass
Identifier IdentKind
k) (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 forall a b. (a -> b) -> a -> b
$ Infixity -> Assoc -> Rational -> Bool
fixityCompatible Infixity
fx Assoc
lr Rational
p) forall a b. (a -> b) -> a -> b
$ forall ann. Int -> Doc ann -> Doc ann
P.nest Int
2 forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
P.sep
    [ DocAssocPrec SyntaxClass
x (Assoc -> Assoc -> Assoc
matchCtx Assoc
AssocL Assoc
assoc) Rational
opPrec 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 forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
closer
  (Doc SyntaxClass
doc:[Doc SyntaxClass]
docs) ->
    forall ann. Doc ann -> Doc ann
P.group forall a b. (a -> b) -> a -> b
$
      Doc SyntaxClass
opener forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann -> Doc ann -> Doc ann
P.flatAlt Doc SyntaxClass
" " Doc SyntaxClass
"" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann -> Doc ann
P.align Doc SyntaxClass
doc forall a. Semigroup a => a -> a -> a
<>
      forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
        (\Doc SyntaxClass
x -> forall ann. Doc ann -> Doc ann
P.group (forall ann. Doc ann
P.line' forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
x))
        (forall a b. (a -> b) -> [a] -> [b]
map (\Doc SyntaxClass
x -> Doc SyntaxClass
separator forall ann. Doc ann -> Doc ann -> Doc ann
P.<+> forall ann. Doc ann -> Doc ann
P.align Doc SyntaxClass
x) [Doc SyntaxClass]
docs) forall a. Semigroup a => a -> a -> a
<>
      forall ann. Doc ann
P.line' forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
closer
 where
  opener :: Doc SyntaxClass
opener = forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Bracket Doc SyntaxClass
o
  separator :: Doc SyntaxClass
separator = forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Separator Doc SyntaxClass
s
  closer :: Doc SyntaxClass
closer = forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Bracket Doc SyntaxClass
c

foldl01 :: (b -> a -> b) -> (a -> b) -> b -> [a] -> b
foldl01 :: forall b a. (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) -> 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 = (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) 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 (forall a. Eq a => a -> a -> Bool
== Char
'\n') Text
s
    in  Text
line 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 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] 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 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 =
  forall ann. ann -> Doc ann -> Doc ann
P.annotate (LitKind -> SyntaxClass
Literal LitKind
StrLit) forall a b. (a -> b) -> a -> b
$
  forall ann. Doc ann -> Doc ann
P.group forall a b. (a -> b) -> a -> b
$ -- Prefer putting the whole thing on this line whenever possible.
  forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
P.enclose Doc SyntaxClass
"\"" Doc SyntaxClass
"\"" forall a b. (a -> b) -> a -> b
$
  -- Then prefer breaking on newlines when the next line doesn't fit.
  forall b a. (b -> a -> b) -> (a -> b) -> b -> [a] -> b
foldl01
    (\Doc SyntaxClass
x Doc SyntaxClass
l ->
      Doc SyntaxClass
x forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann -> Doc ann
P.group (forall ann. Doc ann -> Doc ann -> Doc ann
P.flatAlt (Doc SyntaxClass
nl forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
backslashBreak forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
l) (Doc SyntaxClass
nl forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
l)))
    forall a. a -> a
id
    forall a. Monoid a => a
mempty
    ([(Doc SyntaxClass, Doc SyntaxClass)] -> Doc SyntaxClass
ppLine forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [[(Doc SyntaxClass, Doc SyntaxClass)]]
escapedLinesOfWords)
 where
  nl :: Doc SyntaxClass
nl = forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
EscapeSequence Doc SyntaxClass
"\\n"

  ppWord :: Text -> Doc SyntaxClass
  ppWord :: Text -> Doc SyntaxClass
ppWord Text
"" = 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 forall a. Monoid a => a
mempty
        escaped :: Doc SyntaxClass
escaped = forall a ann. Pretty a => a -> Doc ann
pretty ((Char -> Text) -> Text -> Text
T.concatMap (Config -> Char -> Text
escapeStrChar Config
cfg) Text
toEscape) forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
sep
    in  forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
EscapeSequence Doc SyntaxClass
escaped forall a. Semigroup a => a -> a -> a
<> forall ann. Text -> Doc ann
text Text
plain forall a. Semigroup a => a -> a -> a
<> Text -> Doc SyntaxClass
ppWord Text
rest'

  escapedLinesOfWords :: [[(Doc SyntaxClass, Doc SyntaxClass)]]
  escapedLinesOfWords :: [[(Doc SyntaxClass, Doc SyntaxClass)]]
escapedLinesOfWords =
    forall a b. (a -> b) -> [a] -> [b]
map
        (\ (Text
w, Text
ws) -> (Text -> Doc SyntaxClass
ppWord Text
w, Text -> Doc SyntaxClass
ppWhitespace Text
ws)) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
      Text -> [(Text, Text)]
wordsSep 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 =
    forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
EscapeSequence forall b c a. (b -> c) -> (a -> b) -> a -> c
.
    forall ann. Text -> Doc ann
text 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.
    forall ann. Doc ann -> Doc ann
P.group forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall a. Semigroup a => a -> a -> a
(<>) forall a b. (a -> b) -> a -> b
$ 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 forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann -> Doc ann
P.group (forall ann. Doc ann -> Doc ann -> Doc ann
P.flatAlt (Doc SyntaxClass
space forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
backslashBreak) Doc SyntaxClass
space forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
w)
        , Doc SyntaxClass
space'
        ))
      forall a. a -> a
id
      forall a. Monoid a => a
mempty
      [(Doc SyntaxClass, Doc SyntaxClass)]
ws

  backslashBreak :: Doc SyntaxClass
backslashBreak = forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
EscapeSequence forall a b. (a -> b) -> a -> b
$ Doc SyntaxClass
"\\" forall a. Semigroup a => a -> a -> a
<> forall ann. Doc ann
P.line' forall a. Semigroup a => a -> a -> a
<> Doc SyntaxClass
"\\"

ppIntLit :: Base -> [Int] -> Integer -> Doc SyntaxClass
ppIntLit :: Base -> [Int] -> Integer -> Doc SyntaxClass
ppIntLit Base
b [Int]
seps = forall ann. ann -> Doc ann -> Doc ann
P.annotate (LitKind -> SyntaxClass
Literal LitKind
IntLit) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall ann. Text -> Doc ann
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (Show a, Integral a) => Base -> [Int] -> a -> Text
formatIntLit Base
b [Int]
seps

paddingZeros :: FloatLiteral -> Int
paddingZeros :: FloatLiteral -> Int
paddingZeros (FloatLiteral Bool
_ Text
d Int
e)
  | Int
e forall a. Ord a => a -> a -> Bool
< Int
0 = forall a. Num a => a -> a
negate Int
e
  | Int
e forall a. Ord a => a -> a -> Bool
> Text -> Int
T.length Text
d = Int
e forall a. Num a => a -> a -> a
- Text -> Int
T.length Text
d
  | Bool
otherwise = Int
0

ppFloatLit :: Config -> FloatLiteral -> Doc SyntaxClass
ppFloatLit :: Config -> FloatLiteral -> Doc SyntaxClass
ppFloatLit Config
cfg FloatLiteral
lit =
  forall ann. ann -> Doc ann -> Doc ann
P.annotate (LitKind -> SyntaxClass
Literal LitKind
RatLit) forall a b. (a -> b) -> a -> b
$ forall ann. Text -> Doc ann
text forall a b. (a -> b) -> a -> b
$
  Bool -> [Int] -> FloatLiteral -> Text
formatFloatLit
    (FloatLiteral -> Int
paddingZeros FloatLiteral
lit' forall a. Ord a => a -> a -> Bool
> Config -> Int
_scientificNotationThreshold Config
cfg)
    (Config -> Base -> [Int]
_separatorGroupSizes Config
cfg Base
Decimal) FloatLiteral
lit'
 where
  lit' :: FloatLiteral
lit' =
    (if Config -> Bool
_trimTrailingFloatZeros Config
cfg then FloatLiteral -> FloatLiteral
trimFloatLit else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
    FloatLiteral -> FloatLiteral
normalizeFloatLit FloatLiteral
lit

-- | 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
  LitIntBaseF Base
base Integer
x -> \Assoc
_ Rational
_ -> Base -> [Int] -> Integer -> Doc SyntaxClass
ppIntLit Base
base (Config -> Base -> [Int]
_separatorGroupSizes Config
cfg Base
base) Integer
x
  LitFloatF FloatLiteral
x -> \Assoc
_ Rational
_ -> Config -> FloatLiteral -> Doc SyntaxClass
ppFloatLit Config
cfg FloatLiteral
x

  SpecialFloatF SpecialFloatVal
x -> \Assoc
_ Rational
_ ->
    forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Structural forall a b. (a -> b) -> a -> b
$ forall ann. Text -> Doc ann
text forall a b. (a -> b) -> a -> b
$ -- Different color from numeric float lits.
    SpecialFloatVal -> Text
formatSpecialFloat SpecialFloatVal
x

  LitStrF Text
x -> \Assoc
_ Rational
_ -> Config -> Text -> Doc SyntaxClass
ppStrLit Config
cfg Text
x

  LitCharF Char
x -> \Assoc
_ Rational
_ ->
    -- Likewise Char
    forall ann. ann -> Doc ann -> Doc ann
P.annotate (LitKind -> SyntaxClass
Literal LitKind
CharLit) forall a b. (a -> b) -> a -> b
$
    forall ann. Doc ann -> Doc ann -> Doc ann -> Doc ann
P.enclose Doc SyntaxClass
"'" Doc SyntaxClass
"'" forall a b. (a -> b) -> a -> b
$
    (if Config -> Char -> Bool
litCharIsEscaped Config
cfg Char
x then forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
EscapeSequence else forall a. a -> a
id) forall a b. (a -> b) -> a -> b
$
    forall ann. Text -> Doc ann
text forall a b. (a -> b) -> a -> b
$ Config -> Char -> Text
escapeLitChar Config
cfg Char
x

  OpaqueF Text
txt -> \Assoc
_ Rational
_ -> 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 forall a b. (a -> b) -> a -> b
$ Infixity -> Assoc -> Rational -> Bool
fixityCompatible (Assoc -> Rational -> Infixity
Infixity Assoc
AssocL Rational
10) Assoc
lr Rational
p) forall a b. (a -> b) -> a -> b
$
      forall ann. Int -> Doc ann -> Doc ann
P.nest Int
2 forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
P.sep
        [ DocAssocPrec SyntaxClass
fn Assoc
AssocL Rational
10
        , forall ann. [Doc ann] -> Doc ann
P.sep forall a b. (a -> b) -> a -> b
$ [DocAssocPrec SyntaxClass]
xs 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
")" forall a b. (a -> b) -> a -> b
$ [DocAssocPrec SyntaxClass]
xs 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
"]" forall a b. (a -> b) -> a -> b
$ [DocAssocPrec SyntaxClass]
xs 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 forall a. Ord a => a -> a -> Bool
>= Rational
10) forall a b. (a -> b) -> a -> b
$
      forall ann. Int -> Doc ann -> Doc ann
P.nest Int
2 forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
P.sep
        [ forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Structural Doc SyntaxClass
"\\" forall a. Semigroup a => a -> a -> a
<> 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
"}"
            [ forall ann. Int -> Doc ann -> Doc ann
P.nest Int
2 forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
P.sep forall a b. (a -> b) -> a -> b
$
                [ DocAssocPrec SyntaxClass
pat Assoc
AssocNope Rational
0 forall ann. Doc ann -> Doc ann -> Doc ann
P.<+> 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)]
_  -> forall ann. Int -> Doc ann -> Doc ann
P.nest Int
2 forall a b. (a -> b) -> a -> b
$ 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
"}"
          [ forall ann. Int -> Doc ann -> Doc ann
P.nest Int
2 forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
P.sep
              [ Ident -> Doc SyntaxClass
ppPrefix Ident
sel forall ann. Doc ann -> Doc ann -> Doc ann
P.<+> 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
_ ->
    forall ann. Int -> Doc ann -> Doc ann
P.nest Int
2 forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
P.sep
      [ DocAssocPrec SyntaxClass
val Assoc
AssocNope Rational
10
      , forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Structural 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 forall a. Ord a => a -> a -> Bool
>= Rational
0) forall a b. (a -> b) -> a -> b
$
    forall ann. Int -> Doc ann -> Doc ann
P.nest Int
2 forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
P.sep
      [ DocAssocPrec SyntaxClass
val Assoc
AssocNope Rational
0
      , forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Structural 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
_ ->
    forall ann. Int -> Doc ann -> Doc ann
P.nest Int
2 forall a b. (a -> b) -> a -> b
$ forall ann. [Doc ann] -> Doc ann
P.sep
      [ forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Structural Doc SyntaxClass
"[" forall a. Semigroup a => a -> a -> a
<>
          forall ann. ann -> Doc ann -> Doc ann
P.annotate (IdentKind -> SyntaxClass
Identifier IdentKind
VarIdent) (forall ann. Text -> Doc ann
text Text
nm) forall a. Semigroup a => a -> a -> a
<>
          forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Structural Doc SyntaxClass
"|"
      , DocAssocPrec SyntaxClass
content Assoc
AssocNope (-Rational
1)
      , forall ann. ann -> Doc ann -> Doc ann
P.annotate SyntaxClass
Structural Doc SyntaxClass
"|]"
      ]

  UnlinesF [DocAssocPrec SyntaxClass]
ls -> \Assoc
_ Rational
_ -> forall ann. [Doc ann] -> Doc ann
P.vcat ([DocAssocPrec SyntaxClass]
ls 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
_ -> 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 = forall (f :: * -> *) a. Functor f => (f a -> a) -> Fix f -> a
cata (Config
-> PortrayalF (DocAssocPrec SyntaxClass)
-> DocAssocPrec SyntaxClass
toDocAssocPrecF Config
cfg) 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 (forall a b. a -> b -> a
const 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
prettyConfig SyntaxClass -> Maybe AnsiStyle
defaultStyling

-- | A lazy 'TL.Text' variant of 'prettyShowPortrayal'.
--
-- @since 0.2.1
prettyShowPortrayalLazy :: Portrayal -> TL.Text
prettyShowPortrayalLazy :: Portrayal -> Text
prettyShowPortrayalLazy =
  Config -> (SyntaxClass -> Maybe AnsiStyle) -> Portrayal -> Text
styleShowPortrayalLazy Config
prettyConfig 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 = Text -> Text
TL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> (SyntaxClass -> Maybe AnsiStyle) -> Portrayal -> Text
styleShowPortrayalLazy Config
cfg SyntaxClass -> Maybe AnsiStyle
style

-- | A lazy 'TL.Text' variant of 'styleShowPortrayal'.
--
-- @since 0.2.1
styleShowPortrayalLazy
  :: Config -> (SyntaxClass -> Maybe A.AnsiStyle) -> Portrayal -> TL.Text
styleShowPortrayalLazy :: Config -> (SyntaxClass -> Maybe AnsiStyle) -> Portrayal -> Text
styleShowPortrayalLazy Config
cfg SyntaxClass -> Maybe AnsiStyle
style Portrayal
p =
  SimpleDocStream AnsiStyle -> Text
A.renderLazy forall a b. (a -> b) -> a -> b
$ forall ann ann'.
(ann -> Maybe ann') -> SimpleDocStream ann -> SimpleDocStream ann'
P.alterAnnotationsS SyntaxClass -> Maybe AnsiStyle
style forall a b. (a -> b) -> a -> b
$
  forall ann. LayoutOptions -> Doc ann -> SimpleDocStream ann
P.layoutPretty LayoutOptions
P.defaultLayoutOptions 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 { forall a. WrappedPortray a -> a
unWrappedPortray :: a }
  deriving newtype (WrappedPortray a -> WrappedPortray a -> Bool
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, 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
Ord, Int -> WrappedPortray a -> ShowS
[WrappedPortray a] -> ShowS
WrappedPortray a -> [Char]
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 :: forall ann. WrappedPortray a -> Doc ann
pretty WrappedPortray a
x =
    forall ann xxx. Doc ann -> Doc xxx
P.unAnnotate forall a b. (a -> b) -> a -> b
$ Config -> Portrayal -> Doc SyntaxClass
portrayalToDoc Config
defaultConfig (forall a. Portray a => a -> Portrayal
portray forall a b. (a -> b) -> a -> b
$ forall a. WrappedPortray a -> a
unWrappedPortray WrappedPortray a
x)