{-# 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
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
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
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
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
(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
(==) (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
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
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
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
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
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
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
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
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
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
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 -> ()
rnf Doc a
d
  rnf (TextBeside AnnotDetails a
td Doc a
d)   = AnnotDetails a -> ()
forall a. NFData a => a -> ()
rnf AnnotDetails a
td () -> () -> ()
`seq` Doc a -> ()
forall a. NFData a => a -> ()
rnf Doc a
d
  rnf (Nest Int
k Doc a
d)          = Int -> ()
forall a. NFData a => a -> ()
rnf Int
k  () -> () -> ()
`seq` Doc a -> ()
forall a. NFData a => a -> ()
rnf Doc a
d
  rnf (Union Doc a
ur Doc a
ul)       = Doc a -> ()
forall a. NFData a => a -> ()
rnf Doc a
ur () -> () -> ()
`seq` Doc a -> ()
forall a. NFData a => 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 -> ()
rnf Doc a
ld () -> () -> ()
`seq` Bool -> ()
forall a. NFData a => a -> ()
rnf Bool
s () -> () -> ()
`seq` Doc a -> ()
forall a. NFData a => a -> ()
rnf Doc a
rd
  rnf (Above Doc a
ud Bool
s Doc a
ld)     = Doc a -> ()
forall a. NFData a => a -> ()
rnf Doc a
ud () -> () -> ()
`seq` Bool -> ()
forall a. NFData a => a -> ()
rnf Bool
s () -> () -> ()
`seq` Doc a -> ()
forall a. NFData a => 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 -> ()
rnf TextDetails
d () -> () -> ()
`seq` Int -> ()
forall a. NFData a => a -> ()
rnf Int
sl
  rnf (AnnotEnd a
a)   = a -> ()
forall a. NFData a => a -> ()
rnf a
a

instance NFData TextDetails where
  rnf :: TextDetails -> ()
rnf (Chr Char
c)    = Char -> ()
forall a. NFData a => a -> ()
rnf Char
c
  rnf (Str String
str)  = String -> ()
forall a. NFData a => a -> ()
rnf String
str
  rnf (PStr String
str) = String -> ()
forall a. NFData a => a -> ()
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
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
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
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
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
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
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
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
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
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
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
+ 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
- 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
- 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
+ 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
> 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
== 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
- 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
- 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
- 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
- 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
- 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
== 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
- 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
== 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
- 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
+ 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
`min` Int
r) Int -> Int -> Int
forall a. Num a => a -> a -> a
- 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
< 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
- 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
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
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
round (Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lineLen Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/ Float
ribbons)
    bestLineLen :: Int
bestLineLen = case Mode
m of
                      Mode
ZigZagMode -> Int
forall a. Bounded a => a
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
- Int
ribbon_width of { Int
gap_width ->
    case Int
gap_width Int -> Int -> Int
forall a. Integral a => a -> a -> a
`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
+ 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
>= 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
- Int
shift) AnnotDetails b
s Doc b
p ))

                               |  Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 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
+ 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
+ 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
+ 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
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
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
- 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
- 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
+ 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
+ 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
+ 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
>> 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
>> 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
>> 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
>> 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
>> m b
rest, [ann]
stack)

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