{-# OPTIONS_HADDOCK not-home #-}
{-# LANGUAGE BangPatterns #-}
#if __GLASGOW_HASKELL__ >= 701
{-# LANGUAGE Safe #-}
{-# LANGUAGE DeriveGeneric #-}
#endif

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.PrettyPrint.Annotated.HughesPJ
-- Copyright   :  (c) Trevor Elliott <revor@galois.com> 2015
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  David Terei <code@davidterei.com>
-- Stability   :  stable
-- Portability :  portable
--
-- This module provides a version of pretty that allows for annotations to be
-- attached to documents. Annotations are arbitrary pieces of metadata that can
-- be attached to sub-documents.
--
-----------------------------------------------------------------------------

#ifndef TESTING
module Text.PrettyPrint.Annotated.HughesPJ (

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

        -- * Constructing documents

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

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

        -- ** Wrapping documents in delimiters
        parens, brackets, braces, quotes, doubleQuotes,
        maybeParens, maybeBrackets, maybeBraces, maybeQuotes, maybeDoubleQuotes,

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

        -- ** Annotating documents
        annotate,

        -- * Predicates on documents
        isEmpty,

        -- * Utility functions for documents
        first, reduceDoc,

        -- * Rendering documents

        -- ** Default rendering
        render,

        -- ** Annotation rendering
        renderSpans, Span(..),
        renderDecorated,
        renderDecoratedM,

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

        -- ** General rendering
        fullRender,
        fullRenderAnn

    ) where
#endif

import Control.DeepSeq ( NFData(rnf) )
import Data.Function   ( on )
#if __GLASGOW_HASKELL__ >= 803
import Prelude         hiding ( (<>) )
#endif
#if __GLASGOW_HASKELL__ >= 800
import qualified Data.Semigroup as Semi ( Semigroup((<>)) )
#elif __GLASGOW_HASKELL__ < 709
import Data.Monoid     ( Monoid(mempty, mappend)  )
#endif
import Data.String     ( IsString(fromString) )

import GHC.Generics

-- ---------------------------------------------------------------------------
-- 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 verion 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 a
  = Empty                                            -- ^ An empty span, see 'empty'.
  | NilAbove (Doc a)                                 -- ^ @text "" $$ x@.
  | TextBeside !(AnnotDetails a) (Doc a)             -- ^ @text s <> x@.
  | Nest {-# UNPACK #-} !Int (Doc a)                 -- ^ @nest k x@.
  | Union (Doc a) (Doc a)                            -- ^ @ul `union` ur@.
  | NoDoc                                            -- ^ The empty set of documents.
  | Beside (Doc a) Bool (Doc a)                      -- ^ True <=> space between.
  | Above (Doc a) Bool (Doc a)                       -- ^ True <=> never overlap.
#if __GLASGOW_HASKELL__ >= 701
  deriving ((forall x. Doc a -> Rep (Doc a) x)
-> (forall x. Rep (Doc a) x -> Doc a) -> Generic (Doc a)
forall x. Rep (Doc a) x -> Doc a
forall x. Doc a -> Rep (Doc a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (Doc a) x -> Doc a
forall a x. Doc a -> Rep (Doc a) x
$cto :: forall a x. Rep (Doc a) x -> Doc a
$cfrom :: forall a x. Doc a -> Rep (Doc a) x
Generic)
#endif

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

-- | An annotation (side-metadata) attached at a particular point in a @Doc@.
-- Allows carrying non-pretty-printed data around in a @Doc@ that is attached
-- at particular points in the structure. Once the @Doc@ is render to an output
-- type (such as 'String'), we can also retrieve where in the rendered document
-- our annotations start and end (see 'Span' and 'renderSpans').
data AnnotDetails a = AnnotStart
                    | NoAnnot !TextDetails {-# UNPACK #-} !Int
                    | AnnotEnd a
                      deriving (Int -> AnnotDetails a -> ShowS
[AnnotDetails a] -> ShowS
AnnotDetails a -> String
(Int -> AnnotDetails a -> ShowS)
-> (AnnotDetails a -> String)
-> ([AnnotDetails a] -> ShowS)
-> Show (AnnotDetails a)
forall a. Show a => Int -> AnnotDetails a -> ShowS
forall a. Show a => [AnnotDetails a] -> ShowS
forall a. Show a => AnnotDetails a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AnnotDetails a] -> ShowS
$cshowList :: forall a. Show a => [AnnotDetails a] -> ShowS
show :: AnnotDetails a -> String
$cshow :: forall a. Show a => AnnotDetails a -> String
showsPrec :: Int -> AnnotDetails a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> AnnotDetails a -> ShowS
External instance of the constraint type Show Int
External instance of the constraint type Ord Int
External instance of the constraint type Ord Int
Instance of class: Show of the constraint type Show TextDetails
Evidence bound by a type signature of the constraint type Show a
Show,AnnotDetails a -> AnnotDetails a -> Bool
(AnnotDetails a -> AnnotDetails a -> Bool)
-> (AnnotDetails a -> AnnotDetails a -> Bool)
-> Eq (AnnotDetails a)
forall a. Eq a => AnnotDetails a -> AnnotDetails a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AnnotDetails a -> AnnotDetails a -> Bool
$c/= :: forall a. Eq a => AnnotDetails a -> AnnotDetails a -> Bool
== :: AnnotDetails a -> AnnotDetails a -> Bool
$c== :: forall a. Eq a => AnnotDetails a -> AnnotDetails a -> Bool
External instance of the constraint type Eq Int
Instance of class: Eq of the constraint type Eq TextDetails
Evidence bound by a type signature of the constraint type Eq a
Eq)

instance Functor AnnotDetails where
  fmap :: (a -> b) -> AnnotDetails a -> AnnotDetails b
fmap a -> b
_ AnnotDetails a
AnnotStart     = AnnotDetails b
forall a. AnnotDetails a
AnnotStart
  fmap a -> b
_ (NoAnnot TextDetails
d Int
i)  = TextDetails -> Int -> AnnotDetails b
forall a. TextDetails -> Int -> AnnotDetails a
NoAnnot TextDetails
d Int
i
  fmap a -> b
f (AnnotEnd a
a)   = b -> AnnotDetails b
forall a. a -> AnnotDetails a
AnnotEnd (a -> b
f a
a)

-- NOTE: Annotations are assumed to have zero length; only text has a length.
annotSize :: AnnotDetails a -> Int
annotSize :: AnnotDetails a -> Int
annotSize (NoAnnot TextDetails
_ Int
l) = Int
l
annotSize AnnotDetails a
_             = Int
0

-- | A TextDetails represents a fragment of text that will be output at some
-- point in a @Doc@.
data TextDetails = Chr  {-# UNPACK #-} !Char -- ^ A single Char fragment
                 | Str  String -- ^ A whole String fragment
                 | PStr String -- ^ Used to represent a Fast String fragment
                               --   but now deprecated and identical to the
                               --   Str constructor.
#if __GLASGOW_HASKELL__ >= 701
                 deriving (Int -> TextDetails -> ShowS
[TextDetails] -> ShowS
TextDetails -> String
(Int -> TextDetails -> ShowS)
-> (TextDetails -> String)
-> ([TextDetails] -> ShowS)
-> Show TextDetails
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TextDetails] -> ShowS
$cshowList :: [TextDetails] -> ShowS
show :: TextDetails -> String
$cshow :: TextDetails -> String
showsPrec :: Int -> TextDetails -> ShowS
$cshowsPrec :: Int -> TextDetails -> ShowS
External instance of the constraint type forall a. Show a => Show [a]
External instance of the constraint type forall a. Show a => Show [a]
External instance of the constraint type Show Char
External instance of the constraint type Show Char
External instance of the constraint type Show Char
External instance of the constraint type Ord Int
External instance of the constraint type Ord Int
Show, TextDetails -> TextDetails -> Bool
(TextDetails -> TextDetails -> Bool)
-> (TextDetails -> TextDetails -> Bool) -> Eq TextDetails
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TextDetails -> TextDetails -> Bool
$c/= :: TextDetails -> TextDetails -> Bool
== :: TextDetails -> TextDetails -> Bool
$c== :: TextDetails -> TextDetails -> Bool
External instance of the constraint type forall a. Eq a => Eq [a]
External instance of the constraint type forall a. Eq a => Eq [a]
External instance of the constraint type Eq Char
External instance of the constraint type Eq Char
External instance of the constraint type Eq Char
Eq, (forall x. TextDetails -> Rep TextDetails x)
-> (forall x. Rep TextDetails x -> TextDetails)
-> Generic TextDetails
forall x. Rep TextDetails x -> TextDetails
forall x. TextDetails -> Rep TextDetails x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TextDetails x -> TextDetails
$cfrom :: forall x. TextDetails -> Rep TextDetails x
Generic)
#endif

-- Combining @Doc@ values
#if __GLASGOW_HASKELL__ >= 800
instance Semi.Semigroup (Doc a) where
#ifndef TESTING
    <> :: Doc a -> Doc a -> Doc a
(<>) = Doc a -> Doc a -> Doc a
forall a. Doc a -> Doc a -> Doc a
(Text.PrettyPrint.Annotated.HughesPJ.<>)
#else
    (<>) = (PrettyTestVersion.<>)
#endif

instance Monoid (Doc a) where
    mempty :: Doc a
mempty  = Doc a
forall a. Doc a
empty
    mappend :: Doc a -> Doc a -> Doc a
mappend = Doc a -> Doc a -> Doc a
forall a. Semigroup a => a -> a -> a
Instance of class: Semigroup of the constraint type forall a. Semigroup (Doc a)
(Semi.<>)
#else
instance Monoid (Doc a) where
    mempty  = empty
    mappend = (<>)
#endif

instance IsString (Doc a) where
    fromString :: String -> Doc a
fromString = String -> Doc a
forall a. String -> Doc a
text

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

instance Eq (Doc a) where
  == :: Doc a -> Doc a -> Bool
(==) = String -> String -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type forall a. Eq a => Eq [a]
External instance of the constraint type Eq Char
(==) (String -> String -> Bool)
-> (Doc a -> String) -> Doc a -> Doc a -> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Doc a -> String
forall a. Doc a -> String
render

instance Functor Doc where
  fmap :: (a -> b) -> Doc a -> Doc b
fmap a -> b
_ Doc a
Empty               = Doc b
forall a. Doc a
Empty
  fmap a -> b
f (NilAbove Doc a
d)        = Doc b -> Doc b
forall a. Doc a -> Doc a
NilAbove ((a -> b) -> Doc a -> Doc b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Instance of class: Functor of the constraint type Functor Doc
fmap a -> b
f Doc a
d)
  fmap a -> b
f (TextBeside AnnotDetails a
td Doc a
d)   = AnnotDetails b -> Doc b -> Doc b
forall a. AnnotDetails a -> Doc a -> Doc a
TextBeside ((a -> b) -> AnnotDetails a -> AnnotDetails b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Instance of class: Functor of the constraint type Functor AnnotDetails
fmap a -> b
f AnnotDetails a
td) ((a -> b) -> Doc a -> Doc b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Instance of class: Functor of the constraint type Functor Doc
fmap a -> b
f Doc a
d)
  fmap a -> b
f (Nest Int
k Doc a
d)          = Int -> Doc b -> Doc b
forall a. Int -> Doc a -> Doc a
Nest Int
k ((a -> b) -> Doc a -> Doc b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Instance of class: Functor of the constraint type Functor Doc
fmap a -> b
f Doc a
d)
  fmap a -> b
f (Union Doc a
ur Doc a
ul)       = Doc b -> Doc b -> Doc b
forall a. Doc a -> Doc a -> Doc a
Union ((a -> b) -> Doc a -> Doc b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Instance of class: Functor of the constraint type Functor Doc
fmap a -> b
f Doc a
ur) ((a -> b) -> Doc a -> Doc b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Instance of class: Functor of the constraint type Functor Doc
fmap a -> b
f Doc a
ul)
  fmap a -> b
_ Doc a
NoDoc               = Doc b
forall a. Doc a
NoDoc
  fmap a -> b
f (Beside Doc a
ld Bool
s Doc a
rd)    = Doc b -> Bool -> Doc b -> Doc b
forall a. Doc a -> Bool -> Doc a -> Doc a
Beside ((a -> b) -> Doc a -> Doc b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Instance of class: Functor of the constraint type Functor Doc
fmap a -> b
f Doc a
ld) Bool
s ((a -> b) -> Doc a -> Doc b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Instance of class: Functor of the constraint type Functor Doc
fmap a -> b
f Doc a
rd)
  fmap a -> b
f (Above Doc a
ud Bool
s Doc a
ld)     = Doc b -> Bool -> Doc b -> Doc b
forall a. Doc a -> Bool -> Doc a -> Doc a
Above ((a -> b) -> Doc a -> Doc b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Instance of class: Functor of the constraint type Functor Doc
fmap a -> b
f Doc a
ud) Bool
s ((a -> b) -> Doc a -> Doc b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
Instance of class: Functor of the constraint type Functor Doc
fmap a -> b
f Doc a
ld)

instance NFData a => NFData (Doc a) where
  rnf :: Doc a -> ()
rnf Doc a
Empty               = ()
  rnf (NilAbove Doc a
d)        = Doc a -> ()
forall a. NFData a => a -> ()
Instance of class: NFData of the constraint type forall a. NFData a => NFData (Doc a)
Evidence bound by a type signature of the constraint type NFData a
rnf Doc a
d
  rnf (TextBeside AnnotDetails a
td Doc a
d)   = AnnotDetails a -> ()
forall a. NFData a => a -> ()
Instance of class: NFData of the constraint type forall a. NFData a => NFData (AnnotDetails a)
Evidence bound by a type signature of the constraint type NFData a
rnf AnnotDetails a
td () -> () -> ()
`seq` Doc a -> ()
forall a. NFData a => a -> ()
Instance of class: NFData of the constraint type forall a. NFData a => NFData (Doc a)
Evidence bound by a type signature of the constraint type NFData a
rnf Doc a
d
  rnf (Nest Int
k Doc a
d)          = Int -> ()
forall a. NFData a => a -> ()
External instance of the constraint type NFData Int
rnf Int
k  () -> () -> ()
`seq` Doc a -> ()
forall a. NFData a => a -> ()
Instance of class: NFData of the constraint type forall a. NFData a => NFData (Doc a)
Evidence bound by a type signature of the constraint type NFData a
rnf Doc a
d
  rnf (Union Doc a
ur Doc a
ul)       = Doc a -> ()
forall a. NFData a => a -> ()
Instance of class: NFData of the constraint type forall a. NFData a => NFData (Doc a)
Evidence bound by a type signature of the constraint type NFData a
rnf Doc a
ur () -> () -> ()
`seq` Doc a -> ()
forall a. NFData a => a -> ()
Instance of class: NFData of the constraint type forall a. NFData a => NFData (Doc a)
Evidence bound by a type signature of the constraint type NFData a
rnf Doc a
ul
  rnf Doc a
NoDoc               = ()
  rnf (Beside Doc a
ld Bool
s Doc a
rd)    = Doc a -> ()
forall a. NFData a => a -> ()
Instance of class: NFData of the constraint type forall a. NFData a => NFData (Doc a)
Evidence bound by a type signature of the constraint type NFData a
rnf Doc a
ld () -> () -> ()
`seq` Bool -> ()
forall a. NFData a => a -> ()
External instance of the constraint type NFData Bool
rnf Bool
s () -> () -> ()
`seq` Doc a -> ()
forall a. NFData a => a -> ()
Instance of class: NFData of the constraint type forall a. NFData a => NFData (Doc a)
Evidence bound by a type signature of the constraint type NFData a
rnf Doc a
rd
  rnf (Above Doc a
ud Bool
s Doc a
ld)     = Doc a -> ()
forall a. NFData a => a -> ()
Instance of class: NFData of the constraint type forall a. NFData a => NFData (Doc a)
Evidence bound by a type signature of the constraint type NFData a
rnf Doc a
ud () -> () -> ()
`seq` Bool -> ()
forall a. NFData a => a -> ()
External instance of the constraint type NFData Bool
rnf Bool
s () -> () -> ()
`seq` Doc a -> ()
forall a. NFData a => a -> ()
Instance of class: NFData of the constraint type forall a. NFData a => NFData (Doc a)
Evidence bound by a type signature of the constraint type NFData a
rnf Doc a
ld

instance NFData a => NFData (AnnotDetails a) where
  rnf :: AnnotDetails a -> ()
rnf AnnotDetails a
AnnotStart     = ()
  rnf (NoAnnot TextDetails
d Int
sl) = TextDetails -> ()
forall a. NFData a => a -> ()
Instance of class: NFData of the constraint type NFData TextDetails
rnf TextDetails
d () -> () -> ()
`seq` Int -> ()
forall a. NFData a => a -> ()
External instance of the constraint type NFData Int
rnf Int
sl
  rnf (AnnotEnd a
a)   = a -> ()
forall a. NFData a => a -> ()
Evidence bound by a type signature of the constraint type NFData a
rnf a
a

instance NFData TextDetails where
  rnf :: TextDetails -> ()
rnf (Chr Char
c)    = Char -> ()
forall a. NFData a => a -> ()
External instance of the constraint type NFData Char
rnf Char
c
  rnf (Str String
str)  = String -> ()
forall a. NFData a => a -> ()
External instance of the constraint type forall a. NFData a => NFData [a]
External instance of the constraint type NFData Char
rnf String
str
  rnf (PStr String
str) = String -> ()
forall a. NFData a => a -> ()
External instance of the constraint type forall a. NFData a => NFData [a]
External instance of the constraint type NFData Char
rnf String
str

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

-- | Attach an annotation to a document.
annotate :: a -> Doc a -> Doc a
annotate :: a -> Doc a -> Doc a
annotate a
a Doc a
d = AnnotDetails a -> Doc a -> Doc a
forall a. AnnotDetails a -> Doc a -> Doc a
TextBeside AnnotDetails a
forall a. AnnotDetails a
AnnotStart
             (Doc a -> Doc a) -> Doc a -> Doc a
forall a b. (a -> b) -> a -> b
$ Doc a -> Bool -> Doc a -> Doc a
forall a. Doc a -> Bool -> Doc a -> Doc a
beside (Doc a -> Doc a
forall a. Doc a -> Doc a
reduceDoc Doc a
d) Bool
False
             (Doc a -> Doc a) -> Doc a -> Doc a
forall a b. (a -> b) -> a -> b
$ AnnotDetails a -> Doc a -> Doc a
forall a. AnnotDetails a -> Doc a -> Doc a
TextBeside (a -> AnnotDetails a
forall a. a -> AnnotDetails a
AnnotEnd a
a) Doc a
forall a. Doc a
Empty


-- | A document of height and width 1, containing a literal character.
char :: Char -> Doc a
char :: Char -> Doc a
char Char
c = AnnotDetails a -> Doc a -> Doc a
forall a. AnnotDetails a -> Doc a -> Doc a
textBeside_ (TextDetails -> Int -> AnnotDetails a
forall a. TextDetails -> Int -> AnnotDetails a
NoAnnot (Char -> TextDetails
Chr Char
c) Int
1) Doc a
forall a. Doc a
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 a
text :: String -> Doc a
text String
s = case String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
External instance of the constraint type Foldable []
length String
s of {Int
sl -> AnnotDetails a -> Doc a -> Doc a
forall a. AnnotDetails a -> Doc a -> Doc a
textBeside_ (TextDetails -> Int -> AnnotDetails a
forall a. TextDetails -> Int -> AnnotDetails a
NoAnnot (String -> TextDetails
Str String
s) Int
sl) Doc a
forall a. Doc a
Empty}

-- | Same as @text@. Used to be used for Bytestrings.
ptext :: String -> Doc a
ptext :: String -> Doc a
ptext String
s = case String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
External instance of the constraint type Foldable []
length String
s of {Int
sl -> AnnotDetails a -> Doc a -> Doc a
forall a. AnnotDetails a -> Doc a -> Doc a
textBeside_ (TextDetails -> Int -> AnnotDetails a
forall a. TextDetails -> Int -> AnnotDetails a
NoAnnot (String -> TextDetails
PStr String
s) Int
sl) Doc a
forall a. Doc a
Empty}

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

-- | Some text, but without any width. Use for non-printing text
-- such as a HTML or Latex tags
zeroWidthText :: String -> Doc a
zeroWidthText :: String -> Doc a
zeroWidthText = Int -> String -> Doc a
forall a. Int -> String -> Doc a
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 a
empty :: Doc a
empty = Doc a
forall a. Doc a
Empty

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

-- | Produce spacing for indenting the amount specified.
--
-- an old version inserted tabs being 8 columns apart in the output.
indent :: Int -> String
indent :: Int -> String
indent !Int
n = Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' '

{-
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 -- ^ A ';' character
comma  :: Doc a -- ^ A ',' character
colon  :: Doc a -- ^ A ':' character
space  :: Doc a -- ^ A space character
equals :: Doc a -- ^ A '=' character
lparen :: Doc a -- ^ A '(' character
rparen :: Doc a -- ^ A ')' character
lbrack :: Doc a -- ^ A '[' character
rbrack :: Doc a -- ^ A ']' character
lbrace :: Doc a -- ^ A '{' character
rbrace :: Doc a -- ^ A '}' character
semi :: Doc a
semi   = Char -> Doc a
forall a. Char -> Doc a
char Char
';'
comma :: Doc a
comma  = Char -> Doc a
forall a. Char -> Doc a
char Char
','
colon :: Doc a
colon  = Char -> Doc a
forall a. Char -> Doc a
char Char
':'
space :: Doc a
space  = Char -> Doc a
forall a. Char -> Doc a
char Char
' '
equals :: Doc a
equals = Char -> Doc a
forall a. Char -> Doc a
char Char
'='
lparen :: Doc a
lparen = Char -> Doc a
forall a. Char -> Doc a
char Char
'('
rparen :: Doc a
rparen = Char -> Doc a
forall a. Char -> Doc a
char Char
')'
lbrack :: Doc a
lbrack = Char -> Doc a
forall a. Char -> Doc a
char Char
'['
rbrack :: Doc a
rbrack = Char -> Doc a
forall a. Char -> Doc a
char Char
']'
lbrace :: Doc a
lbrace = Char -> Doc a
forall a. Char -> Doc a
char Char
'{'
rbrace :: Doc a
rbrace = Char -> Doc a
forall a. Char -> Doc a
char Char
'}'

spaceText, nlText :: AnnotDetails a
spaceText :: AnnotDetails a
spaceText = TextDetails -> Int -> AnnotDetails a
forall a. TextDetails -> Int -> AnnotDetails a
NoAnnot (Char -> TextDetails
Chr Char
' ') Int
1
nlText :: AnnotDetails a
nlText    = TextDetails -> Int -> AnnotDetails a
forall a. TextDetails -> Int -> AnnotDetails a
NoAnnot (Char -> TextDetails
Chr Char
'\n') Int
1

int      :: Int      -> Doc a -- ^ @int n = text (show n)@
integer  :: Integer  -> Doc a -- ^ @integer n = text (show n)@
float    :: Float    -> Doc a -- ^ @float n = text (show n)@
double   :: Double   -> Doc a -- ^ @double n = text (show n)@
rational :: Rational -> Doc a -- ^ @rational n = text (show n)@
int :: Int -> Doc a
int      Int
n = String -> Doc a
forall a. String -> Doc a
text (Int -> String
forall a. Show a => a -> String
External instance of the constraint type Show Int
show Int
n)
integer :: Integer -> Doc a
integer  Integer
n = String -> Doc a
forall a. String -> Doc a
text (Integer -> String
forall a. Show a => a -> String
External instance of the constraint type Show Integer
show Integer
n)
float :: Float -> Doc a
float    Float
n = String -> Doc a
forall a. String -> Doc a
text (Float -> String
forall a. Show a => a -> String
External instance of the constraint type Show Float
show Float
n)
double :: Double -> Doc a
double   Double
n = String -> Doc a
forall a. String -> Doc a
text (Double -> String
forall a. Show a => a -> String
External instance of the constraint type Show Double
show Double
n)
rational :: Rational -> Doc a
rational Rational
n = String -> Doc a
forall a. String -> Doc a
text (Rational -> String
forall a. Show a => a -> String
External instance of the constraint type forall a. Show a => Show (Ratio a)
External instance of the constraint type Show Integer
show Rational
n)

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

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

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

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

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

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

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

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

-- | List version of '<>'.
hcat :: [Doc a] -> Doc a
hcat :: [Doc a] -> Doc a
hcat = (IsEmpty, Doc a) -> Doc a
forall a b. (a, b) -> b
snd ((IsEmpty, Doc a) -> Doc a)
-> ([Doc a] -> (IsEmpty, Doc a)) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc a -> (IsEmpty, Doc a)
forall a. Doc a -> (IsEmpty, Doc a)
reduceHoriz (Doc a -> (IsEmpty, Doc a))
-> ([Doc a] -> Doc a) -> [Doc a] -> (IsEmpty, Doc a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc a -> Doc a -> Doc a) -> Doc a -> [Doc a] -> Doc a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
External instance of the constraint type Foldable []
foldr (\Doc a
p Doc a
q -> Doc a -> Bool -> Doc a -> Doc a
forall a. Doc a -> Bool -> Doc a -> Doc a
Beside Doc a
p Bool
False Doc a
q) Doc a
forall a. Doc a
empty

-- | List version of '<+>'.
hsep :: [Doc a] -> Doc a
hsep :: [Doc a] -> Doc a
hsep = (IsEmpty, Doc a) -> Doc a
forall a b. (a, b) -> b
snd ((IsEmpty, Doc a) -> Doc a)
-> ([Doc a] -> (IsEmpty, Doc a)) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc a -> (IsEmpty, Doc a)
forall a. Doc a -> (IsEmpty, Doc a)
reduceHoriz (Doc a -> (IsEmpty, Doc a))
-> ([Doc a] -> Doc a) -> [Doc a] -> (IsEmpty, Doc a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc a -> Doc a -> Doc a) -> Doc a -> [Doc a] -> Doc a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
External instance of the constraint type Foldable []
foldr (\Doc a
p Doc a
q -> Doc a -> Bool -> Doc a -> Doc a
forall a. Doc a -> Bool -> Doc a -> Doc a
Beside Doc a
p Bool
True Doc a
q)  Doc a
forall a. Doc a
empty

-- | List version of '$$'.
vcat :: [Doc a] -> Doc a
vcat :: [Doc a] -> Doc a
vcat = (IsEmpty, Doc a) -> Doc a
forall a b. (a, b) -> b
snd ((IsEmpty, Doc a) -> Doc a)
-> ([Doc a] -> (IsEmpty, Doc a)) -> [Doc a] -> Doc a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc a -> (IsEmpty, Doc a)
forall a. Doc a -> (IsEmpty, Doc a)
reduceVert (Doc a -> (IsEmpty, Doc a))
-> ([Doc a] -> Doc a) -> [Doc a] -> (IsEmpty, Doc a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc a -> Doc a -> Doc a) -> Doc a -> [Doc a] -> Doc a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
External instance of the constraint type Foldable []
foldr (\Doc a
p Doc a
q -> Doc a -> Bool -> Doc a -> Doc a
forall a. Doc a -> Bool -> Doc a -> Doc a
Above Doc a
p Bool
False Doc a
q) Doc a
forall a. Doc a
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 a -> Doc a
nest :: Int -> Doc a -> Doc a
nest Int
k Doc a
p = Int -> Doc a -> Doc a
forall a. Int -> Doc a -> Doc a
mkNest Int
k (Doc a -> Doc a
forall a. Doc a -> Doc a
reduceDoc Doc a
p)

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

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

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

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

data IsEmpty = IsEmpty | NotEmpty

reduceHoriz :: Doc a -> (IsEmpty, Doc a)
reduceHoriz :: Doc a -> (IsEmpty, Doc a)
reduceHoriz (Beside Doc a
p Bool
g Doc a
q) = (Doc a -> Bool -> Doc a -> Doc a)
-> Doc a -> Bool -> (IsEmpty, Doc a) -> (IsEmpty, Doc a)
forall a.
(Doc a -> Bool -> Doc a -> Doc a)
-> Doc a -> Bool -> (IsEmpty, Doc a) -> (IsEmpty, Doc a)
eliminateEmpty Doc a -> Bool -> Doc a -> Doc a
forall a. Doc a -> Bool -> Doc a -> Doc a
Beside ((IsEmpty, Doc a) -> Doc a
forall a b. (a, b) -> b
snd (Doc a -> (IsEmpty, Doc a)
forall a. Doc a -> (IsEmpty, Doc a)
reduceHoriz Doc a
p)) Bool
g (Doc a -> (IsEmpty, Doc a)
forall a. Doc a -> (IsEmpty, Doc a)
reduceHoriz Doc a
q)
reduceHoriz Doc a
doc            = (IsEmpty
NotEmpty, Doc a
doc)

reduceVert :: Doc a -> (IsEmpty, Doc a)
reduceVert :: Doc a -> (IsEmpty, Doc a)
reduceVert (Above  Doc a
p Bool
g Doc a
q) = (Doc a -> Bool -> Doc a -> Doc a)
-> Doc a -> Bool -> (IsEmpty, Doc a) -> (IsEmpty, Doc a)
forall a.
(Doc a -> Bool -> Doc a -> Doc a)
-> Doc a -> Bool -> (IsEmpty, Doc a) -> (IsEmpty, Doc a)
eliminateEmpty Doc a -> Bool -> Doc a -> Doc a
forall a. Doc a -> Bool -> Doc a -> Doc a
Above  ((IsEmpty, Doc a) -> Doc a
forall a b. (a, b) -> b
snd (Doc a -> (IsEmpty, Doc a)
forall a. Doc a -> (IsEmpty, Doc a)
reduceVert Doc a
p)) Bool
g (Doc a -> (IsEmpty, Doc a)
forall a. Doc a -> (IsEmpty, Doc a)
reduceVert Doc a
q)
reduceVert Doc a
doc            = (IsEmpty
NotEmpty, Doc a
doc)

{-# INLINE eliminateEmpty #-}
eliminateEmpty ::
  (Doc a -> Bool -> Doc a -> Doc a) ->
  Doc a -> Bool -> (IsEmpty, Doc a) -> (IsEmpty, Doc a)
eliminateEmpty :: (Doc a -> Bool -> Doc a -> Doc a)
-> Doc a -> Bool -> (IsEmpty, Doc a) -> (IsEmpty, Doc a)
eliminateEmpty Doc a -> Bool -> Doc a -> Doc a
_    Doc a
Empty Bool
_ (IsEmpty, Doc a)
q          = (IsEmpty, Doc a)
q
eliminateEmpty Doc a -> Bool -> Doc a -> Doc a
cons Doc a
p     Bool
g (IsEmpty, Doc a)
q          =
  (IsEmpty
NotEmpty,
   -- We're not empty whether or not q is empty, so for laziness-sake,
   -- after checking that p isn't empty, we put the NotEmpty result
   -- outside independent of q. This allows reduceAB to immediately
   -- return the appropriate constructor (Above or Beside) without
   -- forcing the entire nested Doc. This allows the foldr in vcat,
   -- hsep, and hcat to be lazy on its second argument, avoiding a
   -- stack overflow.
   case (IsEmpty, Doc a)
q of
     (IsEmpty
NotEmpty, Doc a
q') -> Doc a -> Bool -> Doc a -> Doc a
cons Doc a
p Bool
g Doc a
q'
     (IsEmpty
IsEmpty, Doc a
_) -> Doc a
p)

nilAbove_ :: RDoc a -> RDoc a
nilAbove_ :: RDoc a -> RDoc a
nilAbove_ = RDoc a -> RDoc a
forall a. Doc a -> Doc a
NilAbove

-- | Arg of a TextBeside is always an RDoc.
textBeside_ :: AnnotDetails a -> RDoc a -> RDoc a
textBeside_ :: AnnotDetails a -> RDoc a -> RDoc a
textBeside_  = AnnotDetails a -> RDoc a -> RDoc a
forall a. AnnotDetails a -> Doc a -> Doc a
TextBeside

nest_ :: Int -> RDoc a -> RDoc a
nest_ :: Int -> RDoc a -> RDoc a
nest_ = Int -> RDoc a -> RDoc a
forall a. Int -> Doc a -> Doc a
Nest

union_ :: RDoc a -> RDoc a -> RDoc a
union_ :: RDoc a -> RDoc a -> RDoc a
union_ = RDoc a -> RDoc a -> RDoc a
forall a. Doc a -> Doc a -> Doc a
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 a -> Doc a -> Doc a
Doc a
p $$ :: Doc a -> Doc a -> Doc a
$$  Doc a
q = Doc a -> Bool -> Doc a -> Doc a
forall a. Doc a -> Bool -> Doc a -> Doc a
above_ Doc a
p Bool
False Doc a
q

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

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

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

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

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

aboveNest (NilAbove RDoc a
p)        Bool
g Int
k RDoc a
q = RDoc a -> RDoc a
forall a. Doc a -> Doc a
nilAbove_ (RDoc a -> Bool -> Int -> RDoc a -> RDoc a
forall a. RDoc a -> Bool -> Int -> RDoc a -> RDoc a
aboveNest RDoc a
p Bool
g Int
k RDoc a
q)
aboveNest (TextBeside AnnotDetails a
s RDoc a
p)    Bool
g Int
k RDoc a
q = AnnotDetails a -> RDoc a -> RDoc a
forall a. AnnotDetails a -> Doc a -> Doc a
TextBeside AnnotDetails a
s RDoc a
rest
                                    where
                                      !k1 :: Int
k1  = Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
- AnnotDetails a -> Int
forall a. AnnotDetails a -> Int
annotSize AnnotDetails a
s
                                      rest :: RDoc a
rest = case RDoc a
p of
                                                RDoc a
Empty -> Bool -> Int -> RDoc a -> RDoc a
forall a. Bool -> Int -> RDoc a -> RDoc a
nilAboveNest Bool
g Int
k1 RDoc a
q
                                                RDoc a
_     -> RDoc a -> Bool -> Int -> RDoc a -> RDoc a
forall a. RDoc a -> Bool -> Int -> RDoc a -> RDoc a
aboveNest  RDoc a
p Bool
g Int
k1 RDoc a
q

aboveNest (Above {})          Bool
_ Int
_ RDoc a
_ = String -> RDoc a
forall a. HasCallStack => String -> a
error String
"aboveNest Above"
aboveNest (Beside {})         Bool
_ Int
_ RDoc a
_ = String -> RDoc a
forall a. HasCallStack => String -> a
error String
"aboveNest Beside"

-- Specification: text s <> nilaboveNest g k q
--              = text s <> (text "" $g$ nest k q)
nilAboveNest :: Bool -> Int -> RDoc a -> RDoc a
nilAboveNest :: Bool -> Int -> RDoc a -> RDoc a
nilAboveNest Bool
_ Int
k RDoc a
_           | Int
k Int -> Bool -> Bool
`seq` Bool
False = RDoc a
forall a. HasCallStack => a
undefined
nilAboveNest Bool
_ Int
_ RDoc a
Empty       = RDoc a
forall a. Doc a
Empty
                               -- Here's why the "text s <>" is in the spec!
nilAboveNest Bool
g Int
k (Nest Int
k1 RDoc a
q) = Bool -> Int -> RDoc a -> RDoc a
forall a. Bool -> Int -> RDoc a -> RDoc a
nilAboveNest Bool
g (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
+ Int
k1) RDoc a
q
nilAboveNest Bool
g Int
k RDoc a
q           | Bool -> Bool
not Bool
g Bool -> Bool -> Bool
&& Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
External instance of the constraint type Ord Int
> Int
0      -- No newline if no overlap
                             = AnnotDetails a -> RDoc a -> RDoc a
forall a. AnnotDetails a -> Doc a -> Doc a
textBeside_ (TextDetails -> Int -> AnnotDetails a
forall a. TextDetails -> Int -> AnnotDetails a
NoAnnot (String -> TextDetails
Str (Int -> String
indent Int
k)) Int
k) RDoc a
q
                             | Bool
otherwise           -- Put them really above
                             = RDoc a -> RDoc a
forall a. Doc a -> Doc a
nilAbove_ (Int -> RDoc a -> RDoc a
forall a. Int -> Doc a -> Doc a
mkNest Int
k RDoc a
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 a -> Doc a -> Doc a
Doc a
p <> :: Doc a -> Doc a -> Doc a
<>  Doc a
q = Doc a -> Bool -> Doc a -> Doc a
forall a. Doc a -> Bool -> Doc a -> Doc a
beside_ Doc a
p Bool
False Doc a
q

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

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

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

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


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

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

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

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

sepX :: Bool -> [Doc a] -> Doc a
sepX :: Bool -> [Doc a] -> Doc a
sepX Bool
_ []     = Doc a
forall a. Doc a
empty
sepX Bool
x (Doc a
p:[Doc a]
ps) = Bool -> Doc a -> Int -> [Doc a] -> Doc a
forall a. Bool -> RDoc a -> Int -> [RDoc a] -> RDoc a
sep1 Bool
x (Doc a -> Doc a
forall a. Doc a -> Doc a
reduceDoc Doc a
p) Int
0 [Doc a]
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 a -> Int -> [Doc a] -> RDoc a
sep1 :: Bool -> RDoc a -> Int -> [RDoc a] -> RDoc a
sep1 Bool
_ RDoc a
_                   Int
k [RDoc a]
_  | Int
k Int -> Bool -> Bool
`seq` Bool
False = RDoc a
forall a. HasCallStack => a
undefined
sep1 Bool
_ RDoc a
NoDoc               Int
_ [RDoc a]
_  = RDoc a
forall a. Doc a
NoDoc
sep1 Bool
g (RDoc a
p `Union` RDoc a
q)       Int
k [RDoc a]
ys = Bool -> RDoc a -> Int -> [RDoc a] -> RDoc a
forall a. Bool -> RDoc a -> Int -> [RDoc a] -> RDoc a
sep1 Bool
g RDoc a
p Int
k [RDoc a]
ys RDoc a -> RDoc a -> RDoc a
forall a. Doc a -> Doc a -> Doc a
`union_`
                                  RDoc a -> Bool -> Int -> RDoc a -> RDoc a
forall a. RDoc a -> Bool -> Int -> RDoc a -> RDoc a
aboveNest RDoc a
q Bool
False Int
k (RDoc a -> RDoc a
forall a. Doc a -> Doc a
reduceDoc ([RDoc a] -> RDoc a
forall a. [Doc a] -> Doc a
vcat [RDoc a]
ys))

sep1 Bool
g RDoc a
Empty               Int
k [RDoc a]
ys = Int -> RDoc a -> RDoc a
forall a. Int -> Doc a -> Doc a
mkNest Int
k (Bool -> [RDoc a] -> RDoc a
forall a. Bool -> [Doc a] -> Doc a
sepX Bool
g [RDoc a]
ys)
sep1 Bool
g (Nest Int
n RDoc a
p)          Int
k [RDoc a]
ys = Int -> RDoc a -> RDoc a
forall a. Int -> Doc a -> Doc a
nest_ Int
n (Bool -> RDoc a -> Int -> [RDoc a] -> RDoc a
forall a. Bool -> RDoc a -> Int -> [RDoc a] -> RDoc a
sep1 Bool
g RDoc a
p (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
- Int
n) [RDoc a]
ys)

sep1 Bool
_ (NilAbove RDoc a
p)        Int
k [RDoc a]
ys = RDoc a -> RDoc a
forall a. Doc a -> Doc a
nilAbove_
                                  (RDoc a -> Bool -> Int -> RDoc a -> RDoc a
forall a. RDoc a -> Bool -> Int -> RDoc a -> RDoc a
aboveNest RDoc a
p Bool
False Int
k (RDoc a -> RDoc a
forall a. Doc a -> Doc a
reduceDoc ([RDoc a] -> RDoc a
forall a. [Doc a] -> Doc a
vcat [RDoc a]
ys)))
sep1 Bool
g (TextBeside AnnotDetails a
s RDoc a
p) Int
k [RDoc a]
ys    = AnnotDetails a -> RDoc a -> RDoc a
forall a. AnnotDetails a -> Doc a -> Doc a
textBeside_ AnnotDetails a
s (Bool -> RDoc a -> Int -> [RDoc a] -> RDoc a
forall a. Bool -> RDoc a -> Int -> [RDoc a] -> RDoc a
sepNB Bool
g RDoc a
p (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
- AnnotDetails a -> Int
forall a. AnnotDetails a -> Int
annotSize AnnotDetails a
s) [RDoc a]
ys)
sep1 Bool
_ (Above {})          Int
_ [RDoc a]
_  = String -> RDoc a
forall a. HasCallStack => String -> a
error String
"sep1 Above"
sep1 Bool
_ (Beside {})         Int
_ [RDoc a]
_  = String -> RDoc a
forall a. HasCallStack => 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 a -> Int -> [Doc a] -> Doc a
sepNB :: Bool -> Doc a -> Int -> [Doc a] -> Doc a
sepNB Bool
g (Nest Int
_ Doc a
p) Int
k [Doc a]
ys
  = Bool -> Doc a -> Int -> [Doc a] -> Doc a
forall a. Bool -> RDoc a -> Int -> [RDoc a] -> RDoc a
sepNB Bool
g Doc a
p Int
k [Doc a]
ys -- Never triggered, because of invariant (2)
sepNB Bool
g Doc a
Empty Int
k [Doc a]
ys
  = Doc a -> Doc a
forall a. Doc a -> Doc a
oneLiner (Bool -> Doc a -> Doc a
forall a. Bool -> RDoc a -> RDoc a
nilBeside Bool
g (Doc a -> Doc a
forall a. Doc a -> Doc a
reduceDoc Doc a
rest)) Doc a -> Doc a -> Doc a
forall a. Doc a -> Doc a -> Doc a
`mkUnion`
    -- XXX: TODO: PRETTY: Used to use True here (but GHC used False...)
    Bool -> Int -> Doc a -> Doc a
forall a. Bool -> Int -> RDoc a -> RDoc a
nilAboveNest Bool
False Int
k (Doc a -> Doc a
forall a. Doc a -> Doc a
reduceDoc ([Doc a] -> Doc a
forall a. [Doc a] -> Doc a
vcat [Doc a]
ys))
  where
    rest :: Doc a
rest | Bool
g         = [Doc a] -> Doc a
forall a. [Doc a] -> Doc a
hsep [Doc a]
ys
         | Bool
otherwise = [Doc a] -> Doc a
forall a. [Doc a] -> Doc a
hcat [Doc a]
ys
sepNB Bool
g Doc a
p Int
k [Doc a]
ys
  = Bool -> Doc a -> Int -> [Doc a] -> Doc a
forall a. Bool -> RDoc a -> Int -> [RDoc a] -> RDoc a
sep1 Bool
g Doc a
p Int
k [Doc a]
ys


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

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

-- | \"Paragraph fill\" version of 'sep'.
fsep :: [Doc a] -> Doc a
fsep :: [Doc a] -> Doc a
fsep = Bool -> [Doc a] -> Doc a
forall a. Bool -> [Doc a] -> Doc a
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 a] -> RDoc a
fill :: Bool -> [Doc a] -> Doc a
fill Bool
_ []     = Doc a
forall a. Doc a
empty
fill Bool
g (Doc a
p:[Doc a]
ps) = Bool -> Doc a -> Int -> [Doc a] -> Doc a
forall a. Bool -> RDoc a -> Int -> [RDoc a] -> RDoc a
fill1 Bool
g (Doc a -> Doc a
forall a. Doc a -> Doc a
reduceDoc Doc a
p) Int
0 [Doc a]
ps

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

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


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

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


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

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

    get1 :: Int -> Int -> Doc a -> Doc a
get1 Int
w Int
_ Doc a
_ | Int
w Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
External instance of the constraint type Eq Int
== Int
0 Bool -> Bool -> Bool
&& Bool
False  = Doc a
forall a. HasCallStack => a
undefined
    get1 Int
_ Int
_  Doc a
Empty               = Doc a
forall a. Doc a
Empty
    get1 Int
_ Int
_  Doc a
NoDoc               = Doc a
forall a. Doc a
NoDoc
    get1 Int
w Int
sl (NilAbove Doc a
p)        = Doc a -> Doc a
forall a. Doc a -> Doc a
nilAbove_ (Int -> Doc a -> Doc a
get (Int
w Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
- Int
sl) Doc a
p)
    get1 Int
w Int
sl (TextBeside AnnotDetails a
s Doc a
p)    = AnnotDetails a -> Doc a -> Doc a
forall a. AnnotDetails a -> Doc a -> Doc a
textBeside_ AnnotDetails a
s (Int -> Int -> Doc a -> Doc a
get1 Int
w (Int
sl Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
+ AnnotDetails a -> Int
forall a. AnnotDetails a -> Int
annotSize AnnotDetails a
s) Doc a
p)
    get1 Int
w Int
sl (Nest Int
_ Doc a
p)          = Int -> Int -> Doc a -> Doc a
get1 Int
w Int
sl Doc a
p
    get1 Int
w Int
sl (Doc a
p `Union` Doc a
q)       = Int -> Int -> Int -> Doc a -> Doc a -> Doc a
forall a. Int -> Int -> Int -> Doc a -> Doc a -> Doc a
nicest1 Int
w Int
r Int
sl (Int -> Int -> Doc a -> Doc a
get1 Int
w Int
sl Doc a
p)
                                                   (Int -> Int -> Doc a -> Doc a
get1 Int
w Int
sl Doc a
q)
    get1 Int
_ Int
_  (Above {})          = String -> Doc a
forall a. HasCallStack => String -> a
error String
"best get1 Above"
    get1 Int
_ Int
_  (Beside {})         = String -> Doc a
forall a. HasCallStack => String -> a
error String
"best get1 Beside"

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

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

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

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

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

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


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

-- | A rendering style. Allows us to specify constraints to choose among the
-- many different rendering options.
data Style
  = Style { Style -> Mode
mode           :: Mode
            -- ^ The rendering mode.
          , Style -> Int
lineLength     :: Int
            -- ^ Maximum length of a line, in characters.
          , Style -> Float
ribbonsPerLine :: Float
            -- ^ Ratio of line length to ribbon length. A ribbon refers to the
            -- characters on a line /excluding/ indentation. So a 'lineLength'
            -- of 100, with a 'ribbonsPerLine' of @2.0@ would only allow up to
            -- 50 characters of ribbon to be displayed on a line, while
            -- allowing it to be indented up to 50 characters.
          }
#if __GLASGOW_HASKELL__ >= 701
  deriving (Int -> Style -> ShowS
[Style] -> ShowS
Style -> String
(Int -> Style -> ShowS)
-> (Style -> String) -> ([Style] -> ShowS) -> Show Style
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Style] -> ShowS
$cshowList :: [Style] -> ShowS
show :: Style -> String
$cshow :: Style -> String
showsPrec :: Int -> Style -> ShowS
$cshowsPrec :: Int -> Style -> ShowS
External instance of the constraint type Show Float
External instance of the constraint type Show Int
External instance of the constraint type Ord Int
Instance of class: Show of the constraint type Show Mode
Show, Style -> Style -> Bool
(Style -> Style -> Bool) -> (Style -> Style -> Bool) -> Eq Style
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Style -> Style -> Bool
$c/= :: Style -> Style -> Bool
== :: Style -> Style -> Bool
$c== :: Style -> Style -> Bool
External instance of the constraint type Eq Float
External instance of the constraint type Eq Int
Instance of class: Eq of the constraint type Eq Mode
Eq, (forall x. Style -> Rep Style x)
-> (forall x. Rep Style x -> Style) -> Generic Style
forall x. Rep Style x -> Style
forall x. Style -> Rep Style x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Style x -> Style
$cfrom :: forall x. Style -> Rep Style x
Generic)
#endif

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

-- | Rendering mode.
data Mode = PageMode    
            -- ^ Normal rendering ('lineLength' and 'ribbonsPerLine'
            -- respected').
          | ZigZagMode  
            -- ^ With zig-zag cuts.
          | LeftMode    
            -- ^ No indentation, infinitely long lines ('lineLength' ignored),
            -- but explicit new lines, i.e., @text "one" $$ text "two"@, are
            -- respected.
          | OneLineMode 
            -- ^ All on one line, 'lineLength' ignored and explicit new lines
            -- (@$$@) are turned into spaces.
#if __GLASGOW_HASKELL__ >= 701
          deriving (Int -> Mode -> ShowS
[Mode] -> ShowS
Mode -> String
(Int -> Mode -> ShowS)
-> (Mode -> String) -> ([Mode] -> ShowS) -> Show Mode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Mode] -> ShowS
$cshowList :: [Mode] -> ShowS
show :: Mode -> String
$cshow :: Mode -> String
showsPrec :: Int -> Mode -> ShowS
$cshowsPrec :: Int -> Mode -> ShowS
Show, Mode -> Mode -> Bool
(Mode -> Mode -> Bool) -> (Mode -> Mode -> Bool) -> Eq Mode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Mode -> Mode -> Bool
$c/= :: Mode -> Mode -> Bool
== :: Mode -> Mode -> Bool
$c== :: Mode -> Mode -> Bool
Eq, (forall x. Mode -> Rep Mode x)
-> (forall x. Rep Mode x -> Mode) -> Generic Mode
forall x. Rep Mode x -> Mode
forall x. Mode -> Rep Mode x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Mode x -> Mode
$cfrom :: forall x. Mode -> Rep Mode x
Generic)
#endif

-- | Render the @Doc@ to a String using the default @Style@ (see 'style').
render :: Doc a -> String
render :: Doc a -> String
render = Mode
-> Int
-> Float
-> (TextDetails -> ShowS)
-> String
-> Doc a
-> String
forall a b.
Mode -> Int -> Float -> (TextDetails -> a -> a) -> a -> Doc b -> a
fullRender (Style -> Mode
mode Style
style) (Style -> Int
lineLength Style
style) (Style -> Float
ribbonsPerLine Style
style)
                    TextDetails -> ShowS
txtPrinter String
""

-- | Render the @Doc@ to a String using the given @Style@.
renderStyle :: Style -> Doc a -> String
renderStyle :: Style -> Doc a -> String
renderStyle Style
s = Mode
-> Int
-> Float
-> (TextDetails -> ShowS)
-> String
-> Doc a
-> String
forall a b.
Mode -> Int -> Float -> (TextDetails -> a -> a) -> a -> Doc b -> 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
cChar -> ShowS
forall a. a -> [a] -> [a]
:String
s
txtPrinter (Str String
s1)  String
s2 = String
s1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s2
txtPrinter (PStr String
s1) String
s2 = String
s1 String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
s2

-- | The general rendering interface. Please refer to the @Style@ and @Mode@
-- types for a description of rendering mode, line length and ribbons.
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 b                   -- ^ The document.
           -> a                       -- ^ Result.
fullRender :: Mode -> Int -> Float -> (TextDetails -> a -> a) -> a -> Doc b -> a
fullRender Mode
m Int
l Float
r TextDetails -> a -> a
txt = Mode
-> Int -> Float -> (AnnotDetails b -> a -> a) -> a -> Doc b -> a
forall b a.
Mode
-> Int -> Float -> (AnnotDetails b -> a -> a) -> a -> Doc b -> a
fullRenderAnn Mode
m Int
l Float
r AnnotDetails b -> a -> a
forall {a}. AnnotDetails a -> a -> a
annTxt
  where
  annTxt :: AnnotDetails a -> a -> a
annTxt (NoAnnot TextDetails
s Int
_) = TextDetails -> a -> a
txt TextDetails
s
  annTxt AnnotDetails a
_             = a -> a
forall a. a -> a
id

-- | The general rendering interface, supporting annotations. Please refer to
-- the @Style@ and @Mode@ types for a description of rendering mode, line
-- length and ribbons.
fullRenderAnn :: Mode                       -- ^ Rendering mode.
              -> Int                        -- ^ Line length.
              -> Float                      -- ^ Ribbons per line.
              -> (AnnotDetails b -> a -> a) -- ^ What to do with text.
              -> a                          -- ^ What to do at the end.
              -> Doc b                      -- ^ The document.
              -> a                          -- ^ Result.
fullRenderAnn :: Mode
-> Int -> Float -> (AnnotDetails b -> a -> a) -> a -> Doc b -> a
fullRenderAnn Mode
OneLineMode Int
_ Float
_ AnnotDetails b -> a -> a
txt a
end Doc b
doc
  = AnnotDetails b
-> (Doc b -> Doc b -> Doc b)
-> (AnnotDetails b -> a -> a)
-> a
-> Doc b
-> a
forall b a.
AnnotDetails b
-> (Doc b -> Doc b -> Doc b)
-> (AnnotDetails b -> a -> a)
-> a
-> Doc b
-> a
easyDisplay AnnotDetails b
forall a. AnnotDetails a
spaceText (\Doc b
_ Doc b
y -> Doc b
y) AnnotDetails b -> a -> a
txt a
end (Doc b -> Doc b
forall a. Doc a -> Doc a
reduceDoc Doc b
doc)
fullRenderAnn Mode
LeftMode    Int
_ Float
_ AnnotDetails b -> a -> a
txt a
end Doc b
doc
  = AnnotDetails b
-> (Doc b -> Doc b -> Doc b)
-> (AnnotDetails b -> a -> a)
-> a
-> Doc b
-> a
forall b a.
AnnotDetails b
-> (Doc b -> Doc b -> Doc b)
-> (AnnotDetails b -> a -> a)
-> a
-> Doc b
-> a
easyDisplay AnnotDetails b
forall a. AnnotDetails a
nlText Doc b -> Doc b -> Doc b
forall a. Doc a -> Doc a -> Doc a
first AnnotDetails b -> a -> a
txt a
end (Doc b -> Doc b
forall a. Doc a -> Doc a
reduceDoc Doc b
doc)

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

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

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

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

                               |  Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
External instance of the constraint type Ord Int
< Int
0
                               -> AnnotDetails b
forall a. AnnotDetails a
nlText AnnotDetails b -> a -> a
`txt` (
                                  TextDetails -> Int -> AnnotDetails b
forall a. TextDetails -> Int -> AnnotDetails a
NoAnnot (String -> TextDetails
Str (Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
shift Char
'\\')) Int
shift AnnotDetails b -> a -> a
`txt` (
                                  AnnotDetails b
forall a. AnnotDetails a
nlText AnnotDetails b -> a -> a
`txt`
                                  Int -> AnnotDetails b -> Doc b -> a
lay1 (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
+ Int
shift) AnnotDetails b
s Doc b
p ))

                    Mode
_ -> Int -> AnnotDetails b -> Doc b -> a
lay1 Int
k AnnotDetails b
s Doc b
p

        lay Int
_ (Above {})   = String -> a
forall a. HasCallStack => String -> a
error String
"display lay Above"
        lay Int
_ (Beside {})  = String -> a
forall a. HasCallStack => String -> a
error String
"display lay Beside"
        lay Int
_ Doc b
NoDoc        = String -> a
forall a. HasCallStack => String -> a
error String
"display lay NoDoc"
        lay Int
_ (Union {})   = String -> a
forall a. HasCallStack => String -> a
error String
"display lay Union"

        lay1 :: Int -> AnnotDetails b -> Doc b -> a
lay1 !Int
k AnnotDetails b
s Doc b
p        = let !r :: Int
r = Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
+ AnnotDetails b -> Int
forall a. AnnotDetails a -> Int
annotSize AnnotDetails b
s
                             in TextDetails -> Int -> AnnotDetails b
forall a. TextDetails -> Int -> AnnotDetails a
NoAnnot (String -> TextDetails
Str (Int -> String
indent Int
k)) Int
k AnnotDetails b -> a -> a
`txt` (AnnotDetails b
s AnnotDetails b -> a -> a
`txt` Int -> Doc b -> a
lay2 Int
r Doc b
p)

        lay2 :: Int -> Doc b -> a
lay2 Int
k Doc b
_ | Int
k Int -> Bool -> Bool
`seq` Bool
False   = a
forall a. HasCallStack => a
undefined
        lay2 Int
k (NilAbove Doc b
p)        = AnnotDetails b
forall a. AnnotDetails a
nlText AnnotDetails b -> a -> a
`txt` Int -> Doc b -> a
lay Int
k Doc b
p
        lay2 Int
k (TextBeside AnnotDetails b
s Doc b
p)    = AnnotDetails b
s AnnotDetails b -> a -> a
`txt` Int -> Doc b -> a
lay2 (Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
+ AnnotDetails b -> Int
forall a. AnnotDetails a -> Int
annotSize AnnotDetails b
s) Doc b
p
        lay2 Int
k (Nest Int
_ Doc b
p)          = Int -> Doc b -> a
lay2 Int
k Doc b
p
        lay2 Int
_ Doc b
Empty               = a
end
        lay2 Int
_ (Above {})          = String -> a
forall a. HasCallStack => String -> a
error String
"display lay2 Above"
        lay2 Int
_ (Beside {})         = String -> a
forall a. HasCallStack => String -> a
error String
"display lay2 Beside"
        lay2 Int
_ Doc b
NoDoc               = String -> a
forall a. HasCallStack => String -> a
error String
"display lay2 NoDoc"
        lay2 Int
_ (Union {})          = String -> a
forall a. HasCallStack => String -> a
error String
"display lay2 Union"
    in
    Int -> Doc b -> a
lay Int
0 Doc b
doc
    }}



-- Rendering Annotations -------------------------------------------------------

-- | A @Span@ represents the result of an annotation after a @Doc@ has been
-- rendered, capturing where the annotation now starts and ends in the rendered
-- output.
data Span a = Span { Span a -> Int
spanStart      :: !Int
                   , Span a -> Int
spanLength     :: !Int
                   , Span a -> a
spanAnnotation :: a
                   } deriving (Int -> Span a -> ShowS
[Span a] -> ShowS
Span a -> String
(Int -> Span a -> ShowS)
-> (Span a -> String) -> ([Span a] -> ShowS) -> Show (Span a)
forall a. Show a => Int -> Span a -> ShowS
forall a. Show a => [Span a] -> ShowS
forall a. Show a => Span a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Span a] -> ShowS
$cshowList :: forall a. Show a => [Span a] -> ShowS
show :: Span a -> String
$cshow :: forall a. Show a => Span a -> String
showsPrec :: Int -> Span a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Span a -> ShowS
External instance of the constraint type Show Int
External instance of the constraint type Show Int
External instance of the constraint type Ord Int
Evidence bound by a type signature of the constraint type Show a
Show,Span a -> Span a -> Bool
(Span a -> Span a -> Bool)
-> (Span a -> Span a -> Bool) -> Eq (Span a)
forall a. Eq a => Span a -> Span a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Span a -> Span a -> Bool
$c/= :: forall a. Eq a => Span a -> Span a -> Bool
== :: Span a -> Span a -> Bool
$c== :: forall a. Eq a => Span a -> Span a -> Bool
External instance of the constraint type Eq Int
External instance of the constraint type Eq Int
Evidence bound by a type signature of the constraint type Eq a
Eq)

instance Functor Span where
  fmap :: (a -> b) -> Span a -> Span b
fmap a -> b
f (Span Int
x Int
y a
a) = Int -> Int -> b -> Span b
forall a. Int -> Int -> a -> Span a
Span Int
x Int
y (a -> b
f a
a)


-- State required for generating document spans.
data Spans a = Spans { Spans a -> Int
sOffset :: !Int
                       -- ^ Current offset from the end of the document.
                     , Spans a -> [Int -> Span a]
sStack  :: [Int -> Span a]
                       -- ^ Currently open spans.
                     , Spans a -> [Span a]
sSpans  :: [Span a]
                       -- ^ Collected annotation regions.
                     , Spans a -> String
sOutput :: String
                       -- ^ Collected output.
                     }

-- | Render an annotated @Doc@ to a String and list of annotations (see 'Span')
-- using the default @Style@ (see 'style').
renderSpans :: Doc ann -> (String,[Span ann])
renderSpans :: Doc ann -> (String, [Span ann])
renderSpans  = Spans ann -> (String, [Span ann])
forall {a}. Spans a -> (String, [Span a])
finalize
             (Spans ann -> (String, [Span ann]))
-> (Doc ann -> Spans ann) -> Doc ann -> (String, [Span ann])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mode
-> Int
-> Float
-> (AnnotDetails ann -> Spans ann -> Spans ann)
-> Spans ann
-> Doc ann
-> Spans ann
forall b a.
Mode
-> Int -> Float -> (AnnotDetails b -> a -> a) -> a -> Doc b -> a
fullRenderAnn (Style -> Mode
mode Style
style) (Style -> Int
lineLength Style
style) (Style -> Float
ribbonsPerLine Style
style)
                  AnnotDetails ann -> Spans ann -> Spans ann
forall {a}. AnnotDetails a -> Spans a -> Spans a
spanPrinter
                  Spans :: forall a. Int -> [Int -> Span a] -> [Span a] -> String -> Spans a
Spans { sOffset :: Int
sOffset = Int
0, sStack :: [Int -> Span ann]
sStack = [], sSpans :: [Span ann]
sSpans = [], sOutput :: String
sOutput = String
"" }
  where

  finalize :: Spans a -> (String, [Span a])
finalize (Spans Int
size [Int -> Span a]
_ [Span a]
spans String
out) = (String
out, (Span a -> Span a) -> [Span a] -> [Span a]
forall a b. (a -> b) -> [a] -> [b]
map Span a -> Span a
forall {a}. Span a -> Span a
adjust [Span a]
spans)
    where
    adjust :: Span a -> Span a
adjust Span a
s = Span a
s { spanStart :: Int
spanStart = Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
- Span a -> Int
forall a. Span a -> Int
spanStart Span a
s }

  mkSpan :: a -> Int -> Int -> Span a
mkSpan a
a Int
end Int
start = Span :: forall a. Int -> Int -> a -> Span a
Span { spanStart :: Int
spanStart      = Int
start
                            , spanLength :: Int
spanLength     = Int
start Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
- Int
end
                              -- this seems wrong, but remember that it's
                              -- working backwards at this point
                            , spanAnnotation :: a
spanAnnotation = a
a }

  -- the document gets generated in reverse, which is why the starting
  -- annotation ends the annotation.
  spanPrinter :: AnnotDetails a -> Spans a -> Spans a
spanPrinter AnnotDetails a
AnnotStart Spans a
s =
    case Spans a -> [Int -> Span a]
forall a. Spans a -> [Int -> Span a]
sStack Spans a
s of
      Int -> Span a
sp : [Int -> Span a]
rest -> Spans a
s { sSpans :: [Span a]
sSpans = Int -> Span a
sp (Spans a -> Int
forall a. Spans a -> Int
sOffset Spans a
s) Span a -> [Span a] -> [Span a]
forall a. a -> [a] -> [a]
: Spans a -> [Span a]
forall a. Spans a -> [Span a]
sSpans Spans a
s, sStack :: [Int -> Span a]
sStack = [Int -> Span a]
rest }
      [Int -> Span a]
_         -> String -> Spans a
forall a. HasCallStack => String -> a
error String
"renderSpans: stack underflow"

  spanPrinter (AnnotEnd a
a) Spans a
s =
    Spans a
s { sStack :: [Int -> Span a]
sStack = a -> Int -> Int -> Span a
forall {a}. a -> Int -> Int -> Span a
mkSpan a
a (Spans a -> Int
forall a. Spans a -> Int
sOffset Spans a
s) (Int -> Span a) -> [Int -> Span a] -> [Int -> Span a]
forall a. a -> [a] -> [a]
: Spans a -> [Int -> Span a]
forall a. Spans a -> [Int -> Span a]
sStack Spans a
s }

  spanPrinter (NoAnnot TextDetails
td Int
l) Spans a
s =
    case TextDetails
td of
      Chr  Char
c -> Spans a
s { sOutput :: String
sOutput = Char
c  Char -> ShowS
forall a. a -> [a] -> [a]
: Spans a -> String
forall a. Spans a -> String
sOutput Spans a
s, sOffset :: Int
sOffset = Spans a -> Int
forall a. Spans a -> Int
sOffset Spans a
s Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
+ Int
l }
      Str  String
t -> Spans a
s { sOutput :: String
sOutput = String
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ Spans a -> String
forall a. Spans a -> String
sOutput Spans a
s, sOffset :: Int
sOffset = Spans a -> Int
forall a. Spans a -> Int
sOffset Spans a
s Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
+ Int
l }
      PStr String
t -> Spans a
s { sOutput :: String
sOutput = String
t String -> ShowS
forall a. [a] -> [a] -> [a]
++ Spans a -> String
forall a. Spans a -> String
sOutput Spans a
s, sOffset :: Int
sOffset = Spans a -> Int
forall a. Spans a -> Int
sOffset Spans a
s Int -> Int -> Int
forall a. Num a => a -> a -> a
External instance of the constraint type Num Int
+ Int
l }


-- | Render out a String, interpreting the annotations as part of the resulting
-- document.
--
-- /IMPORTANT/: the size of the annotation string does NOT figure into the
-- layout of the document, so the document will lay out as though the
-- annotations are not present.
renderDecorated :: (ann -> String) -- ^ Starting an annotation.
                -> (ann -> String) -- ^ Ending an annotation.
                -> Doc ann -> String
renderDecorated :: (ann -> String) -> (ann -> String) -> Doc ann -> String
renderDecorated ann -> String
startAnn ann -> String
endAnn =
  (String, [ann]) -> String
forall {a} {b}. (a, b) -> a
finalize ((String, [ann]) -> String)
-> (Doc ann -> (String, [ann])) -> Doc ann -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mode
-> Int
-> Float
-> (AnnotDetails ann -> (String, [ann]) -> (String, [ann]))
-> (String, [ann])
-> Doc ann
-> (String, [ann])
forall b a.
Mode
-> Int -> Float -> (AnnotDetails b -> a -> a) -> a -> Doc b -> a
fullRenderAnn (Style -> Mode
mode Style
style) (Style -> Int
lineLength Style
style) (Style -> Float
ribbonsPerLine Style
style)
                 AnnotDetails ann -> (String, [ann]) -> (String, [ann])
annPrinter
                 (String
"", [])
  where
  annPrinter :: AnnotDetails ann -> (String, [ann]) -> (String, [ann])
annPrinter AnnotDetails ann
AnnotStart (String
rest,[ann]
stack) =
    case [ann]
stack of
      ann
a : [ann]
as -> (ann -> String
startAnn ann
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
rest, [ann]
as)
      [ann]
_      -> String -> (String, [ann])
forall a. HasCallStack => String -> a
error String
"renderDecorated: stack underflow"

  annPrinter (AnnotEnd ann
a) (String
rest,[ann]
stack) =
    (ann -> String
endAnn ann
a String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
rest, ann
a ann -> [ann] -> [ann]
forall a. a -> [a] -> [a]
: [ann]
stack)

  annPrinter (NoAnnot TextDetails
s Int
_) (String
rest,[ann]
stack) =
    (TextDetails -> ShowS
txtPrinter TextDetails
s String
rest, [ann]
stack)

  finalize :: (a, b) -> a
finalize (a
str,b
_) = a
str


-- | Render a document with annotations, by interpreting the start and end of
-- the annotations, as well as the text details in the context of a monad.
renderDecoratedM :: Monad m
                 => (ann    -> m r) -- ^ Starting an annotation.
                 -> (ann    -> m r) -- ^ Ending an annotation.
                 -> (String -> m r) -- ^ Text formatting.
                 -> m r             -- ^ Document end.
                 -> Doc ann -> m r
renderDecoratedM :: (ann -> m r)
-> (ann -> m r) -> (String -> m r) -> m r -> Doc ann -> m r
renderDecoratedM ann -> m r
startAnn ann -> m r
endAnn String -> m r
txt m r
docEnd =
  (m r, [ann]) -> m r
forall {a} {b}. (a, b) -> a
finalize ((m r, [ann]) -> m r)
-> (Doc ann -> (m r, [ann])) -> Doc ann -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mode
-> Int
-> Float
-> (AnnotDetails ann -> (m r, [ann]) -> (m r, [ann]))
-> (m r, [ann])
-> Doc ann
-> (m r, [ann])
forall b a.
Mode
-> Int -> Float -> (AnnotDetails b -> a -> a) -> a -> Doc b -> a
fullRenderAnn (Style -> Mode
mode Style
style) (Style -> Int
lineLength Style
style) (Style -> Float
ribbonsPerLine Style
style)
                 AnnotDetails ann -> (m r, [ann]) -> (m r, [ann])
forall {b}. AnnotDetails ann -> (m b, [ann]) -> (m b, [ann])
annPrinter
                 (m r
docEnd, [])
  where
  annPrinter :: AnnotDetails ann -> (m b, [ann]) -> (m b, [ann])
annPrinter AnnotDetails ann
AnnotStart (m b
rest,[ann]
stack) =
    case [ann]
stack of
      ann
a : [ann]
as -> (ann -> m r
startAnn ann
a m r -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
Evidence bound by a type signature of the constraint type Monad m
>> m b
rest, [ann]
as)
      [ann]
_      -> String -> (m b, [ann])
forall a. HasCallStack => String -> a
error String
"renderDecorated: stack underflow"

  annPrinter (AnnotEnd ann
a) (m b
rest,[ann]
stack) =
    (ann -> m r
endAnn ann
a m r -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
Evidence bound by a type signature of the constraint type Monad m
>> m b
rest, ann
a ann -> [ann] -> [ann]
forall a. a -> [a] -> [a]
: [ann]
stack)

  annPrinter (NoAnnot TextDetails
td Int
_) (m b
rest,[ann]
stack) =
    case TextDetails
td of
      Chr  Char
c -> (String -> m r
txt [Char
c] m r -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
Evidence bound by a type signature of the constraint type Monad m
>> m b
rest, [ann]
stack)
      Str  String
s -> (String -> m r
txt String
s   m r -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
Evidence bound by a type signature of the constraint type Monad m
>> m b
rest, [ann]
stack)
      PStr String
s -> (String -> m r
txt String
s   m r -> m b -> m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
Evidence bound by a type signature of the constraint type Monad m
>> m b
rest, [ann]
stack)

  finalize :: (a, b) -> a
finalize (a
m,b
_) = a
m