{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}

-----------------------------------------------------------------------------
-- |
-- Module      :  GHC.Utils.Ppr
-- Copyright   :  (c) The University of Glasgow 2001
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  David Terei <code@davidterei.com>
-- Stability   :  stable
-- Portability :  portable
--
-- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators
--
-- Based on /The Design of a Pretty-printing Library/
-- in Advanced Functional Programming,
-- Johan Jeuring and Erik Meijer (eds), LNCS 925
-- <http://www.cse.chalmers.se/~rjmh/Papers/pretty.ps>
--
-----------------------------------------------------------------------------

{-
Note [Differences between libraries/pretty and compiler/GHC/Utils/Ppr.hs]

For historical reasons, there are two different copies of `Pretty` in the GHC
source tree:
 * `libraries/pretty` is a submodule containing
   https://github.com/haskell/pretty. This is the `pretty` library as released
   on hackage. It is used by several other libraries in the GHC source tree
   (e.g. template-haskell and Cabal).
 * `compiler/GHC/Utils/Ppr.hs` (this module). It is used by GHC only.

There is an ongoing effort in https://github.com/haskell/pretty/issues/1 and
https://gitlab.haskell.org/ghc/ghc/issues/10735 to try to get rid of GHC's copy
of Pretty.

Currently, GHC's copy of Pretty resembles pretty-1.1.2.0, with the following
major differences:
 * GHC's copy uses `Faststring` for performance reasons.
 * GHC's copy has received a backported bugfix for #12227, which was
   released as pretty-1.1.3.4 ("Remove harmful $! forcing in beside",
   https://github.com/haskell/pretty/pull/35).

Other differences are minor. Both copies define some extra functions and
instances not defined in the other copy. To see all differences, do this in a
ghc git tree:

    $ cd libraries/pretty
    $ git checkout v1.1.2.0
    $ cd -
    $ vimdiff compiler/GHC/Utils/Ppr.hs \
              libraries/pretty/src/Text/PrettyPrint/HughesPJ.hs

For parity with `pretty-1.1.2.1`, the following two `pretty` commits would
have to be backported:
  * "Resolve foldr-strictness stack overflow bug"
    (307b8173f41cd776eae8f547267df6d72bff2d68)
  * "Special-case reduce for horiz/vert"
    (c57c7a9dfc49617ba8d6e4fcdb019a3f29f1044c)
This has not been done sofar, because these commits seem to cause more
allocation in the compiler (see thomie's comments in
https://github.com/haskell/pretty/pull/9).
-}

module GHC.Utils.Ppr (

        -- * The document type
        Doc, TextDetails(..),

        -- * Constructing documents

        -- ** Converting values into documents
        char, text, ftext, ptext, ztext, sizedText, zeroWidthText,
        int, integer, float, double, rational, hex,

        -- ** Simple derived documents
        semi, comma, colon, space, equals,
        lparen, rparen, lbrack, rbrack, lbrace, rbrace,

        -- ** Wrapping documents in delimiters
        parens, brackets, braces, quotes, quote, doubleQuotes,
        maybeParens,

        -- ** Combining documents
        empty,
        (<>), (<+>), hcat, hsep,
        ($$), ($+$), vcat,
        sep, cat,
        fsep, fcat,
        nest,
        hang, hangNotEmpty, punctuate,

        -- * Predicates on documents
        isEmpty,

        -- * Rendering documents

        -- ** Rendering with a particular style
        Style(..),
        style,
        renderStyle,
        Mode(..),

        -- ** General rendering
        fullRender, txtPrinter,

        -- ** GHC-specific rendering
        printDoc, printDoc_,
        bufLeftRender -- performance hack

  ) where

import GHC.Prelude hiding (error)

import GHC.Utils.BufHandle
import GHC.Data.FastString
import GHC.Utils.Panic.Plain
import System.IO
import Numeric (showHex)

--for a RULES
import GHC.Base ( unpackCString#, unpackNBytes#, Int(..) )
import GHC.Ptr  ( Ptr(..) )

-- ---------------------------------------------------------------------------
-- The Doc calculus

{-
Laws for $$
~~~~~~~~~~~
<a1>    (x $$ y) $$ z   = x $$ (y $$ z)
<a2>    empty $$ x      = x
<a3>    x $$ empty      = x

        ...ditto $+$...

Laws for <>
~~~~~~~~~~~
<b1>    (x <> y) <> z   = x <> (y <> z)
<b2>    empty <> x      = empty
<b3>    x <> empty      = x

        ...ditto <+>...

Laws for text
~~~~~~~~~~~~~
<t1>    text s <> text t        = text (s++t)
<t2>    text "" <> x            = x, if x non-empty

** because of law n6, t2 only holds if x doesn't
** start with `nest'.


Laws for nest
~~~~~~~~~~~~~
<n1>    nest 0 x                = x
<n2>    nest k (nest k' x)      = nest (k+k') x
<n3>    nest k (x <> y)         = nest k x <> nest k y
<n4>    nest k (x $$ y)         = nest k x $$ nest k y
<n5>    nest k empty            = empty
<n6>    x <> nest k y           = x <> y, if x non-empty

** Note the side condition on <n6>!  It is this that
** makes it OK for empty to be a left unit for <>.

Miscellaneous
~~~~~~~~~~~~~
<m1>    (text s <> x) $$ y = text s <> ((text "" <> x) $$
                                         nest (-length s) y)

<m2>    (x $$ y) <> z = x $$ (y <> z)
        if y non-empty


Laws for list versions
~~~~~~~~~~~~~~~~~~~~~~
<l1>    sep (ps++[empty]++qs)   = sep (ps ++ qs)
        ...ditto hsep, hcat, vcat, fill...

<l2>    nest k (sep ps) = sep (map (nest k) ps)
        ...ditto hsep, hcat, vcat, fill...

Laws for oneLiner
~~~~~~~~~~~~~~~~~
<o1>    oneLiner (nest k p) = nest k (oneLiner p)
<o2>    oneLiner (x <> y)   = oneLiner x <> oneLiner y

You might think that the following version of <m1> would
be neater:

<3 NO>  (text s <> x) $$ y = text s <> ((empty <> x)) $$
                                         nest (-length s) y)

But it doesn't work, for if x=empty, we would have

        text s $$ y = text s <> (empty $$ nest (-length s) y)
                    = text s <> nest (-length s) y
-}

-- ---------------------------------------------------------------------------
-- Operator fixity

infixl 6 <>
infixl 6 <+>
infixl 5 $$, $+$


-- ---------------------------------------------------------------------------
-- The Doc data type

-- | The abstract type of documents.
-- A Doc represents a *set* of layouts. A Doc with
-- no occurrences of Union or NoDoc represents just one layout.
data Doc
  = Empty                                            -- empty
  | NilAbove Doc                                     -- text "" $$ x
  | TextBeside !TextDetails {-# UNPACK #-} !Int Doc  -- text s <> x
  | Nest {-# UNPACK #-} !Int Doc                     -- nest k x
  | Union Doc Doc                                    -- ul `union` ur
  | NoDoc                                            -- The empty set of documents
  | Beside Doc Bool Doc                              -- True <=> space between
  | Above Doc Bool Doc                               -- True <=> never overlap

{-
Here are the invariants:

1) The argument of NilAbove is never Empty. Therefore
   a NilAbove occupies at least two lines.

2) The argument of @TextBeside@ is never @Nest@.

3) The layouts of the two arguments of @Union@ both flatten to the same
   string.

4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@.

5) A @NoDoc@ may only appear on the first line of the left argument of an
   union. Therefore, the right argument of an union can never be equivalent
   to the empty set (@NoDoc@).

6) An empty document is always represented by @Empty@.  It can't be
   hidden inside a @Nest@, or a @Union@ of two @Empty@s.

7) The first line of every layout in the left argument of @Union@ is
   longer than the first line of any layout in the right argument.
   (1) ensures that the left argument has a first line.  In view of
   (3), this invariant means that the right argument must have at
   least two lines.

Notice the difference between
   * NoDoc (no documents)
   * Empty (one empty document; no height and no width)
   * text "" (a document containing the empty string;
              one line high, but has no width)
-}


-- | RDoc is a "reduced GDoc", guaranteed not to have a top-level Above or Beside.
type RDoc = Doc

-- | The TextDetails data type
--
-- A TextDetails represents a fragment of text that will be
-- output at some point.
data TextDetails = Chr  {-# UNPACK #-} !Char -- ^ A single Char fragment
                 | Str  String -- ^ A whole String fragment
                 | PStr FastString                      -- a hashed string
                 | ZStr FastZString                     -- a z-encoded string
                 | LStr {-# UNPACK #-} !PtrString
                   -- a '\0'-terminated array of bytes
                 | RStr {-# UNPACK #-} !Int {-# UNPACK #-} !Char
                   -- a repeated character (e.g., ' ')

instance Show Doc where
  showsPrec :: Int -> Doc -> ShowS
showsPrec Int
_ Doc
doc String
cont = forall a.
Mode -> Int -> Float -> (TextDetails -> a -> a) -> a -> Doc -> a
fullRender (Style -> Mode
mode Style
style) (Style -> Int
lineLength Style
style)
                                    (Style -> Float
ribbonsPerLine Style
style)
                                    TextDetails -> ShowS
txtPrinter String
cont Doc
doc


-- ---------------------------------------------------------------------------
-- Values and Predicates on GDocs and TextDetails

-- | A document of height and width 1, containing a literal character.
char :: Char -> Doc
char :: Char -> Doc
char Char
c = TextDetails -> Int -> Doc -> Doc
textBeside_ (Char -> TextDetails
Chr Char
c) Int
1 Doc
Empty

-- | A document of height 1 containing a literal string.
-- 'text' satisfies the following laws:
--
-- * @'text' s '<>' 'text' t = 'text' (s'++'t)@
--
-- * @'text' \"\" '<>' x = x@, if @x@ non-empty
--
-- The side condition on the last law is necessary because @'text' \"\"@
-- has height 1, while 'empty' has no height.
text :: String -> Doc
text :: String -> Doc
text String
s = TextDetails -> Int -> Doc -> Doc
textBeside_ (String -> TextDetails
Str String
s) (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
s) Doc
Empty
{-# NOINLINE [0] text #-}   -- Give the RULE a chance to fire
                            -- It must wait till after phase 1 when
                            -- the unpackCString first is manifested

-- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the
-- intermediate packing/unpacking of the string.
{-# RULES "text/str"
    forall a. text (unpackCString# a)  = ptext (mkPtrString# a)
  #-}
{-# RULES "text/unpackNBytes#"
    forall p n. text (unpackNBytes# p n) = ptext (PtrString (Ptr p) (I# n))
  #-}

ftext :: FastString -> Doc
ftext :: FastString -> Doc
ftext FastString
s = TextDetails -> Int -> Doc -> Doc
textBeside_ (FastString -> TextDetails
PStr FastString
s) (FastString -> Int
lengthFS FastString
s) Doc
Empty

ptext :: PtrString -> Doc
ptext :: PtrString -> Doc
ptext PtrString
s = TextDetails -> Int -> Doc -> Doc
textBeside_ (PtrString -> TextDetails
LStr PtrString
s) (PtrString -> Int
lengthPS PtrString
s) Doc
Empty

ztext :: FastZString -> Doc
ztext :: FastZString -> Doc
ztext FastZString
s = TextDetails -> Int -> Doc -> Doc
textBeside_ (FastZString -> TextDetails
ZStr FastZString
s) (FastZString -> Int
lengthFZS FastZString
s) Doc
Empty

-- | Some text with any width. (@text s = sizedText (length s) s@)
sizedText :: Int -> String -> Doc
sizedText :: Int -> String -> Doc
sizedText Int
l String
s = TextDetails -> Int -> Doc -> Doc
textBeside_ (String -> TextDetails
Str String
s) Int
l Doc
Empty

-- | Some text, but without any width. Use for non-printing text
-- such as a HTML or Latex tags
zeroWidthText :: String -> Doc
zeroWidthText :: String -> Doc
zeroWidthText = Int -> String -> Doc
sizedText Int
0

-- | The empty document, with no height and no width.
-- 'empty' is the identity for '<>', '<+>', '$$' and '$+$', and anywhere
-- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc.
empty :: Doc
empty :: Doc
empty = Doc
Empty

-- | Returns 'True' if the document is empty
isEmpty :: Doc -> Bool
isEmpty :: Doc -> Bool
isEmpty Doc
Empty = Bool
True
isEmpty Doc
_     = Bool
False

{-
Q: What is the reason for negative indentation (i.e. argument to indent
   is < 0) ?

A:
This indicates an error in the library client's code.
If we compose a <> b, and the first line of b is more indented than some
other lines of b, the law <n6> (<> eats nests) may cause the pretty
printer to produce an invalid layout:

doc       |0123345
------------------
d1        |a...|
d2        |...b|
          |c...|

d1<>d2    |ab..|
         c|....|

Consider a <> b, let `s' be the length of the last line of `a', `k' the
indentation of the first line of b, and `k0' the indentation of the
left-most line b_i of b.

The produced layout will have negative indentation if `k - k0 > s', as
the first line of b will be put on the (s+1)th column, effectively
translating b horizontally by (k-s). Now if the i^th line of b has an
indentation k0 < (k-s), it is translated out-of-page, causing
`negative indentation'.
-}


semi   :: Doc -- ^ A ';' character
comma  :: Doc -- ^ A ',' character
colon  :: Doc -- ^ A ':' character
space  :: Doc -- ^ A space character
equals :: Doc -- ^ A '=' character
lparen :: Doc -- ^ A '(' character
rparen :: Doc -- ^ A ')' character
lbrack :: Doc -- ^ A '[' character
rbrack :: Doc -- ^ A ']' character
lbrace :: Doc -- ^ A '{' character
rbrace :: Doc -- ^ A '}' character
semi :: Doc
semi   = Char -> Doc
char Char
';'
comma :: Doc
comma  = Char -> Doc
char Char
','
colon :: Doc
colon  = Char -> Doc
char Char
':'
space :: Doc
space  = Char -> Doc
char Char
' '
equals :: Doc
equals = Char -> Doc
char Char
'='
lparen :: Doc
lparen = Char -> Doc
char Char
'('
rparen :: Doc
rparen = Char -> Doc
char Char
')'
lbrack :: Doc
lbrack = Char -> Doc
char Char
'['
rbrack :: Doc
rbrack = Char -> Doc
char Char
']'
lbrace :: Doc
lbrace = Char -> Doc
char Char
'{'
rbrace :: Doc
rbrace = Char -> Doc
char Char
'}'

spaceText, nlText :: TextDetails
spaceText :: TextDetails
spaceText = Char -> TextDetails
Chr Char
' '
nlText :: TextDetails
nlText    = Char -> TextDetails
Chr Char
'\n'

int      :: Int      -> Doc -- ^ @int n = text (show n)@
integer  :: Integer  -> Doc -- ^ @integer n = text (show n)@
float    :: Float    -> Doc -- ^ @float n = text (show n)@
double   :: Double   -> Doc -- ^ @double n = text (show n)@
rational :: Rational -> Doc -- ^ @rational n = text (show n)@
hex      :: Integer  -> Doc -- ^ See Note [Print Hexadecimal Literals]
int :: Int -> Doc
int      Int
n = String -> Doc
text (forall a. Show a => a -> String
show Int
n)
integer :: Integer -> Doc
integer  Integer
n = String -> Doc
text (forall a. Show a => a -> String
show Integer
n)
float :: Float -> Doc
float    Float
n = String -> Doc
text (forall a. Show a => a -> String
show Float
n)
double :: Double -> Doc
double   Double
n = String -> Doc
text (forall a. Show a => a -> String
show Double
n)
rational :: Rational -> Doc
rational Rational
n = String -> Doc
text (forall a. Show a => a -> String
show Rational
n)
hex :: Integer -> Doc
hex      Integer
n = String -> Doc
text (Char
'0' forall a. a -> [a] -> [a]
: Char
'x' forall a. a -> [a] -> [a]
: String
padded)
    where
    str :: String
str = forall a. (Integral a, Show a) => a -> ShowS
showHex Integer
n String
""
    strLen :: Int
strLen = forall a. Ord a => a -> a -> a
max Int
1 (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
str)
    len :: Int
len = Int
2 forall a b. (Num a, Integral b) => a -> b -> a
^ (forall a b. (RealFrac a, Integral b) => a -> b
ceiling (forall a. Floating a => a -> a -> a
logBase Double
2 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
strLen :: Double)) :: Int)
    padded :: String
padded = forall a. Int -> a -> [a]
replicate (Int
len forall a. Num a => a -> a -> a
- Int
strLen) Char
'0' forall a. [a] -> [a] -> [a]
++ String
str

parens       :: Doc -> Doc -- ^ Wrap document in @(...)@
brackets     :: Doc -> Doc -- ^ Wrap document in @[...]@
braces       :: Doc -> Doc -- ^ Wrap document in @{...}@
quotes       :: Doc -> Doc -- ^ Wrap document in @\'...\'@
quote        :: Doc -> Doc
doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@
quotes :: Doc -> Doc
quotes Doc
p       = Char -> Doc
char Char
'`' Doc -> Doc -> Doc
<> Doc
p Doc -> Doc -> Doc
<> Char -> Doc
char Char
'\''
quote :: Doc -> Doc
quote Doc
p        = Char -> Doc
char Char
'\'' Doc -> Doc -> Doc
<> Doc
p
doubleQuotes :: Doc -> Doc
doubleQuotes Doc
p = Char -> Doc
char Char
'"' Doc -> Doc -> Doc
<> Doc
p Doc -> Doc -> Doc
<> Char -> Doc
char Char
'"'
parens :: Doc -> Doc
parens Doc
p       = Char -> Doc
char Char
'(' Doc -> Doc -> Doc
<> Doc
p Doc -> Doc -> Doc
<> Char -> Doc
char Char
')'
brackets :: Doc -> Doc
brackets Doc
p     = Char -> Doc
char Char
'[' Doc -> Doc -> Doc
<> Doc
p Doc -> Doc -> Doc
<> Char -> Doc
char Char
']'
braces :: Doc -> Doc
braces Doc
p       = Char -> Doc
char Char
'{' Doc -> Doc -> Doc
<> Doc
p Doc -> Doc -> Doc
<> Char -> Doc
char Char
'}'

{-
Note [Print Hexadecimal Literals]

Relevant discussions:
 * Phabricator: https://phabricator.haskell.org/D4465
 * GHC Trac: https://gitlab.haskell.org/ghc/ghc/issues/14872

There is a flag `-dword-hex-literals` that causes literals of
type `Word#` or `Word64#` to be displayed in hexadecimal instead
of decimal when dumping GHC core. It also affects the presentation
of these in GHC's error messages. Additionally, the hexadecimal
encoding of these numbers is zero-padded so that its length is
a power of two. As an example of what this does,
consider the following haskell file `Literals.hs`:

    module Literals where

    alpha :: Int
    alpha = 100 + 200

    beta :: Word -> Word
    beta x = x + div maxBound 255 + div 0xFFFFFFFF 255 + 0x0202

We get the following dumped core when we compile on a 64-bit
machine with ghc -O2 -fforce-recomp -ddump-simpl -dsuppress-all
-dhex-word-literals literals.hs:

    ==================== Tidy Core ====================

    ... omitted for brevity ...

    -- RHS size: {terms: 2, types: 0, coercions: 0, joins: 0/0}
    alpha
    alpha = I# 300#

    -- RHS size: {terms: 12, types: 3, coercions: 0, joins: 0/0}
    beta
    beta
      = \ x_aYE ->
          case x_aYE of { W# x#_a1v0 ->
          W#
            (plusWord#
               (plusWord# (plusWord# x#_a1v0 0x0101010101010101##) 0x01010101##)
               0x0202##)
          }

Notice that the word literals are in hexadecimals and that they have
been padded with zeroes so that their lengths are 16, 8, and 4, respectively.

-}

-- | Apply 'parens' to 'Doc' if boolean is true.
maybeParens :: Bool -> Doc -> Doc
maybeParens :: Bool -> Doc -> Doc
maybeParens Bool
False = forall a. a -> a
id
maybeParens Bool
True = Doc -> Doc
parens

-- ---------------------------------------------------------------------------
-- Structural operations on GDocs

-- | Perform some simplification of a built up @GDoc@.
reduceDoc :: Doc -> RDoc
reduceDoc :: Doc -> Doc
reduceDoc (Beside Doc
p Bool
g Doc
q) = Doc
p seq :: forall a b. a -> b -> b
`seq` Bool
g seq :: forall a b. a -> b -> b
`seq` (Doc -> Bool -> Doc -> Doc
beside Doc
p Bool
g forall a b. (a -> b) -> a -> b
$! Doc -> Doc
reduceDoc Doc
q)
reduceDoc (Above  Doc
p Bool
g Doc
q) = Doc
p seq :: forall a b. a -> b -> b
`seq` Bool
g seq :: forall a b. a -> b -> b
`seq` (Doc -> Bool -> Doc -> Doc
above  Doc
p Bool
g forall a b. (a -> b) -> a -> b
$! Doc -> Doc
reduceDoc Doc
q)
reduceDoc Doc
p              = Doc
p

-- | List version of '<>'.
hcat :: [Doc] -> Doc
hcat :: [Doc] -> Doc
hcat = Doc -> Doc
reduceAB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Bool -> Doc -> Doc -> Doc
beside_' Bool
False) Doc
empty

-- | List version of '<+>'.
hsep :: [Doc] -> Doc
hsep :: [Doc] -> Doc
hsep = Doc -> Doc
reduceAB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Bool -> Doc -> Doc -> Doc
beside_' Bool
True)  Doc
empty

-- | List version of '$$'.
vcat :: [Doc] -> Doc
vcat :: [Doc] -> Doc
vcat = Doc -> Doc
reduceAB forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Bool -> Doc -> Doc -> Doc
above_' Bool
False) Doc
empty

-- | Nest (or indent) a document by a given number of positions
-- (which may also be negative).  'nest' satisfies the laws:
--
-- * @'nest' 0 x = x@
--
-- * @'nest' k ('nest' k' x) = 'nest' (k+k') x@
--
-- * @'nest' k (x '<>' y) = 'nest' k z '<>' 'nest' k y@
--
-- * @'nest' k (x '$$' y) = 'nest' k x '$$' 'nest' k y@
--
-- * @'nest' k 'empty' = 'empty'@
--
-- * @x '<>' 'nest' k y = x '<>' y@, if @x@ non-empty
--
-- The side condition on the last law is needed because
-- 'empty' is a left identity for '<>'.
nest :: Int -> Doc -> Doc
nest :: Int -> Doc -> Doc
nest Int
k Doc
p = Int -> Doc -> Doc
mkNest Int
k (Doc -> Doc
reduceDoc Doc
p)

-- | @hang d1 n d2 = sep [d1, nest n d2]@
hang :: Doc -> Int -> Doc -> Doc
hang :: Doc -> Int -> Doc -> Doc
hang Doc
d1 Int
n Doc
d2 = [Doc] -> Doc
sep [Doc
d1, Int -> Doc -> Doc
nest Int
n Doc
d2]

-- | Apply 'hang' to the arguments if the first 'Doc' is not empty.
hangNotEmpty :: Doc -> Int -> Doc -> Doc
hangNotEmpty :: Doc -> Int -> Doc -> Doc
hangNotEmpty Doc
d1 Int
n Doc
d2 = if Doc -> Bool
isEmpty Doc
d1
                       then Doc
d2
                       else Doc -> Int -> Doc -> Doc
hang Doc
d1 Int
n Doc
d2

-- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@
punctuate :: Doc -> [Doc] -> [Doc]
punctuate :: Doc -> [Doc] -> [Doc]
punctuate Doc
_ []     = []
punctuate Doc
p (Doc
x:[Doc]
xs) = Doc -> [Doc] -> [Doc]
go Doc
x [Doc]
xs
                   where go :: Doc -> [Doc] -> [Doc]
go Doc
y []     = [Doc
y]
                         go Doc
y (Doc
z:[Doc]
zs) = (Doc
y Doc -> Doc -> Doc
<> Doc
p) forall a. a -> [a] -> [a]
: Doc -> [Doc] -> [Doc]
go Doc
z [Doc]
zs

-- mkNest checks for Nest's invariant that it doesn't have an Empty inside it
mkNest :: Int -> Doc -> Doc
mkNest :: Int -> Doc -> Doc
mkNest Int
k Doc
_ | Int
k seq :: forall a b. a -> b -> b
`seq` Bool
False = forall a. HasCallStack => a
undefined
mkNest Int
k (Nest Int
k1 Doc
p)       = Int -> Doc -> Doc
mkNest (Int
k forall a. Num a => a -> a -> a
+ Int
k1) Doc
p
mkNest Int
_ Doc
NoDoc             = Doc
NoDoc
mkNest Int
_ Doc
Empty             = Doc
Empty
mkNest Int
0 Doc
p                 = Doc
p
mkNest Int
k Doc
p                 = Int -> Doc -> Doc
nest_ Int
k Doc
p

-- mkUnion checks for an empty document
mkUnion :: Doc -> Doc -> Doc
mkUnion :: Doc -> Doc -> Doc
mkUnion Doc
Empty Doc
_ = Doc
Empty
mkUnion Doc
p Doc
q     = Doc
p Doc -> Doc -> Doc
`union_` Doc
q

beside_' :: Bool -> Doc -> Doc -> Doc
beside_' :: Bool -> Doc -> Doc -> Doc
beside_' Bool
_ Doc
p Doc
Empty = Doc
p
beside_' Bool
g Doc
p Doc
q     = Doc -> Bool -> Doc -> Doc
Beside Doc
p Bool
g Doc
q

above_' :: Bool -> Doc -> Doc -> Doc
above_' :: Bool -> Doc -> Doc -> Doc
above_' Bool
_ Doc
p Doc
Empty = Doc
p
above_' Bool
g Doc
p Doc
q     = Doc -> Bool -> Doc -> Doc
Above Doc
p Bool
g Doc
q

reduceAB :: Doc -> Doc
reduceAB :: Doc -> Doc
reduceAB (Above  Doc
Empty Bool
_ Doc
q) = Doc
q
reduceAB (Beside Doc
Empty Bool
_ Doc
q) = Doc
q
reduceAB Doc
doc                = Doc
doc

nilAbove_ :: RDoc -> RDoc
nilAbove_ :: Doc -> Doc
nilAbove_ = Doc -> Doc
NilAbove

-- Arg of a TextBeside is always an RDoc
textBeside_ :: TextDetails -> Int -> RDoc -> RDoc
textBeside_ :: TextDetails -> Int -> Doc -> Doc
textBeside_ = TextDetails -> Int -> Doc -> Doc
TextBeside

nest_ :: Int -> RDoc -> RDoc
nest_ :: Int -> Doc -> Doc
nest_ = Int -> Doc -> Doc
Nest

union_ :: RDoc -> RDoc -> RDoc
union_ :: Doc -> Doc -> Doc
union_ = Doc -> Doc -> Doc
Union


-- ---------------------------------------------------------------------------
-- Vertical composition @$$@

-- | Above, except that if the last line of the first argument stops
-- at least one position before the first line of the second begins,
-- these two lines are overlapped.  For example:
--
-- >    text "hi" $$ nest 5 (text "there")
--
-- lays out as
--
-- >    hi   there
--
-- rather than
--
-- >    hi
-- >         there
--
-- '$$' is associative, with identity 'empty', and also satisfies
--
-- * @(x '$$' y) '<>' z = x '$$' (y '<>' z)@, if @y@ non-empty.
--
($$) :: Doc -> Doc -> Doc
Doc
p $$ :: Doc -> Doc -> Doc
$$  Doc
q = Doc -> Bool -> Doc -> Doc
above_ Doc
p Bool
False Doc
q

-- | Above, with no overlapping.
-- '$+$' is associative, with identity 'empty'.
($+$) :: Doc -> Doc -> Doc
Doc
p $+$ :: Doc -> Doc -> Doc
$+$ Doc
q = Doc -> Bool -> Doc -> Doc
above_ Doc
p Bool
True Doc
q

above_ :: Doc -> Bool -> Doc -> Doc
above_ :: Doc -> Bool -> Doc -> Doc
above_ Doc
p Bool
_ Doc
Empty = Doc
p
above_ Doc
Empty Bool
_ Doc
q = Doc
q
above_ Doc
p Bool
g Doc
q     = Doc -> Bool -> Doc -> Doc
Above Doc
p Bool
g Doc
q

above :: Doc -> Bool -> RDoc -> RDoc
above :: Doc -> Bool -> Doc -> Doc
above (Above Doc
p Bool
g1 Doc
q1)  Bool
g2 Doc
q2 = Doc -> Bool -> Doc -> Doc
above Doc
p Bool
g1 (Doc -> Bool -> Doc -> Doc
above Doc
q1 Bool
g2 Doc
q2)
above p :: Doc
p@(Beside{})     Bool
g  Doc
q  = Doc -> Bool -> Int -> Doc -> Doc
aboveNest (Doc -> Doc
reduceDoc Doc
p) Bool
g Int
0 (Doc -> Doc
reduceDoc Doc
q)
above Doc
p Bool
g Doc
q                  = Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
p             Bool
g Int
0 (Doc -> Doc
reduceDoc Doc
q)

-- Specification: aboveNest p g k q = p $g$ (nest k q)
aboveNest :: RDoc -> Bool -> Int -> RDoc -> RDoc
aboveNest :: Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
_                   Bool
_ Int
k Doc
_ | Int
k seq :: forall a b. a -> b -> b
`seq` Bool
False = forall a. HasCallStack => a
undefined
aboveNest Doc
NoDoc               Bool
_ Int
_ Doc
_ = Doc
NoDoc
aboveNest (Doc
p1 `Union` Doc
p2)     Bool
g Int
k Doc
q = Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
p1 Bool
g Int
k Doc
q Doc -> Doc -> Doc
`union_`
                                      Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
p2 Bool
g Int
k Doc
q

aboveNest Doc
Empty               Bool
_ Int
k Doc
q = Int -> Doc -> Doc
mkNest Int
k Doc
q
aboveNest (Nest Int
k1 Doc
p)         Bool
g Int
k Doc
q = Int -> Doc -> Doc
nest_ Int
k1 (Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
p Bool
g (Int
k forall a. Num a => a -> a -> a
- Int
k1) Doc
q)
                                  -- p can't be Empty, so no need for mkNest

aboveNest (NilAbove Doc
p)        Bool
g Int
k Doc
q = Doc -> Doc
nilAbove_ (Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
p Bool
g Int
k Doc
q)
aboveNest (TextBeside TextDetails
s Int
sl Doc
p) Bool
g Int
k Doc
q = TextDetails -> Int -> Doc -> Doc
textBeside_ TextDetails
s Int
sl Doc
rest
                                    where
                                      !k1 :: Int
k1  = Int
k forall a. Num a => a -> a -> a
- Int
sl
                                      rest :: Doc
rest = case Doc
p of
                                                Doc
Empty -> Bool -> Int -> Doc -> Doc
nilAboveNest Bool
g Int
k1 Doc
q
                                                Doc
_     -> Doc -> Bool -> Int -> Doc -> Doc
aboveNest  Doc
p Bool
g Int
k1 Doc
q
aboveNest (Above {})          Bool
_ Int
_ Doc
_ = forall a. String -> a
error String
"aboveNest Above"
aboveNest (Beside {})         Bool
_ Int
_ Doc
_ = forall a. String -> a
error String
"aboveNest Beside"

-- Specification: text s <> nilaboveNest g k q
--              = text s <> (text "" $g$ nest k q)
nilAboveNest :: Bool -> Int -> RDoc -> RDoc
nilAboveNest :: Bool -> Int -> Doc -> Doc
nilAboveNest Bool
_ Int
k Doc
_           | Int
k seq :: forall a b. a -> b -> b
`seq` Bool
False = forall a. HasCallStack => a
undefined
nilAboveNest Bool
_ Int
_ Doc
Empty       = Doc
Empty
                               -- Here's why the "text s <>" is in the spec!
nilAboveNest Bool
g Int
k (Nest Int
k1 Doc
q) = Bool -> Int -> Doc -> Doc
nilAboveNest Bool
g (Int
k forall a. Num a => a -> a -> a
+ Int
k1) Doc
q
nilAboveNest Bool
g Int
k Doc
q           | Bool -> Bool
not Bool
g Bool -> Bool -> Bool
&& Int
k forall a. Ord a => a -> a -> Bool
> Int
0      -- No newline if no overlap
                             = TextDetails -> Int -> Doc -> Doc
textBeside_ (Int -> Char -> TextDetails
RStr Int
k Char
' ') Int
k Doc
q
                             | Bool
otherwise           -- Put them really above
                             = Doc -> Doc
nilAbove_ (Int -> Doc -> Doc
mkNest Int
k Doc
q)


-- ---------------------------------------------------------------------------
-- Horizontal composition @<>@

-- We intentionally avoid Data.Monoid.(<>) here due to interactions of
-- Data.Monoid.(<>) and (<+>).  See
-- http://www.haskell.org/pipermail/libraries/2011-November/017066.html

-- | Beside.
-- '<>' is associative, with identity 'empty'.
(<>) :: Doc -> Doc -> Doc
Doc
p <> :: Doc -> Doc -> Doc
<>  Doc
q = Doc -> Bool -> Doc -> Doc
beside_ Doc
p Bool
False Doc
q

-- | Beside, separated by space, unless one of the arguments is 'empty'.
-- '<+>' is associative, with identity 'empty'.
(<+>) :: Doc -> Doc -> Doc
Doc
p <+> :: Doc -> Doc -> Doc
<+> Doc
q = Doc -> Bool -> Doc -> Doc
beside_ Doc
p Bool
True  Doc
q

beside_ :: Doc -> Bool -> Doc -> Doc
beside_ :: Doc -> Bool -> Doc -> Doc
beside_ Doc
p Bool
_ Doc
Empty = Doc
p
beside_ Doc
Empty Bool
_ Doc
q = Doc
q
beside_ Doc
p Bool
g Doc
q     = Doc -> Bool -> Doc -> Doc
Beside Doc
p Bool
g Doc
q

-- Specification: beside g p q = p <g> q
beside :: Doc -> Bool -> RDoc -> RDoc
beside :: Doc -> Bool -> Doc -> Doc
beside Doc
NoDoc               Bool
_ Doc
_   = Doc
NoDoc
beside (Doc
p1 `Union` Doc
p2)     Bool
g Doc
q   = Doc -> Bool -> Doc -> Doc
beside Doc
p1 Bool
g Doc
q Doc -> Doc -> Doc
`union_` Doc -> Bool -> Doc -> Doc
beside Doc
p2 Bool
g Doc
q
beside Doc
Empty               Bool
_ Doc
q   = Doc
q
beside (Nest Int
k Doc
p)          Bool
g Doc
q   = Int -> Doc -> Doc
nest_ Int
k forall a b. (a -> b) -> a -> b
$! Doc -> Bool -> Doc -> Doc
beside Doc
p Bool
g Doc
q
beside p :: Doc
p@(Beside Doc
p1 Bool
g1 Doc
q1) Bool
g2 Doc
q2
         | Bool
g1 forall a. Eq a => a -> a -> Bool
== Bool
g2              = Doc -> Bool -> Doc -> Doc
beside Doc
p1 Bool
g1 forall a b. (a -> b) -> a -> b
$! Doc -> Bool -> Doc -> Doc
beside Doc
q1 Bool
g2 Doc
q2
         | Bool
otherwise             = Doc -> Bool -> Doc -> Doc
beside (Doc -> Doc
reduceDoc Doc
p) Bool
g2 Doc
q2
beside p :: Doc
p@(Above{})         Bool
g Doc
q   = let !d :: Doc
d = Doc -> Doc
reduceDoc Doc
p in Doc -> Bool -> Doc -> Doc
beside Doc
d Bool
g Doc
q
beside (NilAbove Doc
p)        Bool
g Doc
q   = Doc -> Doc
nilAbove_ forall a b. (a -> b) -> a -> b
$! Doc -> Bool -> Doc -> Doc
beside Doc
p Bool
g Doc
q
beside (TextBeside TextDetails
s Int
sl Doc
p) Bool
g Doc
q   = TextDetails -> Int -> Doc -> Doc
textBeside_ TextDetails
s Int
sl Doc
rest
                               where
                                  rest :: Doc
rest = case Doc
p of
                                           Doc
Empty -> Bool -> Doc -> Doc
nilBeside Bool
g Doc
q
                                           Doc
_     -> Doc -> Bool -> Doc -> Doc
beside Doc
p Bool
g Doc
q

-- Specification: text "" <> nilBeside g p
--              = text "" <g> p
nilBeside :: Bool -> RDoc -> RDoc
nilBeside :: Bool -> Doc -> Doc
nilBeside Bool
_ Doc
Empty         = Doc
Empty -- Hence the text "" in the spec
nilBeside Bool
g (Nest Int
_ Doc
p)    = Bool -> Doc -> Doc
nilBeside Bool
g Doc
p
nilBeside Bool
g Doc
p | Bool
g         = TextDetails -> Int -> Doc -> Doc
textBeside_ TextDetails
spaceText Int
1 Doc
p
              | Bool
otherwise = Doc
p


-- ---------------------------------------------------------------------------
-- Separate, @sep@

-- Specification: sep ps  = oneLiner (hsep ps)
--                         `union`
--                          vcat ps

-- | Either 'hsep' or 'vcat'.
sep  :: [Doc] -> Doc
sep :: [Doc] -> Doc
sep = Bool -> [Doc] -> Doc
sepX Bool
True   -- Separate with spaces

-- | Either 'hcat' or 'vcat'.
cat :: [Doc] -> Doc
cat :: [Doc] -> Doc
cat = Bool -> [Doc] -> Doc
sepX Bool
False  -- Don't

sepX :: Bool -> [Doc] -> Doc
sepX :: Bool -> [Doc] -> Doc
sepX Bool
_ []     = Doc
empty
sepX Bool
x (Doc
p:[Doc]
ps) = Bool -> Doc -> Int -> [Doc] -> Doc
sep1 Bool
x (Doc -> Doc
reduceDoc Doc
p) Int
0 [Doc]
ps


-- Specification: sep1 g k ys = sep (x : map (nest k) ys)
--                            = oneLiner (x <g> nest k (hsep ys))
--                              `union` x $$ nest k (vcat ys)
sep1 :: Bool -> RDoc -> Int -> [Doc] -> RDoc
sep1 :: Bool -> Doc -> Int -> [Doc] -> Doc
sep1 Bool
_ Doc
_                   Int
k [Doc]
_  | Int
k seq :: forall a b. a -> b -> b
`seq` Bool
False = forall a. HasCallStack => a
undefined
sep1 Bool
_ Doc
NoDoc               Int
_ [Doc]
_  = Doc
NoDoc
sep1 Bool
g (Doc
p `Union` Doc
q)       Int
k [Doc]
ys = Bool -> Doc -> Int -> [Doc] -> Doc
sep1 Bool
g Doc
p Int
k [Doc]
ys Doc -> Doc -> Doc
`union_`
                                  Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
q Bool
False Int
k (Doc -> Doc
reduceDoc ([Doc] -> Doc
vcat [Doc]
ys))

sep1 Bool
g Doc
Empty               Int
k [Doc]
ys = Int -> Doc -> Doc
mkNest Int
k (Bool -> [Doc] -> Doc
sepX Bool
g [Doc]
ys)
sep1 Bool
g (Nest Int
n Doc
p)          Int
k [Doc]
ys = Int -> Doc -> Doc
nest_ Int
n (Bool -> Doc -> Int -> [Doc] -> Doc
sep1 Bool
g Doc
p (Int
k forall a. Num a => a -> a -> a
- Int
n) [Doc]
ys)

sep1 Bool
_ (NilAbove Doc
p)        Int
k [Doc]
ys = Doc -> Doc
nilAbove_
                                  (Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
p Bool
False Int
k (Doc -> Doc
reduceDoc ([Doc] -> Doc
vcat [Doc]
ys)))
sep1 Bool
g (TextBeside TextDetails
s Int
sl Doc
p) Int
k [Doc]
ys = TextDetails -> Int -> Doc -> Doc
textBeside_ TextDetails
s Int
sl (Bool -> Doc -> Int -> [Doc] -> Doc
sepNB Bool
g Doc
p (Int
k forall a. Num a => a -> a -> a
- Int
sl) [Doc]
ys)
sep1 Bool
_ (Above {})          Int
_ [Doc]
_  = forall a. String -> a
error String
"sep1 Above"
sep1 Bool
_ (Beside {})         Int
_ [Doc]
_  = forall a. String -> a
error String
"sep1 Beside"

-- Specification: sepNB p k ys = sep1 (text "" <> p) k ys
-- Called when we have already found some text in the first item
-- We have to eat up nests
sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc
sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc
sepNB Bool
g (Nest Int
_ Doc
p) Int
k [Doc]
ys
  = Bool -> Doc -> Int -> [Doc] -> Doc
sepNB Bool
g Doc
p Int
k [Doc]
ys -- Never triggered, because of invariant (2)
sepNB Bool
g Doc
Empty Int
k [Doc]
ys
  = Doc -> Doc
oneLiner (Bool -> Doc -> Doc
nilBeside Bool
g (Doc -> Doc
reduceDoc Doc
rest)) Doc -> Doc -> Doc
`mkUnion`
    -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...)
    Bool -> Int -> Doc -> Doc
nilAboveNest Bool
False Int
k (Doc -> Doc
reduceDoc ([Doc] -> Doc
vcat [Doc]
ys))
  where
    rest :: Doc
rest | Bool
g         = [Doc] -> Doc
hsep [Doc]
ys
         | Bool
otherwise = [Doc] -> Doc
hcat [Doc]
ys
sepNB Bool
g Doc
p Int
k [Doc]
ys
  = Bool -> Doc -> Int -> [Doc] -> Doc
sep1 Bool
g Doc
p Int
k [Doc]
ys


-- ---------------------------------------------------------------------------
-- @fill@

-- | \"Paragraph fill\" version of 'cat'.
fcat :: [Doc] -> Doc
fcat :: [Doc] -> Doc
fcat = Bool -> [Doc] -> Doc
fill Bool
False

-- | \"Paragraph fill\" version of 'sep'.
fsep :: [Doc] -> Doc
fsep :: [Doc] -> Doc
fsep = Bool -> [Doc] -> Doc
fill Bool
True

-- Specification:
--
-- fill g docs = fillIndent 0 docs
--
-- fillIndent k [] = []
-- fillIndent k [p] = p
-- fillIndent k (p1:p2:ps) =
--    oneLiner p1 <g> fillIndent (k + length p1 + g ? 1 : 0)
--                               (remove_nests (oneLiner p2) : ps)
--     `Union`
--    (p1 $*$ nest (-k) (fillIndent 0 ps))
--
-- $*$ is defined for layouts (not Docs) as
-- layout1 $*$ layout2 | hasMoreThanOneLine layout1 = layout1 $$ layout2
--                     | otherwise                  = layout1 $+$ layout2

fill :: Bool -> [Doc] -> RDoc
fill :: Bool -> [Doc] -> Doc
fill Bool
_ []     = Doc
empty
fill Bool
g (Doc
p:[Doc]
ps) = Bool -> Doc -> Int -> [Doc] -> Doc
fill1 Bool
g (Doc -> Doc
reduceDoc Doc
p) Int
0 [Doc]
ps

fill1 :: Bool -> RDoc -> Int -> [Doc] -> Doc
fill1 :: Bool -> Doc -> Int -> [Doc] -> Doc
fill1 Bool
_ Doc
_                   Int
k [Doc]
_  | Int
k seq :: forall a b. a -> b -> b
`seq` Bool
False = forall a. HasCallStack => a
undefined
fill1 Bool
_ Doc
NoDoc               Int
_ [Doc]
_  = Doc
NoDoc
fill1 Bool
g (Doc
p `Union` Doc
q)       Int
k [Doc]
ys = Bool -> Doc -> Int -> [Doc] -> Doc
fill1 Bool
g Doc
p Int
k [Doc]
ys Doc -> Doc -> Doc
`union_`
                                   Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
q Bool
False Int
k (Bool -> [Doc] -> Doc
fill Bool
g [Doc]
ys)
fill1 Bool
g Doc
Empty               Int
k [Doc]
ys = Int -> Doc -> Doc
mkNest Int
k (Bool -> [Doc] -> Doc
fill Bool
g [Doc]
ys)
fill1 Bool
g (Nest Int
n Doc
p)          Int
k [Doc]
ys = Int -> Doc -> Doc
nest_ Int
n (Bool -> Doc -> Int -> [Doc] -> Doc
fill1 Bool
g Doc
p (Int
k forall a. Num a => a -> a -> a
- Int
n) [Doc]
ys)
fill1 Bool
g (NilAbove Doc
p)        Int
k [Doc]
ys = Doc -> Doc
nilAbove_ (Doc -> Bool -> Int -> Doc -> Doc
aboveNest Doc
p Bool
False Int
k (Bool -> [Doc] -> Doc
fill Bool
g [Doc]
ys))
fill1 Bool
g (TextBeside TextDetails
s Int
sl Doc
p) Int
k [Doc]
ys = TextDetails -> Int -> Doc -> Doc
textBeside_ TextDetails
s Int
sl (Bool -> Doc -> Int -> [Doc] -> Doc
fillNB Bool
g Doc
p (Int
k forall a. Num a => a -> a -> a
- Int
sl) [Doc]
ys)
fill1 Bool
_ (Above {})          Int
_ [Doc]
_  = forall a. String -> a
error String
"fill1 Above"
fill1 Bool
_ (Beside {})         Int
_ [Doc]
_  = forall a. String -> a
error String
"fill1 Beside"

fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc
fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc
fillNB Bool
_ Doc
_           Int
k [Doc]
_  | Int
k seq :: forall a b. a -> b -> b
`seq` Bool
False = forall a. HasCallStack => a
undefined
fillNB Bool
g (Nest Int
_ Doc
p)  Int
k [Doc]
ys   = Bool -> Doc -> Int -> [Doc] -> Doc
fillNB Bool
g Doc
p Int
k [Doc]
ys
                              -- Never triggered, because of invariant (2)
fillNB Bool
_ Doc
Empty Int
_ []         = Doc
Empty
fillNB Bool
g Doc
Empty Int
k (Doc
Empty:[Doc]
ys) = Bool -> Doc -> Int -> [Doc] -> Doc
fillNB Bool
g Doc
Empty Int
k [Doc]
ys
fillNB Bool
g Doc
Empty Int
k (Doc
y:[Doc]
ys)     = Bool -> Int -> Doc -> [Doc] -> Doc
fillNBE Bool
g Int
k Doc
y [Doc]
ys
fillNB Bool
g Doc
p Int
k [Doc]
ys             = Bool -> Doc -> Int -> [Doc] -> Doc
fill1 Bool
g Doc
p Int
k [Doc]
ys


fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc
fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc
fillNBE Bool
g Int
k Doc
y [Doc]
ys
  = Bool -> Doc -> Doc
nilBeside Bool
g (Bool -> Doc -> Int -> [Doc] -> Doc
fill1 Bool
g ((Doc -> Doc
elideNest forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
oneLiner forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Doc
reduceDoc) Doc
y) Int
k' [Doc]
ys)
    -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...)
    Doc -> Doc -> Doc
`mkUnion` Bool -> Int -> Doc -> Doc
nilAboveNest Bool
False Int
k (Bool -> [Doc] -> Doc
fill Bool
g (Doc
yforall a. a -> [a] -> [a]
:[Doc]
ys))
  where k' :: Int
k' = if Bool
g then Int
k forall a. Num a => a -> a -> a
- Int
1 else Int
k

elideNest :: Doc -> Doc
elideNest :: Doc -> Doc
elideNest (Nest Int
_ Doc
d) = Doc
d
elideNest Doc
d          = Doc
d

-- ---------------------------------------------------------------------------
-- Selecting the best layout

best :: Int   -- Line length
     -> Int   -- Ribbon length
     -> RDoc
     -> RDoc  -- No unions in here!
best :: Int -> Int -> Doc -> Doc
best Int
w0 Int
r = Int -> Doc -> Doc
get Int
w0
  where
    get :: Int          -- (Remaining) width of line
        -> Doc -> Doc
    get :: Int -> Doc -> Doc
get Int
w Doc
_ | Int
w forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Bool
False = forall a. HasCallStack => a
undefined
    get Int
_ Doc
Empty               = Doc
Empty
    get Int
_ Doc
NoDoc               = Doc
NoDoc
    get Int
w (NilAbove Doc
p)        = Doc -> Doc
nilAbove_ (Int -> Doc -> Doc
get Int
w Doc
p)
    get Int
w (TextBeside TextDetails
s Int
sl Doc
p) = TextDetails -> Int -> Doc -> Doc
textBeside_ TextDetails
s Int
sl (Int -> Int -> Doc -> Doc
get1 Int
w Int
sl Doc
p)
    get Int
w (Nest Int
k Doc
p)          = Int -> Doc -> Doc
nest_ Int
k (Int -> Doc -> Doc
get (Int
w forall a. Num a => a -> a -> a
- Int
k) Doc
p)
    get Int
w (Doc
p `Union` Doc
q)       = Int -> Int -> Doc -> Doc -> Doc
nicest Int
w Int
r (Int -> Doc -> Doc
get Int
w Doc
p) (Int -> Doc -> Doc
get Int
w Doc
q)
    get Int
_ (Above {})          = forall a. String -> a
error String
"best get Above"
    get Int
_ (Beside {})         = forall a. String -> a
error String
"best get Beside"

    get1 :: Int         -- (Remaining) width of line
         -> Int         -- Amount of first line already eaten up
         -> Doc         -- This is an argument to TextBeside => eat Nests
         -> Doc         -- No unions in here!

    get1 :: Int -> Int -> Doc -> Doc
get1 Int
w Int
_ Doc
_ | Int
w forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Bool
False  = forall a. HasCallStack => a
undefined
    get1 Int
_ Int
_  Doc
Empty               = Doc
Empty
    get1 Int
_ Int
_  Doc
NoDoc               = Doc
NoDoc
    get1 Int
w Int
sl (NilAbove Doc
p)        = Doc -> Doc
nilAbove_ (Int -> Doc -> Doc
get (Int
w forall a. Num a => a -> a -> a
- Int
sl) Doc
p)
    get1 Int
w Int
sl (TextBeside TextDetails
t Int
tl Doc
p) = TextDetails -> Int -> Doc -> Doc
textBeside_ TextDetails
t Int
tl (Int -> Int -> Doc -> Doc
get1 Int
w (Int
sl forall a. Num a => a -> a -> a
+ Int
tl) Doc
p)
    get1 Int
w Int
sl (Nest Int
_ Doc
p)          = Int -> Int -> Doc -> Doc
get1 Int
w Int
sl Doc
p
    get1 Int
w Int
sl (Doc
p `Union` Doc
q)       = Int -> Int -> Int -> Doc -> Doc -> Doc
nicest1 Int
w Int
r Int
sl (Int -> Int -> Doc -> Doc
get1 Int
w Int
sl Doc
p)
                                                   (Int -> Int -> Doc -> Doc
get1 Int
w Int
sl Doc
q)
    get1 Int
_ Int
_  (Above {})          = forall a. String -> a
error String
"best get1 Above"
    get1 Int
_ Int
_  (Beside {})         = forall a. String -> a
error String
"best get1 Beside"

nicest :: Int -> Int -> Doc -> Doc -> Doc
nicest :: Int -> Int -> Doc -> Doc -> Doc
nicest !Int
w !Int
r = Int -> Int -> Int -> Doc -> Doc -> Doc
nicest1 Int
w Int
r Int
0

nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc
nicest1 :: Int -> Int -> Int -> Doc -> Doc -> Doc
nicest1 !Int
w !Int
r !Int
sl Doc
p Doc
q | Int -> Doc -> Bool
fits ((Int
w forall a. Ord a => a -> a -> a
`min` Int
r) forall a. Num a => a -> a -> a
- Int
sl) Doc
p = Doc
p
                      | Bool
otherwise                 = Doc
q

fits :: Int  -- Space available
     -> Doc
     -> Bool -- True if *first line* of Doc fits in space available
fits :: Int -> Doc -> Bool
fits Int
n Doc
_ | Int
n forall a. Ord a => a -> a -> Bool
< Int
0           = Bool
False
fits Int
_ Doc
NoDoc               = Bool
False
fits Int
_ Doc
Empty               = Bool
True
fits Int
_ (NilAbove Doc
_)        = Bool
True
fits Int
n (TextBeside TextDetails
_ Int
sl Doc
p) = Int -> Doc -> Bool
fits (Int
n forall a. Num a => a -> a -> a
- Int
sl) Doc
p
fits Int
_ (Above {})          = forall a. String -> a
error String
"fits Above"
fits Int
_ (Beside {})         = forall a. String -> a
error String
"fits Beside"
fits Int
_ (Union {})          = forall a. String -> a
error String
"fits Union"
fits Int
_ (Nest {})           = forall a. String -> a
error String
"fits Nest"

-- | @first@ returns its first argument if it is non-empty, otherwise its second.
first :: Doc -> Doc -> Doc
first :: Doc -> Doc -> Doc
first Doc
p Doc
q | Doc -> Bool
nonEmptySet Doc
p = Doc
p -- unused, because (get OneLineMode) is unused
          | Bool
otherwise     = Doc
q

nonEmptySet :: Doc -> Bool
nonEmptySet :: Doc -> Bool
nonEmptySet Doc
NoDoc              = Bool
False
nonEmptySet (Doc
_ `Union` Doc
_)      = Bool
True
nonEmptySet Doc
Empty              = Bool
True
nonEmptySet (NilAbove Doc
_)       = Bool
True
nonEmptySet (TextBeside TextDetails
_ Int
_ Doc
p) = Doc -> Bool
nonEmptySet Doc
p
nonEmptySet (Nest Int
_ Doc
p)         = Doc -> Bool
nonEmptySet Doc
p
nonEmptySet (Above {})         = forall a. String -> a
error String
"nonEmptySet Above"
nonEmptySet (Beside {})        = forall a. String -> a
error String
"nonEmptySet Beside"

-- @oneLiner@ returns the one-line members of the given set of @GDoc@s.
oneLiner :: Doc -> Doc
oneLiner :: Doc -> Doc
oneLiner Doc
NoDoc               = Doc
NoDoc
oneLiner Doc
Empty               = Doc
Empty
oneLiner (NilAbove Doc
_)        = Doc
NoDoc
oneLiner (TextBeside TextDetails
s Int
sl Doc
p) = TextDetails -> Int -> Doc -> Doc
textBeside_ TextDetails
s Int
sl (Doc -> Doc
oneLiner Doc
p)
oneLiner (Nest Int
k Doc
p)          = Int -> Doc -> Doc
nest_ Int
k (Doc -> Doc
oneLiner Doc
p)
oneLiner (Doc
p `Union` Doc
_)       = Doc -> Doc
oneLiner Doc
p
oneLiner (Above {})          = forall a. String -> a
error String
"oneLiner Above"
oneLiner (Beside {})         = forall a. String -> a
error String
"oneLiner Beside"


-- ---------------------------------------------------------------------------
-- Rendering

-- | A rendering style.
data Style
  = Style { Style -> Mode
mode           :: Mode  -- ^ The rendering mode
          , Style -> Int
lineLength     :: Int   -- ^ Length of line, in chars
          , Style -> Float
ribbonsPerLine :: Float -- ^ Ratio of line length to ribbon length
          }

-- | The default style (@mode=PageMode False, lineLength=100, ribbonsPerLine=1.5@).
style :: Style
style :: Style
style = Style { lineLength :: Int
lineLength = Int
100, ribbonsPerLine :: Float
ribbonsPerLine = Float
1.5, mode :: Mode
mode = Bool -> Mode
PageMode Bool
False }

-- | Rendering mode.
data Mode = PageMode { Mode -> Bool
asciiSpace :: Bool }    -- ^ Normal
          | ZigZagMode   -- ^ With zig-zag cuts
          | LeftMode     -- ^ No indentation, infinitely long lines
          | OneLineMode  -- ^ All on one line

-- | Can we output an ascii space character for spaces?
--   Mostly true, but not for e.g. UTF16
--   See Note [putSpaces optimizations] for why we bother
--   to track this.
hasAsciiSpace :: Mode -> Bool
hasAsciiSpace :: Mode -> Bool
hasAsciiSpace Mode
mode =
  case Mode
mode of
    PageMode Bool
asciiSpace -> Bool
asciiSpace
    Mode
_ -> Bool
False

-- | Render the @Doc@ to a String using the given @Style@.
renderStyle :: Style -> Doc -> String
renderStyle :: Style -> Doc -> String
renderStyle Style
s = forall a.
Mode -> Int -> Float -> (TextDetails -> a -> a) -> a -> Doc -> a
fullRender (Style -> Mode
mode Style
s) (Style -> Int
lineLength Style
s) (Style -> Float
ribbonsPerLine Style
s)
                TextDetails -> ShowS
txtPrinter String
""

-- | Default TextDetails printer
txtPrinter :: TextDetails -> String -> String
txtPrinter :: TextDetails -> ShowS
txtPrinter (Chr Char
c)    String
s  = Char
cforall a. a -> [a] -> [a]
:String
s
txtPrinter (Str String
s1)   String
s2 = String
s1 forall a. [a] -> [a] -> [a]
++ String
s2
txtPrinter (PStr FastString
s1)  String
s2 = FastString -> String
unpackFS FastString
s1 forall a. [a] -> [a] -> [a]
++ String
s2
txtPrinter (ZStr FastZString
s1)  String
s2 = FastZString -> String
zString FastZString
s1 forall a. [a] -> [a] -> [a]
++ String
s2
txtPrinter (LStr PtrString
s1)  String
s2 = PtrString -> String
unpackPtrString PtrString
s1 forall a. [a] -> [a] -> [a]
++ String
s2
txtPrinter (RStr Int
n Char
c) String
s2 = forall a. Int -> a -> [a]
replicate Int
n Char
c forall a. [a] -> [a] -> [a]
++ String
s2

-- | The general rendering interface.
fullRender :: Mode                     -- ^ Rendering mode
           -> Int                      -- ^ Line length
           -> Float                    -- ^ Ribbons per line
           -> (TextDetails -> a -> a)  -- ^ What to do with text
           -> a                        -- ^ What to do at the end
           -> Doc                      -- ^ The document
           -> a                        -- ^ Result
fullRender :: forall a.
Mode -> Int -> Float -> (TextDetails -> a -> a) -> a -> Doc -> a
fullRender Mode
OneLineMode Int
_ Float
_ TextDetails -> a -> a
txt a
end Doc
doc
  = forall a.
TextDetails
-> (Doc -> Doc -> Doc) -> (TextDetails -> a -> a) -> a -> Doc -> a
easyDisplay TextDetails
spaceText (\Doc
_ Doc
y -> Doc
y) TextDetails -> a -> a
txt a
end (Doc -> Doc
reduceDoc Doc
doc)
fullRender Mode
LeftMode    Int
_ Float
_ TextDetails -> a -> a
txt a
end Doc
doc
  = forall a.
TextDetails
-> (Doc -> Doc -> Doc) -> (TextDetails -> a -> a) -> a -> Doc -> a
easyDisplay TextDetails
nlText Doc -> Doc -> Doc
first TextDetails -> a -> a
txt a
end (Doc -> Doc
reduceDoc Doc
doc)

fullRender Mode
m Int
lineLen Float
ribbons TextDetails -> a -> a
txt a
rest Doc
doc
  = forall a.
Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a
display Mode
m Int
lineLen Int
ribbonLen TextDetails -> a -> a
txt a
rest Doc
doc'
  where
    doc' :: Doc
doc' = Int -> Int -> Doc -> Doc
best Int
bestLineLen Int
ribbonLen (Doc -> Doc
reduceDoc Doc
doc)

    bestLineLen, ribbonLen :: Int
    ribbonLen :: Int
ribbonLen   = forall a b. (RealFrac a, Integral b) => a -> b
round (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lineLen forall a. Fractional a => a -> a -> a
/ Float
ribbons)
    bestLineLen :: Int
bestLineLen = case Mode
m of
                      Mode
ZigZagMode -> forall a. Bounded a => a
maxBound
                      Mode
_          -> Int
lineLen

easyDisplay :: TextDetails
             -> (Doc -> Doc -> Doc)
             -> (TextDetails -> a -> a)
             -> a
             -> Doc
             -> a
easyDisplay :: forall a.
TextDetails
-> (Doc -> Doc -> Doc) -> (TextDetails -> a -> a) -> a -> Doc -> a
easyDisplay TextDetails
nlSpaceText Doc -> Doc -> Doc
choose TextDetails -> a -> a
txt a
end
  = Doc -> a
lay
  where
    lay :: Doc -> a
lay Doc
NoDoc              = forall a. String -> a
error String
"easyDisplay: NoDoc"
    lay (Union Doc
p Doc
q)        = Doc -> a
lay (Doc -> Doc -> Doc
choose Doc
p Doc
q)
    lay (Nest Int
_ Doc
p)         = Doc -> a
lay Doc
p
    lay Doc
Empty              = a
end
    lay (NilAbove Doc
p)       = TextDetails
nlSpaceText TextDetails -> a -> a
`txt` Doc -> a
lay Doc
p
    lay (TextBeside TextDetails
s Int
_ Doc
p) = TextDetails
s TextDetails -> a -> a
`txt` Doc -> a
lay Doc
p
    lay (Above {})         = forall a. String -> a
error String
"easyDisplay Above"
    lay (Beside {})        = forall a. String -> a
error String
"easyDisplay Beside"

display :: Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a
display :: forall a.
Mode -> Int -> Int -> (TextDetails -> a -> a) -> a -> Doc -> a
display Mode
m !Int
page_width !Int
ribbon_width TextDetails -> a -> a
txt a
end Doc
doc
  = case Int
page_width forall a. Num a => a -> a -> a
- Int
ribbon_width of { Int
gap_width ->
    case Int
gap_width forall a. Integral a => a -> a -> a
`quot` Int
2 of { Int
shift ->
    let
        lay :: Int -> Doc -> a
lay Int
k Doc
_            | Int
k seq :: forall a b. a -> b -> b
`seq` Bool
False = forall a. HasCallStack => a
undefined
        lay Int
k (Nest Int
k1 Doc
p)  = Int -> Doc -> a
lay (Int
k forall a. Num a => a -> a -> a
+ Int
k1) Doc
p
        lay Int
_ Doc
Empty        = a
end
        lay Int
k (NilAbove Doc
p) = TextDetails
nlText TextDetails -> a -> a
`txt` Int -> Doc -> a
lay Int
k Doc
p
        lay Int
k (TextBeside TextDetails
s Int
sl Doc
p)
            = case Mode
m of
                    Mode
ZigZagMode |  Int
k forall a. Ord a => a -> a -> Bool
>= Int
gap_width
                               -> TextDetails
nlText TextDetails -> a -> a
`txt` (
                                  String -> TextDetails
Str (forall a. Int -> a -> [a]
replicate Int
shift Char
'/') TextDetails -> a -> a
`txt` (
                                  TextDetails
nlText TextDetails -> a -> a
`txt`
                                  Int -> TextDetails -> Int -> Doc -> a
lay1 (Int
k forall a. Num a => a -> a -> a
- Int
shift) TextDetails
s Int
sl Doc
p ))

                               |  Int
k forall a. Ord a => a -> a -> Bool
< Int
0
                               -> TextDetails
nlText TextDetails -> a -> a
`txt` (
                                  String -> TextDetails
Str (forall a. Int -> a -> [a]
replicate Int
shift Char
'\\') TextDetails -> a -> a
`txt` (
                                  TextDetails
nlText TextDetails -> a -> a
`txt`
                                  Int -> TextDetails -> Int -> Doc -> a
lay1 (Int
k forall a. Num a => a -> a -> a
+ Int
shift) TextDetails
s Int
sl Doc
p ))

                    Mode
_ -> Int -> TextDetails -> Int -> Doc -> a
lay1 Int
k TextDetails
s Int
sl Doc
p
        lay Int
_ (Above {})   = forall a. String -> a
error String
"display lay Above"
        lay Int
_ (Beside {})  = forall a. String -> a
error String
"display lay Beside"
        lay Int
_ Doc
NoDoc        = forall a. String -> a
error String
"display lay NoDoc"
        lay Int
_ (Union {})   = forall a. String -> a
error String
"display lay Union"

        lay1 :: Int -> TextDetails -> Int -> Doc -> a
lay1 !Int
k TextDetails
s !Int
sl Doc
p    = let !r :: Int
r = Int
k forall a. Num a => a -> a -> a
+ Int
sl
                             in Int -> a -> a
indent Int
k (TextDetails
s TextDetails -> a -> a
`txt` Int -> Doc -> a
lay2 Int
r Doc
p)

        lay2 :: Int -> Doc -> a
lay2 Int
k Doc
_ | Int
k seq :: forall a b. a -> b -> b
`seq` Bool
False   = forall a. HasCallStack => a
undefined
        lay2 Int
k (NilAbove Doc
p)        = TextDetails
nlText TextDetails -> a -> a
`txt` Int -> Doc -> a
lay Int
k Doc
p
        lay2 Int
k (TextBeside TextDetails
s Int
sl Doc
p) = TextDetails
s TextDetails -> a -> a
`txt` Int -> Doc -> a
lay2 (Int
k forall a. Num a => a -> a -> a
+ Int
sl) Doc
p
        lay2 Int
k (Nest Int
_ Doc
p)          = Int -> Doc -> a
lay2 Int
k Doc
p
        lay2 Int
_ Doc
Empty               = a
end
        lay2 Int
_ (Above {})          = forall a. String -> a
error String
"display lay2 Above"
        lay2 Int
_ (Beside {})         = forall a. String -> a
error String
"display lay2 Beside"
        lay2 Int
_ Doc
NoDoc               = forall a. String -> a
error String
"display lay2 NoDoc"
        lay2 Int
_ (Union {})          = forall a. String -> a
error String
"display lay2 Union"

        indent :: Int -> a -> a
indent !Int
n a
r                = Int -> Char -> TextDetails
RStr Int
n Char
' ' TextDetails -> a -> a
`txt` a
r
    in
    Int -> Doc -> a
lay Int
0 Doc
doc
    }}

printDoc :: Mode -> Int -> Handle -> Doc -> IO ()
-- printDoc adds a newline to the end
printDoc :: Mode -> Int -> Handle -> Doc -> IO ()
printDoc Mode
mode Int
cols Handle
hdl Doc
doc = Mode -> Int -> Handle -> Doc -> IO ()
printDoc_ Mode
mode Int
cols Handle
hdl (Doc
doc Doc -> Doc -> Doc
$$ String -> Doc
text String
"")

{- Note [putSpaces optimizations]
   ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

When using dump flags a lot of what we are dumping ends up being whitespace.
This is especially true for Core/Stg dumps. Enough so that it's worth optimizing.

Especially in the common case of writing to an UTF8 or similarly encoded file
where space is equal to ascii space we use hPutBuf to write a preallocated
buffer to the file. This avoids a fair bit of allocation.

For other cases we fall back to the old and slow path for simplicity.

-}

printDoc_ :: Mode -> Int -> Handle -> Doc -> IO ()
-- printDoc_ does not add a newline at the end, so that
-- successive calls can output stuff on the same line
-- Rather like putStr vs putStrLn
printDoc_ :: Mode -> Int -> Handle -> Doc -> IO ()
printDoc_ Mode
LeftMode Int
_ Handle
hdl Doc
doc
  = do { Handle -> Doc -> IO ()
printLeftRender Handle
hdl Doc
doc; Handle -> IO ()
hFlush Handle
hdl }
printDoc_ Mode
mode Int
pprCols Handle
hdl Doc
doc
  = do { forall a.
Mode -> Int -> Float -> (TextDetails -> a -> a) -> a -> Doc -> a
fullRender Mode
mode Int
pprCols Float
1.5 TextDetails -> IO () -> IO ()
put IO ()
done Doc
doc ;
         Handle -> IO ()
hFlush Handle
hdl }
  where
    put :: TextDetails -> IO () -> IO ()
put (Chr Char
c)    IO ()
next = Handle -> Char -> IO ()
hPutChar Handle
hdl Char
c forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
next
    put (Str String
s)    IO ()
next = Handle -> String -> IO ()
hPutStr  Handle
hdl String
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
next
    put (PStr FastString
s)   IO ()
next = Handle -> String -> IO ()
hPutStr  Handle
hdl (FastString -> String
unpackFS FastString
s) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
next
                          -- NB. not hPutFS, we want this to go through
                          -- the I/O library's encoding layer. (#3398)
    put (ZStr FastZString
s)   IO ()
next = Handle -> FastZString -> IO ()
hPutFZS  Handle
hdl FastZString
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
next
    put (LStr PtrString
s)   IO ()
next = Handle -> PtrString -> IO ()
hPutPtrString Handle
hdl PtrString
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
next
    put (RStr Int
n Char
c) IO ()
next
      | Char
c forall a. Eq a => a -> a -> Bool
== Char
' '
      = Int -> IO ()
putSpaces Int
n forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
next
      | Bool
otherwise
      = Handle -> String -> IO ()
hPutStr Handle
hdl (forall a. Int -> a -> [a]
replicate Int
n Char
c) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
next
    putSpaces :: Int -> IO ()
putSpaces Int
n
      -- If we use ascii spaces we are allowed to use hPutBuf
      -- See Note [putSpaces optimizations]
      | Mode -> Bool
hasAsciiSpace Mode
mode
      , Int
n forall a. Ord a => a -> a -> Bool
<= Int
100
      = forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
hdl (forall a. Addr# -> Ptr a
Ptr Addr#
spaces') Int
n
      | Mode -> Bool
hasAsciiSpace Mode
mode
      , Int
n forall a. Ord a => a -> a -> Bool
> Int
100
      = forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
hdl (forall a. Addr# -> Ptr a
Ptr Addr#
spaces') Int
100 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Int -> IO ()
putSpaces (Int
nforall a. Num a => a -> a -> a
-Int
100)

      | Bool
otherwise = Handle -> String -> IO ()
hPutStr Handle
hdl (forall a. Int -> a -> [a]
replicate Int
n Char
' ')

    done :: IO ()
done = forall (m :: * -> *) a. Monad m => a -> m a
return () -- hPutChar hdl '\n'
    -- 100 spaces, so we avoid the allocation of replicate n ' '
    spaces' :: Addr#
spaces' = Addr#
"                                                                                                    "#


  -- some versions of hPutBuf will barf if the length is zero
hPutPtrString :: Handle -> PtrString -> IO ()
hPutPtrString :: Handle -> PtrString -> IO ()
hPutPtrString Handle
_handle (PtrString Ptr Word8
_ Int
0) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
hPutPtrString Handle
handle  (PtrString Ptr Word8
a Int
l) = forall a. Handle -> Ptr a -> Int -> IO ()
hPutBuf Handle
handle Ptr Word8
a Int
l

-- Printing output in LeftMode is performance critical: it's used when
-- dumping C and assembly output, so we allow ourselves a few dirty
-- hacks:
--
-- (1) we specialise fullRender for LeftMode with IO output.
--
-- (2) we add a layer of buffering on top of Handles.  Handles
--     don't perform well with lots of hPutChars, which is mostly
--     what we're doing here, because Handles have to be thread-safe
--     and async exception-safe.  We only have a single thread and don't
--     care about exceptions, so we add a layer of fast buffering
--     over the Handle interface.

printLeftRender :: Handle -> Doc -> IO ()
printLeftRender :: Handle -> Doc -> IO ()
printLeftRender Handle
hdl Doc
doc = do
  BufHandle
b <- Handle -> IO BufHandle
newBufHandle Handle
hdl
  BufHandle -> Doc -> IO ()
bufLeftRender BufHandle
b Doc
doc
  BufHandle -> IO ()
bFlush BufHandle
b

bufLeftRender :: BufHandle -> Doc -> IO ()
bufLeftRender :: BufHandle -> Doc -> IO ()
bufLeftRender BufHandle
b Doc
doc = BufHandle -> Doc -> IO ()
layLeft BufHandle
b (Doc -> Doc
reduceDoc Doc
doc)

layLeft :: BufHandle -> Doc -> IO ()
layLeft :: BufHandle -> Doc -> IO ()
layLeft BufHandle
b Doc
_ | BufHandle
b seq :: forall a b. a -> b -> b
`seq` Bool
False  = forall a. HasCallStack => a
undefined -- make it strict in b
layLeft BufHandle
_ Doc
NoDoc              = forall a. String -> a
error String
"layLeft: NoDoc"
layLeft BufHandle
b (Union Doc
p Doc
q)        = BufHandle -> Doc -> IO ()
layLeft BufHandle
b forall a b. (a -> b) -> a -> b
$! Doc -> Doc -> Doc
first Doc
p Doc
q
layLeft BufHandle
b (Nest Int
_ Doc
p)         = BufHandle -> Doc -> IO ()
layLeft BufHandle
b forall a b. (a -> b) -> a -> b
$! Doc
p
layLeft BufHandle
b Doc
Empty              = BufHandle -> Char -> IO ()
bPutChar BufHandle
b Char
'\n'
layLeft BufHandle
b (NilAbove Doc
p)       = Doc
p seq :: forall a b. a -> b -> b
`seq` (BufHandle -> Char -> IO ()
bPutChar BufHandle
b Char
'\n' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BufHandle -> Doc -> IO ()
layLeft BufHandle
b Doc
p)
layLeft BufHandle
b (TextBeside TextDetails
s Int
_ Doc
p) = TextDetails
s seq :: forall a b. a -> b -> b
`seq` (BufHandle -> TextDetails -> IO ()
put BufHandle
b TextDetails
s forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BufHandle -> Doc -> IO ()
layLeft BufHandle
b Doc
p)
 where
    put :: BufHandle -> TextDetails -> IO ()
put BufHandle
b TextDetails
_ | BufHandle
b seq :: forall a b. a -> b -> b
`seq` Bool
False = forall a. HasCallStack => a
undefined
    put BufHandle
b (Chr Char
c)    = BufHandle -> Char -> IO ()
bPutChar BufHandle
b Char
c
    put BufHandle
b (Str String
s)    = BufHandle -> String -> IO ()
bPutStr  BufHandle
b String
s
    put BufHandle
b (PStr FastString
s)   = BufHandle -> FastString -> IO ()
bPutFS   BufHandle
b FastString
s
    put BufHandle
b (ZStr FastZString
s)   = BufHandle -> FastZString -> IO ()
bPutFZS  BufHandle
b FastZString
s
    put BufHandle
b (LStr PtrString
s)   = BufHandle -> PtrString -> IO ()
bPutPtrString BufHandle
b PtrString
s
    put BufHandle
b (RStr Int
n Char
c) = BufHandle -> Int -> Char -> IO ()
bPutReplicate BufHandle
b Int
n Char
c
layLeft BufHandle
_ Doc
_                  = forall a. String -> a
panic String
"layLeft: Unhandled case"

-- Define error=panic, for easier comparison with libraries/pretty.
error :: String -> a
error :: forall a. String -> a
error = forall a. String -> a
panic