{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE CPP                 #-}
{-# LANGUAGE DefaultSignatures   #-}
{-# LANGUAGE DeriveDataTypeable  #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

#include "version-compatibility-macros.h"

-- | __Warning: internal module!__ This means that the API may change
-- arbitrarily between versions without notice. Depending on this module may
-- lead to unexpected breakages, so proceed with caution!
--
-- For a stable API, use the non-internal modules. For the special case of
-- writing adaptors to this library’s @'Doc'@ type, see
-- "Data.Text.Prettyprint.Doc.Internal.Type".
module Data.Text.Prettyprint.Doc.Internal (
    module Data.Text.Prettyprint.Doc.Internal
) where



import           Control.Applicative
import           Data.Int
import           Data.List.NonEmpty  (NonEmpty (..))
import           Data.Maybe
import           Data.String         (IsString (..))
import           Data.Text           (Text)
import qualified Data.Text           as T
import qualified Data.Text.Lazy      as Lazy
import           Data.Typeable       (Typeable)
import           Data.Void
import           Data.Word
import           GHC.Generics        (Generic)

-- Depending on the Cabal file, this might be from base, or for older builds,
-- from the semigroups package.
import Data.Semigroup

#if NATURAL_IN_BASE
import Numeric.Natural
#endif

#if !(FOLDABLE_TRAVERSABLE_IN_PRELUDE)
import Data.Foldable    (Foldable (..))
import Data.Traversable (Traversable (..))
import Prelude          hiding (foldr, foldr1)
#endif

#if !(MONOID_IN_PRELUDE)
import Data.Monoid hiding ((<>))
#endif

#if FUNCTOR_IDENTITY_IN_BASE
import Data.Functor.Identity
#endif

import Data.Text.Prettyprint.Doc.Render.Util.Panic



-- | The abstract data type @'Doc' ann@ represents pretty documents that have
-- been annotated with data of type @ann@.
--
-- More specifically, a value of type @'Doc'@ represents a non-empty set of
-- possible layouts of a document. The layout functions select one of these
-- possibilities, taking into account things like the width of the output
-- document.
--
-- The annotation is an arbitrary piece of data associated with (part of) a
-- document. Annotations may be used by the rendering backends in order to
-- display output differently, such as
--
--   - color information (e.g. when rendering to the terminal)
--   - mouseover text (e.g. when rendering to rich HTML)
--   - whether to show something or not (to allow simple or detailed versions)
--
-- The simplest way to display a 'Doc' is via the 'Show' class.
--
-- >>> putStrLn (show (vsep ["hello", "world"]))
-- hello
-- world
data Doc ann =

    -- | Occurs when flattening a line. The layouter will reject this document,
    -- choosing a more suitable rendering.
    Fail

    -- | The empty document; conceptually the unit of 'Cat'
    | Empty

    -- | invariant: not '\n'
    | Char !Char

    -- | Invariants: at least two characters long, does not contain '\n'. For
    -- empty documents, there is @Empty@; for singleton documents, there is
    -- @Char@; newlines should be replaced by e.g. @Line@.
    --
    -- Since the frequently used 'T.length' of 'Text' is /O(length)/, we cache
    -- it in this constructor.
    | Text !Int !Text

    -- | Hard line break
    | Line

    -- | Lay out the first 'Doc', but when flattened (via 'group'), fall back to
    -- the second. The flattened version should in general be higher and
    -- narrower than the fallback.
    | FlatAlt (Doc ann) (Doc ann)

    -- | Concatenation of two documents
    | Cat (Doc ann) (Doc ann)

    -- | Document indented by a number of columns
    | Nest !Int (Doc ann)

    -- | Invariant: The first lines of first document should be longer than the
    -- first lines of the second one, so the layout algorithm can pick the one
    -- that fits best. Used to implement layout alternatives for 'group'.
    | Union (Doc ann) (Doc ann)

    -- | React on the current cursor position, see 'column'
    | Column (Int -> Doc ann)

    -- | React on the document's width, see 'pageWidth'
    | WithPageWidth (PageWidth -> Doc ann)

    -- | React on the current nesting level, see 'nesting'
    | Nesting (Int -> Doc ann)

    -- | Add an annotation to the enclosed 'Doc'. Can be used for example to add
    -- styling directives or alt texts that can then be used by the renderer.
    | Annotated ann (Doc ann)
    deriving (Generic, Typeable)

-- |
-- @
-- x '<>' y = 'hcat' [x, y]
-- @
--
-- >>> "hello" <> "world" :: Doc ann
-- helloworld
instance Semigroup (Doc ann) where
    (<>) = Cat
    sconcat (x :| xs) = hcat (x:xs)

-- |
-- @
-- 'mempty' = 'emptyDoc'
-- 'mconcat' = 'hcat'
-- @
--
-- >>> mappend "hello" "world" :: Doc ann
-- helloworld
instance Monoid (Doc ann) where
    mempty = emptyDoc
    mappend = (<>)
    mconcat = hcat

-- | >>> pretty ("hello\nworld")
-- hello
-- world
--
-- This instance uses the 'Pretty' 'Text' instance, and uses the same newline to
-- 'line' conversion.
instance IsString (Doc ann) where
    fromString = pretty . T.pack

-- | Alter the document’s annotations.
--
-- This instance makes 'Doc' more flexible (because it can be used in
-- 'Functor'-polymorphic values), but @'fmap'@ is much less readable compared to
-- using @'reAnnotate'@ in code that only works for @'Doc'@ anyway. Consider
-- using the latter when the type does not matter.
instance Functor Doc where
    fmap = reAnnotate

-- | Overloaded conversion to 'Doc'.
--
-- Laws:
--
--   1. output should be pretty. :-)
class Pretty a where

    -- | >>> pretty 1 <+> pretty "hello" <+> pretty 1.234
    -- 1 hello 1.234
    pretty :: a -> Doc ann

    default pretty :: Show a => a -> Doc ann
    pretty = viaShow

    -- | @'prettyList'@ is only used to define the @instance
    -- 'Pretty' a => 'Pretty' [a]@. In normal circumstances only the @'pretty'@
    -- function is used.
    --
    -- >>> prettyList [1, 23, 456]
    -- [1, 23, 456]
    prettyList :: [a] -> Doc ann
    prettyList = align . list . map pretty

    {-# MINIMAL pretty #-}

-- $
-- Issue #67: Nested lists were not aligned with »pretty«, leading to non-pretty
-- output, violating the Pretty class law.
--
-- >>> pretty (replicate 2 (replicate 4 (1, replicate 8 2)))
-- [ [ (1, [2, 2, 2, 2, 2, 2, 2, 2])
--   , (1, [2, 2, 2, 2, 2, 2, 2, 2])
--   , (1, [2, 2, 2, 2, 2, 2, 2, 2])
--   , (1, [2, 2, 2, 2, 2, 2, 2, 2]) ]
-- , [ (1, [2, 2, 2, 2, 2, 2, 2, 2])
--   , (1, [2, 2, 2, 2, 2, 2, 2, 2])
--   , (1, [2, 2, 2, 2, 2, 2, 2, 2])
--   , (1, [2, 2, 2, 2, 2, 2, 2, 2]) ] ]

instance Pretty a => Pretty (Const a b) where
  pretty = pretty . getConst

#if FUNCTOR_IDENTITY_IN_BASE
-- | >>> pretty (Identity 1)
-- 1
instance Pretty a => Pretty (Identity a) where
  pretty = pretty . runIdentity
#endif

-- | >>> pretty [1,2,3]
-- [1, 2, 3]
instance Pretty a => Pretty [a] where
    pretty = prettyList

instance Pretty a => Pretty (NonEmpty a) where
    pretty (x:|xs) = prettyList (x:xs)

-- | >>> pretty ()
-- ()
--
-- The argument is not used,
--
-- >>> pretty (error "Strict?" :: ())
-- ()
instance Pretty () where
    pretty _ = "()"

-- | >>> pretty True
-- True
instance Pretty Bool where
    pretty True  = "True"
    pretty False = "False"

-- | Instead of @('pretty' '\n')@, consider using @'line'@ as a more readable
-- alternative.
--
-- >>> pretty 'f' <> pretty 'o' <> pretty 'o'
-- foo
-- >>> pretty ("string" :: String)
-- string
instance Pretty Char where
    pretty '\n' = line
    pretty c = Char c

    prettyList = pretty . (id :: Text -> Text) . fromString

-- | Convenience function to convert a 'Show'able value to a 'Doc'. If the
-- 'String' does not contain newlines, consider using the more performant
-- 'unsafeViaShow'.
viaShow :: Show a => a -> Doc ann
viaShow = pretty . T.pack . show

-- | Convenience function to convert a 'Show'able value /that must not contain
-- newlines/ to a 'Doc'. If there may be newlines, use 'viaShow' instead.
unsafeViaShow :: Show a => a -> Doc ann
unsafeViaShow = unsafeTextWithoutNewlines . T.pack . show

-- | >>> pretty (123 :: Int)
-- 123
instance Pretty Int    where pretty = unsafeViaShow
instance Pretty Int8   where pretty = unsafeViaShow
instance Pretty Int16  where pretty = unsafeViaShow
instance Pretty Int32  where pretty = unsafeViaShow
instance Pretty Int64  where pretty = unsafeViaShow
instance Pretty Word   where pretty = unsafeViaShow
instance Pretty Word8  where pretty = unsafeViaShow
instance Pretty Word16 where pretty = unsafeViaShow
instance Pretty Word32 where pretty = unsafeViaShow
instance Pretty Word64 where pretty = unsafeViaShow

-- | >>> pretty (2^123 :: Integer)
-- 10633823966279326983230456482242756608
instance Pretty Integer where pretty = unsafeViaShow

#if NATURAL_IN_BASE
instance Pretty Natural where pretty = unsafeViaShow
#endif

-- | >>> pretty (pi :: Float)
-- 3.1415927
instance Pretty Float where pretty = unsafeViaShow

-- | >>> pretty (exp 1 :: Double)
-- 2.71828182845904...
instance Pretty Double where pretty = unsafeViaShow

-- | >>> pretty (123, "hello")
-- (123, hello)
instance (Pretty a1, Pretty a2) => Pretty (a1,a2) where
    pretty (x1,x2) = tupled [pretty x1, pretty x2]

-- | >>> pretty (123, "hello", False)
-- (123, hello, False)
instance (Pretty a1, Pretty a2, Pretty a3) => Pretty (a1,a2,a3) where
    pretty (x1,x2,x3) = tupled [pretty x1, pretty x2, pretty x3]

--    -- | >>> pretty (123, "hello", False, ())
--    -- (123, hello, False, ())
--    instance (Pretty a1, Pretty a2, Pretty a3, Pretty a4) => Pretty (a1,a2,a3,a4) where
--        pretty (x1,x2,x3,x4) = tupled [pretty x1, pretty x2, pretty x3, pretty x4]
--
--    -- | >>> pretty (123, "hello", False, (), 3.14)
--    -- (123, hello, False, (), 3.14)
--    instance (Pretty a1, Pretty a2, Pretty a3, Pretty a4, Pretty a5) => Pretty (a1,a2,a3,a4,a5) where
--        pretty (x1,x2,x3,x4,x5) = tupled [pretty x1, pretty x2, pretty x3, pretty x4, pretty x5]
--
--    -- | >>> pretty (123, "hello", False, (), 3.14, Just 2.71)
--    -- ( 123
--    -- , hello
--    -- , False
--    -- , ()
--    -- , 3.14
--    -- , 2.71 )
--    instance (Pretty a1, Pretty a2, Pretty a3, Pretty a4, Pretty a5, Pretty a6) => Pretty (a1,a2,a3,a4,a5,a6) where
--        pretty (x1,x2,x3,x4,x5,x6) = tupled [pretty x1, pretty x2, pretty x3, pretty x4, pretty x5, pretty x6]
--
--    -- | >>> pretty (123, "hello", False, (), 3.14, Just 2.71, [1,2,3])
--    -- ( 123
--    -- , hello
--    -- , False
--    -- , ()
--    -- , 3.14
--    -- , 2.71
--    -- , [1, 2, 3] )
--    instance (Pretty a1, Pretty a2, Pretty a3, Pretty a4, Pretty a5, Pretty a6, Pretty a7) => Pretty (a1,a2,a3,a4,a5,a6,a7) where
--        pretty (x1,x2,x3,x4,x5,x6,x7) = tupled [pretty x1, pretty x2, pretty x3, pretty x4, pretty x5, pretty x6, pretty x7]

-- | Ignore 'Nothing's, print 'Just' contents.
--
-- >>> pretty (Just True)
-- True
-- >>> braces (pretty (Nothing :: Maybe Bool))
-- {}
--
-- >>> pretty [Just 1, Nothing, Just 3, Nothing]
-- [1, 3]
instance Pretty a => Pretty (Maybe a) where
    pretty = maybe mempty pretty
    prettyList = prettyList . catMaybes

-- | Automatically converts all newlines to @'line'@.
--
-- >>> pretty ("hello\nworld" :: Text)
-- hello
-- world
--
-- Note that  @'line'@ can be undone by @'group'@:
--
-- >>> group (pretty ("hello\nworld" :: Text))
-- hello world
--
-- Manually use @'hardline'@ if you /definitely/ want newlines.
instance Pretty Text where pretty = vsep . map unsafeTextWithoutNewlines . T.splitOn "\n"

-- | (lazy 'Text' instance, identical to the strict version)
instance Pretty Lazy.Text where pretty = pretty . Lazy.toStrict

-- | Finding a good example for printing something that does not exist is hard,
-- so here is an example of printing a list full of nothing.
--
-- >>> pretty ([] :: [Void])
-- []
instance Pretty Void where pretty = absurd



-- | @(unsafeTextWithoutNewlines s)@ contains the literal string @s@.
--
-- The string must not contain any newline characters, since this is an
-- invariant of the 'Text' constructor.
unsafeTextWithoutNewlines :: Text -> Doc ann
unsafeTextWithoutNewlines text = case T.uncons text of
    Nothing -> Empty
    Just (t,ext)
        | T.null ext -> Char t
        | otherwise -> Text (T.length text) text

-- | The empty document behaves like @('pretty' "")@, so it has a height of 1.
-- This may lead to surprising behaviour if we expect it to bear no weight
-- inside e.g. 'vcat', where we get an empty line of output from it ('parens'
-- for visibility only):
--
-- >>> vsep ["hello", parens emptyDoc, "world"]
-- hello
-- ()
-- world
--
-- Together with '<>', 'emptyDoc' forms the 'Monoid' 'Doc'.
emptyDoc :: Doc ann
emptyDoc = Empty

-- | @('nest' i x)@ lays out the document @x@ with the current nesting level
-- (indentation of the following lines) increased by @i@. Negative values are
-- allowed, and decrease the nesting level accordingly.
--
-- >>> vsep [nest 4 (vsep ["lorem", "ipsum", "dolor"]), "sit", "amet"]
-- lorem
--     ipsum
--     dolor
-- sit
-- amet
--
-- See also
--
--   * 'hang' ('nest' relative to current cursor position instead of
--      current nesting level)
--   * 'align' (set nesting level to current cursor position)
--   * 'indent' (increase indentation on the spot, padding with spaces).
nest
    :: Int -- ^ Change of nesting level
    -> Doc ann
    -> Doc ann
nest 0 x = x -- Optimization
nest i x = Nest i x

-- | The @'line'@ document advances to the next line and indents to the current
-- nesting level.
--
-- >>> let doc = "lorem ipsum" <> line <> "dolor sit amet"
-- >>> doc
-- lorem ipsum
-- dolor sit amet
--
-- @'line'@ behaves like @'space'@ if the line break is undone by 'group':
--
-- >>> group doc
-- lorem ipsum dolor sit amet
line :: Doc ann
line = FlatAlt Line (Char ' ')

-- | @'line''@ is like @'line'@, but behaves like @'mempty'@ if the line break
-- is undone by 'group' (instead of @'space'@).
--
-- >>> let doc = "lorem ipsum" <> line' <> "dolor sit amet"
-- >>> doc
-- lorem ipsum
-- dolor sit amet
-- >>> group doc
-- lorem ipsumdolor sit amet
line' :: Doc ann
line' = FlatAlt Line mempty

-- | @softline@ behaves like @'space'@ if the resulting output fits the page,
-- otherwise like @'line'@.
--
-- Here, we have enough space to put everything in one line:
--
-- >>> let doc = "lorem ipsum" <> softline <> "dolor sit amet"
-- >>> putDocW 80 doc
-- lorem ipsum dolor sit amet
--
-- If we narrow the page to width 10, the layouter produces a line break:
--
-- >>> putDocW 10 doc
-- lorem ipsum
-- dolor sit amet
--
-- @
-- 'softline' = 'group' 'line'
-- @
softline :: Doc ann
softline = group line

-- | @'softline''@ is like @'softline'@, but behaves like @'mempty'@ if the
-- resulting output does not fit on the page (instead of @'space'@). In other
-- words, @'line'@ is to @'line''@ how @'softline'@ is to @'softline''@.
--
-- With enough space, we get direct concatenation:
--
-- >>> let doc = "ThisWord" <> softline' <> "IsWayTooLong"
-- >>> putDocW 80 doc
-- ThisWordIsWayTooLong
--
-- If we narrow the page to width 10, the layouter produces a line break:
--
-- >>> putDocW 10 doc
-- ThisWord
-- IsWayTooLong
--
-- @
-- 'softline'' = 'group' 'line''
-- @
softline' :: Doc ann
softline' = group line'

-- | A @'hardline'@ is /always/ laid out as a line break, even when 'group'ed or
-- when there is plenty of space. Note that it might still be simply discarded
-- if it is part of a 'flatAlt' inside a 'group'.
--
-- >>> let doc = "lorem ipsum" <> hardline <> "dolor sit amet"
-- >>> putDocW 1000 doc
-- lorem ipsum
-- dolor sit amet
--
-- >>> group doc
-- lorem ipsum
-- dolor sit amet
hardline :: Doc ann
hardline = Line

-- | @('group' x)@ tries laying out @x@ into a single line by removing the
-- contained line breaks; if this does not fit the page, @x@ is laid out without
-- any changes. The 'group' function is key to layouts that adapt to available
-- space nicely.
--
-- See 'vcat', 'line', or 'flatAlt' for examples that are related, or make good
-- use of it.
group :: Doc ann -> Doc ann
-- See note [Group: special flattening]
group x = case changesUponFlattening x of
    Nothing -> x
    Just x' -> Union x' x

-- Note [Group: special flattening]
--
-- Since certain documents do not change under removal of newlines etc, there is
-- no point in creating a 'Union' of the flattened and unflattened version – all
-- this does is introducing two branches for the layout algorithm to take,
-- resulting in potentially exponential behavior on deeply nested examples, such
-- as
--
--     pathological n = iterate (\x ->  hsep [x, sep []] ) "foobar" !! n
--
-- See https://github.com/quchen/prettyprinter/issues/22 for the  corresponding
-- ticket.

-- | Choose the first element of each @Union@, and discard the first field of
-- all @FlatAlt@s.
--
-- The result is 'Just' if the element might change depending on the layout
-- algorithm (i.e. contains differently renderable sub-documents), and 'Nothing'
-- if the document is static (e.g. contains only a plain 'Empty' node). See
-- [Group: special flattening] for further explanations.
changesUponFlattening :: Doc ann -> Maybe (Doc ann)
changesUponFlattening = \doc -> case doc of
    FlatAlt _ y     -> Just (flatten y)
    Line            -> Just Fail
    Union x _       -> changesUponFlattening x <|> Just x
    Nest i x        -> fmap (Nest i) (changesUponFlattening x)
    Annotated ann x -> fmap (Annotated ann) (changesUponFlattening x)

    Column f        -> Just (Column (flatten . f))
    Nesting f       -> Just (Nesting (flatten . f))
    WithPageWidth f -> Just (WithPageWidth (flatten . f))

    Cat x y -> case (changesUponFlattening x, changesUponFlattening y) of
        (Nothing, Nothing) -> Nothing
        (Just x', Nothing) -> Just (Cat x' y )
        (Nothing, Just y') -> Just (Cat x  y')
        (Just x', Just y') -> Just (Cat x' y')

    Empty  -> Nothing
    Char{} -> Nothing
    Text{} -> Nothing
    Fail   -> Nothing
  where
    -- Flatten, but don’t report whether anything changes.
    flatten :: Doc ann -> Doc ann
    flatten = \doc -> case doc of
        FlatAlt _ y     -> flatten y
        Cat x y         -> Cat (flatten x) (flatten y)
        Nest i x        -> Nest i (flatten x)
        Line            -> Fail
        Union x _       -> flatten x
        Column f        -> Column (flatten . f)
        WithPageWidth f -> WithPageWidth (flatten . f)
        Nesting f       -> Nesting (flatten . f)
        Annotated ann x -> Annotated ann (flatten x)

        x@Fail   -> x
        x@Empty  -> x
        x@Char{} -> x
        x@Text{} -> x



-- | @('flatAlt' x fallback)@ renders as @x@ by default, but falls back to
-- @fallback@ when 'group'ed. Since the layout algorithms rely on 'group' having
-- an effect of shortening the width of the contained text, careless usage of
-- 'flatAlt' with wide fallbacks might lead to unappealingly long lines.
--
-- 'flatAlt' is particularly useful for defining conditional separators such as
--
-- @
-- softHyphen = 'flatAlt' 'mempty' "-"
-- softline   = 'flatAlt' 'space' 'line'
-- @
--
-- We can use this to render Haskell's do-notation nicely:
--
-- >>> let open        = flatAlt "" "{ "
-- >>> let close       = flatAlt "" " }"
-- >>> let separator   = flatAlt "" "; "
-- >>> let prettyDo xs = group ("do" <+> align (encloseSep open close separator xs))
-- >>> let statements  = ["name:_ <- getArgs", "let greet = \"Hello, \" <> name", "putStrLn greet"]
--
-- This is put into a single line with @{;}@ style if it fits,
--
-- >>> putDocW 80 (prettyDo statements)
-- do { name:_ <- getArgs; let greet = "Hello, " <> name; putStrLn greet }
--
-- When there is not enough space the statements are broken up into lines
-- nicely,
--
-- >>> putDocW 10 (prettyDo statements)
-- do name:_ <- getArgs
--    let greet = "Hello, " <> name
--    putStrLn greet
flatAlt
    :: Doc ann -- ^ Default
    -> Doc ann -- ^ Fallback when 'group'ed
    -> Doc ann
flatAlt = FlatAlt



-- | @('align' x)@ lays out the document @x@ with the nesting level set to the
-- current column. It is used for example to implement 'hang'.
--
-- As an example, we will put a document right above another one, regardless of
-- the current nesting level. Without 'align'ment, the second line is put simply
-- below everything we've had so far,
--
-- >>> "lorem" <+> vsep ["ipsum", "dolor"]
-- lorem ipsum
-- dolor
--
-- If we add an 'align' to the mix, the @'vsep'@'s contents all start in the
-- same column,
--
-- >>> "lorem" <+> align (vsep ["ipsum", "dolor"])
-- lorem ipsum
--       dolor
align :: Doc ann -> Doc ann
align d = column (\k -> nesting (\i -> nest (k - i) d)) -- nesting might be negative!

-- | @('hang' i x)@ lays out the document @x@ with a nesting level set to the
-- /current column/ plus @i@. Negative values are allowed, and decrease the
-- nesting level accordingly.
--
-- >>> let doc = reflow "Indenting these words with hang"
-- >>> putDocW 24 ("prefix" <+> hang 4 doc)
-- prefix Indenting these
--            words with
--            hang
--
-- This differs from 'nest', which is based on the /current nesting level/ plus
-- @i@. When you're not sure, try the more efficient 'nest' first. In our
-- example, this would yield
--
-- >>> let doc = reflow "Indenting these words with nest"
-- >>> putDocW 24 ("prefix" <+> nest 4 doc)
-- prefix Indenting these
--     words with nest
--
-- @
-- 'hang' i doc = 'align' ('nest' i doc)
-- @
hang
    :: Int -- ^ Change of nesting level, relative to the start of the first line
    -> Doc ann
    -> Doc ann
hang i d = align (nest i d)

-- | @('indent' i x)@ indents document @x@ with @i@ spaces, starting from the
-- current cursor position.
--
-- >>> let doc = reflow "The indent function indents these words!"
-- >>> putDocW 24 ("prefix" <> indent 4 doc)
-- prefix    The indent
--           function
--           indents these
--           words!
--
-- @
-- 'indent' i d = 'hang' i ({i spaces} <> d)
-- @
indent
    :: Int -- ^ Number of spaces to increase indentation by
    -> Doc ann
    -> Doc ann
indent i d = hang i (spaces i <> d)

-- | @('encloseSep' l r sep xs)@ concatenates the documents @xs@ separated by
-- @sep@, and encloses the resulting document by @l@ and @r@.
--
-- The documents are laid out horizontally if that fits the page,
--
-- >>> let doc = "list" <+> align (encloseSep lbracket rbracket comma (map pretty [1,20,300,4000]))
-- >>> putDocW 80 doc
-- list [1,20,300,4000]
--
-- If there is not enough space, then the input is split into lines entry-wise
-- therwise they are laid out vertically, with separators put in the front:
--
-- >>> putDocW 10 doc
-- list [1
--      ,20
--      ,300
--      ,4000]
--
-- Note that @doc@ contains an explicit call to 'align' so that the list items
-- are aligned vertically.
--
-- For putting separators at the end of entries instead, have a look at
-- 'punctuate'.
encloseSep
    :: Doc ann   -- ^ left delimiter
    -> Doc ann   -- ^ right delimiter
    -> Doc ann   -- ^ separator
    -> [Doc ann] -- ^ input documents
    -> Doc ann
encloseSep l r s ds = case ds of
    []  -> l <> r
    [d] -> l <> d <> r
    _   -> cat (zipWith (<>) (l : repeat s) ds) <> r

-- | Haskell-inspired variant of 'encloseSep' with braces and comma as
-- separator.
--
-- >>> let doc = list (map pretty [1,20,300,4000])
--
-- >>> putDocW 80 doc
-- [1, 20, 300, 4000]
--
-- >>> putDocW 10 doc
-- [ 1
-- , 20
-- , 300
-- , 4000 ]
list :: [Doc ann] -> Doc ann
list = group . encloseSep (flatAlt "[ " "[")
                          (flatAlt " ]" "]")
                          ", "

-- | Haskell-inspired variant of 'encloseSep' with parentheses and comma as
-- separator.
--
-- >>> let doc = tupled (map pretty [1,20,300,4000])
--
-- >>> putDocW 80 doc
-- (1, 20, 300, 4000)
--
-- >>> putDocW 10 doc
-- ( 1
-- , 20
-- , 300
-- , 4000 )
tupled :: [Doc ann] -> Doc ann
tupled = group . encloseSep (flatAlt "( " "(")
                            (flatAlt " )" ")")
                            ", "



-- | @(x '<+>' y)@ concatenates document @x@ and @y@ with a @'space'@ in
-- between.
--
-- >>> "hello" <+> "world"
-- hello world
--
-- @
-- x '<+>' y = x '<>' 'space' '<>' y
-- @
(<+>) :: Doc ann -> Doc ann -> Doc ann
x <+> y = x <> Char ' ' <> y
infixr 6 <+> -- like <>



-- | Concatenate all documents element-wise with a binary function.
--
-- @
-- 'concatWith' _ [] = 'mempty'
-- 'concatWith' (**) [x,y,z] = x ** y ** z
-- @
--
-- Multiple convenience definitions based on 'concatWith' are alredy predefined,
-- for example
--
-- @
-- 'hsep'    = 'concatWith' ('<+>')
-- 'fillSep' = 'concatWith' (\\x y -> x '<>' 'softline' '<>' y)
-- @
--
-- This is also useful to define customized joiners,
--
-- >>> concatWith (surround dot) ["Data", "Text", "Prettyprint", "Doc"]
-- Data.Text.Prettyprint.Doc
concatWith :: Foldable t => (Doc ann -> Doc ann -> Doc ann) -> t (Doc ann) -> Doc ann
concatWith f ds
#if !(FOLDABLE_TRAVERSABLE_IN_PRELUDE)
    | foldr (\_ _ -> False) True ds = mempty
#else
    | null ds = mempty
#endif
    | otherwise = foldr1 f ds
{-# INLINE concatWith #-}
{-# SPECIALIZE concatWith :: (Doc ann -> Doc ann -> Doc ann) -> [Doc ann] -> Doc ann #-}

-- | @('hsep' xs)@ concatenates all documents @xs@ horizontally with @'<+>'@,
-- i.e. it puts a space between all entries.
--
-- >>> let docs = Util.words "lorem ipsum dolor sit amet"
--
-- >>> hsep docs
-- lorem ipsum dolor sit amet
--
-- @'hsep'@ does not introduce line breaks on its own, even when the page is too
-- narrow:
--
-- >>> putDocW 5 (hsep docs)
-- lorem ipsum dolor sit amet
--
-- For automatic line breaks, consider using 'fillSep' instead.
hsep :: [Doc ann] -> Doc ann
hsep = concatWith (<+>)

-- | @('vsep' xs)@ concatenates all documents @xs@ above each other. If a
-- 'group' undoes the line breaks inserted by @vsep@, the documents are
-- separated with a 'space' instead.
--
-- Using 'vsep' alone yields
--
-- >>> "prefix" <+> vsep ["text", "to", "lay", "out"]
-- prefix text
-- to
-- lay
-- out
--
-- 'group'ing a 'vsep' separates the documents with a 'space' if it fits the
-- page (and does nothing otherwise). See the @'sep'@ convenience function for
-- this use case.
--
-- The 'align' function can be used to align the documents under their first
-- element:
--
-- >>> "prefix" <+> align (vsep ["text", "to", "lay", "out"])
-- prefix text
--        to
--        lay
--        out
--
-- Since 'group'ing a 'vsep' is rather common, 'sep' is a built-in for doing
-- that.
vsep :: [Doc ann] -> Doc ann
vsep = concatWith (\x y -> x <> line <> y)

-- | @('fillSep' xs)@ concatenates the documents @xs@ horizontally with @'<+>'@
-- as long as it fits the page, then inserts a @'line'@ and continues doing that
-- for all documents in @xs@. (@'line'@ means that if 'group'ed, the documents
-- are separated with a 'space' instead of newlines. Use 'fillCat' if you do not
-- want a 'space'.)
--
-- Let's print some words to fill the line:
--
-- >>> let docs = take 20 (cycle ["lorem", "ipsum", "dolor", "sit", "amet"])
-- >>> putDocW 80 ("Docs:" <+> fillSep docs)
-- Docs: lorem ipsum dolor sit amet lorem ipsum dolor sit amet lorem ipsum dolor
-- sit amet lorem ipsum dolor sit amet
--
-- The same document, printed at a width of only 40, yields
--
-- >>> putDocW 40 ("Docs:" <+> fillSep docs)
-- Docs: lorem ipsum dolor sit amet lorem
-- ipsum dolor sit amet lorem ipsum dolor
-- sit amet lorem ipsum dolor sit amet
fillSep :: [Doc ann] -> Doc ann
fillSep = concatWith (\x y -> x <> softline <> y)

-- | @('sep' xs)@ tries laying out the documents @xs@ separated with 'space's,
-- and if this does not fit the page, separates them with newlines. This is what
-- differentiates it from 'vsep', which always lays out its contents beneath
-- each other.
--
-- >>> let doc = "prefix" <+> sep ["text", "to", "lay", "out"]
-- >>> putDocW 80 doc
-- prefix text to lay out
--
-- With a narrower layout, the entries are separated by newlines:
--
-- >>> putDocW 20 doc
-- prefix text
-- to
-- lay
-- out
--
-- @
-- 'sep' = 'group' . 'vsep'
-- @
sep :: [Doc ann] -> Doc ann
sep = group . vsep



-- | @('hcat' xs)@ concatenates all documents @xs@ horizontally with @'<>'@
-- (i.e. without any spacing).
--
-- It is provided only for consistency, since it is identical to 'mconcat'.
--
-- >>> let docs = Util.words "lorem ipsum dolor"
-- >>> hcat docs
-- loremipsumdolor
hcat :: [Doc ann] -> Doc ann
hcat = concatWith (<>)

-- | @('vcat' xs)@ vertically concatenates the documents @xs@. If it is
-- 'group'ed, the line breaks are removed.
--
-- In other words @'vcat'@ is like @'vsep'@, with newlines removed instead of
-- replaced by 'space's.
--
-- >>> let docs = Util.words "lorem ipsum dolor"
-- >>> vcat docs
-- lorem
-- ipsum
-- dolor
-- >>> group (vcat docs)
-- loremipsumdolor
--
-- Since 'group'ing a 'vcat' is rather common, 'cat' is a built-in shortcut for
-- it.
vcat :: [Doc ann] -> Doc ann
vcat = concatWith (\x y -> x <> line' <> y)

-- | @('fillCat' xs)@ concatenates documents @xs@ horizontally with @'<>'@ as
-- long as it fits the page, then inserts a @'line''@ and continues doing that
-- for all documents in @xs@. This is similar to how an ordinary word processor
-- lays out the text if you just keep typing after you hit the maximum line
-- length.
--
-- (@'line''@ means that if 'group'ed, the documents are separated with nothing
-- instead of newlines. See 'fillSep' if you want a 'space' instead.)
--
-- Observe the difference between 'fillSep' and 'fillCat'. 'fillSep'
-- concatenates the entries 'space'd when 'group'ed,
--
-- >>> let docs = take 20 (cycle (["lorem", "ipsum", "dolor", "sit", "amet"]))
-- >>> putDocW 40 ("Grouped:" <+> group (fillSep docs))
-- Grouped: lorem ipsum dolor sit amet
-- lorem ipsum dolor sit amet lorem ipsum
-- dolor sit amet lorem ipsum dolor sit
-- amet
--
-- On the other hand, 'fillCat' concatenates the entries directly when
-- 'group'ed,
--
-- >>> putDocW 40 ("Grouped:" <+> group (fillCat docs))
-- Grouped: loremipsumdolorsitametlorem
-- ipsumdolorsitametloremipsumdolorsitamet
-- loremipsumdolorsitamet
fillCat :: [Doc ann] -> Doc ann
fillCat = concatWith (\x y -> x <> softline' <> y)

-- | @('cat' xs)@ tries laying out the documents @xs@ separated with nothing,
-- and if this does not fit the page, separates them with newlines. This is what
-- differentiates it from 'vcat', which always lays out its contents beneath
-- each other.
--
-- >>> let docs = Util.words "lorem ipsum dolor"
-- >>> putDocW 80 ("Docs:" <+> cat docs)
-- Docs: loremipsumdolor
--
-- When there is enough space, the documents are put above one another,
--
-- >>> putDocW 10 ("Docs:" <+> cat docs)
-- Docs: lorem
-- ipsum
-- dolor
--
-- @
-- 'cat' = 'group' . 'vcat'
-- @
cat :: [Doc ann] -> Doc ann
cat = group . vcat



-- | @('punctuate' p xs)@ appends @p@ to all but the last document in @xs@.
--
-- >>> let docs = punctuate comma (Util.words "lorem ipsum dolor sit amet")
-- >>> putDocW 80 (hsep docs)
-- lorem, ipsum, dolor, sit, amet
--
-- The separators are put at the end of the entries, which we can see if we
-- position the result vertically:
--
-- >>> putDocW 20 (vsep docs)
-- lorem,
-- ipsum,
-- dolor,
-- sit,
-- amet
--
-- If you want put the commas in front of their elements instead of at the end,
-- you should use 'tupled' or, in general, 'encloseSep'.
punctuate
    :: Doc ann -- ^ Punctuation, e.g. 'comma'
    -> [Doc ann]
    -> [Doc ann]
punctuate p = go
  where
    go []     = []
    go [d]    = [d]
    go (d:ds) = (d <> p) : go ds



-- | Layout a document depending on which column it starts at. 'align' is
-- implemented in terms of 'column'.
--
-- >>> column (\l -> "Columns are" <+> pretty l <> "-based.")
-- Columns are 0-based.
--
-- >>> let doc = "prefix" <+> column (\l -> "| <- column" <+> pretty l)
-- >>> vsep [indent n doc | n <- [0,4,8]]
-- prefix | <- column 7
--     prefix | <- column 11
--         prefix | <- column 15
column :: (Int -> Doc ann) -> Doc ann
column = Column

-- | Layout a document depending on the current 'nest'ing level. 'align' is
-- implemented in terms of 'nesting'.
--
-- >>> let doc = "prefix" <+> nesting (\l -> brackets ("Nested:" <+> pretty l))
-- >>> vsep [indent n doc | n <- [0,4,8]]
-- prefix [Nested: 0]
--     prefix [Nested: 4]
--         prefix [Nested: 8]
nesting :: (Int -> Doc ann) -> Doc ann
nesting = Nesting

-- | @('width' doc f)@ lays out the document 'doc', and makes the column width
-- of it available to a function.
--
-- >>> let annotate doc = width (brackets doc) (\w -> " <- width:" <+> pretty w)
-- >>> align (vsep (map annotate ["---", "------", indent 3 "---", vsep ["---", indent 4 "---"]]))
-- [---] <- width: 5
-- [------] <- width: 8
-- [   ---] <- width: 8
-- [---
--     ---] <- width: 8
width :: Doc ann -> (Int -> Doc ann) -> Doc ann
width doc f
  = column (\colStart ->
        doc <> column (\colEnd ->
            f (colEnd - colStart)))

-- | Layout a document depending on the page width, if one has been specified.
--
-- >>> let prettyPageWidth (AvailablePerLine l r) = "Width:" <+> pretty l <> ", ribbon fraction:" <+> pretty r
-- >>> let doc = "prefix" <+> pageWidth (brackets . prettyPageWidth)
-- >>> putDocW 32 (vsep [indent n doc | n <- [0,4,8]])
-- prefix [Width: 32, ribbon fraction: 1.0]
--     prefix [Width: 32, ribbon fraction: 1.0]
--         prefix [Width: 32, ribbon fraction: 1.0]
pageWidth :: (PageWidth -> Doc ann) -> Doc ann
pageWidth = WithPageWidth



-- | @('fill' i x)@ lays out the document @x@. It then appends @space@s until
-- the width is equal to @i@. If the width of @x@ is already larger, nothing is
-- appended.
--
-- This function is quite useful in practice to output a list of bindings:
--
-- >>> let types = [("empty","Doc"), ("nest","Int -> Doc -> Doc"), ("fillSep","[Doc] -> Doc")]
-- >>> let ptype (name, tp) = fill 5 (pretty name) <+> "::" <+> pretty tp
-- >>> "let" <+> align (vcat (map ptype types))
-- let empty :: Doc
--     nest  :: Int -> Doc -> Doc
--     fillSep :: [Doc] -> Doc
fill
    :: Int -- ^ Append spaces until the document is at least this wide
    -> Doc ann
    -> Doc ann
fill n doc = width doc (\w -> spaces (n - w))

-- | @('fillBreak' i x)@ first lays out the document @x@. It then appends @space@s
-- until the width is equal to @i@. If the width of @x@ is already larger than
-- @i@, the nesting level is increased by @i@ and a @line@ is appended. When we
-- redefine @ptype@ in the example given in 'fill' to use @'fillBreak'@, we get
-- a useful variation of the output:
--
-- >>> let types = [("empty","Doc"), ("nest","Int -> Doc -> Doc"), ("fillSep","[Doc] -> Doc")]
-- >>> let ptype (name, tp) = fillBreak 5 (pretty name) <+> "::" <+> pretty tp
-- >>> "let" <+> align (vcat (map ptype types))
-- let empty :: Doc
--     nest  :: Int -> Doc -> Doc
--     fillSep
--           :: [Doc] -> Doc
fillBreak
    :: Int -- ^ Append spaces until the document is at least this wide
    -> Doc ann
    -> Doc ann
fillBreak f x = width x (\w ->
    if w > f
        then nest f line'
        else spaces (f - w))

-- | Insert a number of spaces. Negative values count as 0.
spaces :: Int -> Doc ann
spaces n = unsafeTextWithoutNewlines (T.replicate n " ")

-- $
-- prop> \(NonNegative n) -> length (show (spaces n)) == n
--
-- >>> case spaces 1 of Char ' ' -> True; _ -> False
-- True
--
-- >>> case spaces 0 of Empty -> True; _ -> False
-- True
--
-- prop> \(Positive n) -> case (spaces (-n)) of Empty -> True; _ -> False



-- | @('plural' n one many)@ is @one@ if @n@ is @1@, and @many@ otherwise. A
-- typical use case is  adding a plural "s".
--
-- >>> let things = [True]
-- >>> let amount = length things
-- >>> pretty things <+> "has" <+> pretty amount <+> plural "entry" "entries" amount
-- [True] has 1 entry
plural
    :: (Num amount, Eq amount)
    => doc -- ^ @1@ case
    -> doc -- ^ other cases
    -> amount
    -> doc
plural one multiple n
    | n == 1    = one
    | otherwise = multiple

-- | @('enclose' l r x)@ encloses document @x@ between documents @l@ and @r@
-- using @'<>'@.
--
-- >>> enclose "A" "Z" "·"
-- A·Z
--
-- @
-- 'enclose' l r x = l '<>' x '<>' r
-- @
enclose
    :: Doc ann -- ^ L
    -> Doc ann -- ^ R
    -> Doc ann -- ^ x
    -> Doc ann -- ^ LxR
enclose l r x = l <> x <> r

-- | @('surround' x l r)@ surrounds document @x@ with @l@ and @r@.
--
-- >>> surround "·" "A" "Z"
-- A·Z
--
-- This is merely an argument reordering of @'enclose'@, but allows for
-- definitions like
--
-- >>> concatWith (surround ".") ["Data", "Text", "Prettyprint", "Doc"]
-- Data.Text.Prettyprint.Doc
surround
    :: Doc ann
    -> Doc ann
    -> Doc ann
    -> Doc ann
surround x l r = l <> x <> r






-- | Add an annotation to a @'Doc'@. This annotation can then be used by the
-- renderer to e.g. add color to certain parts of the output. For a full
-- tutorial example on how to use it, see the
-- "Data.Text.Prettyprint.Doc.Render.Tutorials.StackMachineTutorial" or
-- "Data.Text.Prettyprint.Doc.Render.Tutorials.TreeRenderingTutorial" modules.
--
-- This function is only relevant for custom formats with their own annotations,
-- and not relevant for basic prettyprinting. The predefined renderers, e.g.
-- "Data.Text.Prettyprint.Doc.Render.Text", should be enough for the most common
-- needs.
annotate :: ann -> Doc ann -> Doc ann
annotate = Annotated

-- | Remove all annotations.
--
-- Although 'unAnnotate' is idempotent with respect to rendering,
--
-- @
-- 'unAnnotate' . 'unAnnotate' = 'unAnnotate'
-- @
--
-- it should not be used without caution, for each invocation traverses the
-- entire contained document. If possible, it is preferrable to unannotate after
-- producing the layout by using 'unAnnotateS'.
unAnnotate :: Doc ann -> Doc xxx
unAnnotate = alterAnnotations (const [])

-- | Change the annotation of a 'Doc'ument.
--
-- Useful in particular to embed documents with one form of annotation in a more
-- generlly annotated document.
--
-- Since this traverses the entire @'Doc'@ tree, including parts that are not
-- rendered due to other layouts fitting better, it is preferrable to reannotate
-- after producing the layout by using @'reAnnotateS'@.
--
-- Since @'reAnnotate'@ has the right type and satisfies @'reAnnotate id = id'@,
-- it is used to define the @'Functor'@ instance of @'Doc'@.
reAnnotate :: (ann -> ann') -> Doc ann -> Doc ann'
reAnnotate re = alterAnnotations (pure . re)

-- | Change the annotations of a 'Doc'ument. Individual annotations can be
-- removed, changed, or replaced by multiple ones.
--
-- This is a general function that combines 'unAnnotate' and 'reAnnotate', and
-- it is useful for mapping semantic annotations (such as »this is a keyword«)
-- to display annotations (such as »this is red and underlined«), because some
-- backends may not care about certain annotations, while others may.
--
-- Annotations earlier in the new list will be applied earlier, i.e. returning
-- @[Bold, Green]@ will result in a bold document that contains green text, and
-- not vice-versa.
--
-- Since this traverses the entire @'Doc'@ tree, including parts that are not
-- rendered due to other layouts fitting better, it is preferrable to reannotate
-- after producing the layout by using @'alterAnnotationsS'@.
alterAnnotations :: (ann -> [ann']) -> Doc ann -> Doc ann'
alterAnnotations re = go
  where
    go = \doc -> case doc of
        Fail     -> Fail
        Empty    -> Empty
        Char c   -> Char c
        Text l t -> Text l t
        Line     -> Line

        FlatAlt x y     -> FlatAlt (go x) (go y)
        Cat x y         -> Cat (go x) (go y)
        Nest i x        -> Nest i (go x)
        Union x y       -> Union (go x) (go y)
        Column f        -> Column (go . f)
        WithPageWidth f -> WithPageWidth (go . f)
        Nesting f       -> Nesting (go . f)
        Annotated ann x -> foldr Annotated (go x) (re ann)

-- $
-- >>> let doc = "lorem" <+> annotate () "ipsum" <+> "dolor"
-- >>> let re () = ["FOO", "BAR"]
-- >>> layoutPretty defaultLayoutOptions (alterAnnotations re doc)
-- SText 5 "lorem" (SChar ' ' (SAnnPush "FOO" (SAnnPush "BAR" (SText 5 "ipsum" (SAnnPop (SAnnPop (SChar ' ' (SText 5 "dolor" SEmpty))))))))

-- | Remove all annotations. 'unAnnotate' for 'SimpleDocStream'.
unAnnotateS :: SimpleDocStream ann -> SimpleDocStream xxx
unAnnotateS = go
  where
    go = \doc -> case doc of
        SFail              -> SFail
        SEmpty             -> SEmpty
        SChar c rest       -> SChar c (go rest)
        SText l t rest     -> SText l t (go rest)
        SLine l rest       -> SLine l (go rest)
        SAnnPop rest       -> go rest
        SAnnPush _ann rest -> go rest

-- | Change the annotation of a document. 'reAnnotate' for 'SimpleDocStream'.
reAnnotateS :: (ann -> ann') -> SimpleDocStream ann -> SimpleDocStream ann'
reAnnotateS re = go
  where
    go = \doc -> case doc of
        SFail             -> SFail
        SEmpty            -> SEmpty
        SChar c rest      -> SChar c (go rest)
        SText l t rest    -> SText l t (go rest)
        SLine l rest      -> SLine l (go rest)
        SAnnPop rest      -> SAnnPop (go rest)
        SAnnPush ann rest -> SAnnPush (re ann) (go rest)

data AnnotationRemoval = Remove | DontRemove
  deriving Typeable

-- | Change the annotation of a document to a different annotation, or none at
-- all. 'alterAnnotations' for 'SimpleDocStream'.
--
-- Note that the 'Doc' version is more flexible, since it allows changing a
-- single annotation to multiple ones.
-- ('Data.Text.Prettyprint.Doc.Render.Util.SimpleDocTree.SimpleDocTree' restores
-- this flexibility again.)
alterAnnotationsS :: (ann -> Maybe ann') -> SimpleDocStream ann -> SimpleDocStream ann'
alterAnnotationsS re = go []
  where
    -- We keep a stack of whether to remove a pop so that we can remove exactly
    -- the pops corresponding to annotations that mapped to Nothing.
    go stack = \sds -> case sds of
        SFail             -> SFail
        SEmpty            -> SEmpty
        SChar c rest      -> SChar c (go stack rest)
        SText l t rest    -> SText l t (go stack rest)
        SLine l rest      -> SLine l (go stack rest)
        SAnnPush ann rest -> case re ann of
            Nothing   -> go (Remove:stack) rest
            Just ann' -> SAnnPush ann' (go (DontRemove:stack) rest)
        SAnnPop rest      -> case stack of
            []                -> panicPeekedEmpty
            DontRemove:stack' -> SAnnPop (go stack' rest)
            Remove:stack'     -> go stack' rest

-- | Fusion depth parameter, used by 'fuse'.
data FusionDepth =

    -- | Do not dive deep into nested documents, fusing mostly concatenations of
    -- text nodes together.
    Shallow

    -- | Recurse into all parts of the 'Doc', including different layout
    -- alternatives, and location-sensitive values such as created by 'nesting'
    -- which cannot be fused before, but only during, the layout process. As a
    -- result, the performance cost of using deep fusion is often hard to
    -- predict, and depends on the interplay between page layout and document to
    -- prettyprint.
    --
    -- This value should only be used if profiling shows it is significantly
    -- faster than using 'Shallow'.
    | Deep
    deriving (Eq, Ord, Show, Typeable)

-- | @('fuse' depth doc)@ combines text nodes so they can be rendered more
-- efficiently. A fused document is always laid out identical to its unfused
-- version.
--
-- When laying a 'Doc'ument out to a 'SimpleDocStream', every component of the
-- input is translated directly to the simpler output format. This sometimes
-- yields undesirable chunking when many pieces have been concatenated together.
--
-- For example
--
-- >>> "a" <> "b" <> pretty 'c' <> "d"
-- abcd
--
-- results in a chain of four entries in a 'SimpleDocStream', although this is fully
-- equivalent to the tightly packed
--
-- >>> "abcd" :: Doc ann
-- abcd
--
-- which is only a single 'SimpleDocStream' entry, and can be processed faster.
--
-- It is therefore a good idea to run 'fuse' on concatenations of lots of small
-- strings that are used many times,
--
-- >>> let oftenUsed = fuse Shallow ("a" <> "b" <> pretty 'c' <> "d")
-- >>> hsep (replicate 5 oftenUsed)
-- abcd abcd abcd abcd abcd
fuse :: FusionDepth -> Doc ann -> Doc ann
fuse depth = go
  where
    go = \doc -> case doc of
        Cat Empty x                   -> go x
        Cat x Empty                   -> go x
        Cat (Char c1) (Char c2)       -> Text 2 (T.singleton c1 <> T.singleton c2)
        Cat (Text lt t) (Char c)      -> Text (lt+1) (T.snoc t c)
        Cat (Char c) (Text lt t)      -> Text (1+lt) (T.cons c t)
        Cat (Text l1 t1) (Text l2 t2) -> Text (l1+l2) (t1 <> t2)

        Cat x@Char{} (Cat y@Char{} z) -> go (Cat (go (Cat x y)) z)
        Cat x@Text{} (Cat y@Char{} z) -> go (Cat (go (Cat x y)) z)
        Cat x@Char{} (Cat y@Text{} z) -> go (Cat (go (Cat x y)) z)
        Cat x@Text{} (Cat y@Text{} z) -> go (Cat (go (Cat x y)) z)

        Cat (Cat x y@Char{}) z -> go (Cat x (go (Cat y z)))
        Cat (Cat x y@Text{}) z -> go (Cat x (go (Cat y z)))

        Cat x y -> Cat (go x) (go y)

        Nest i (Nest j x) -> let !fused = Nest (i+j) x
                             in go fused
        Nest _ x@Empty{} -> x
        Nest _ x@Text{}  -> x
        Nest _ x@Char{}  -> x
        Nest 0 x         -> go x
        Nest i x         -> Nest i (go x)

        Annotated _ Empty -> Empty

        FlatAlt x1 x2 -> FlatAlt (go x1) (go x2)
        Union x1 x2   -> Union (go x1) (go x2)

        other | depth == Shallow -> other

        Column f        -> Column (go . f)
        WithPageWidth f -> WithPageWidth (go . f)
        Nesting f       -> Nesting (go . f)

        other -> other



-- | The data type @SimpleDocStream@ represents laid out documents and is used
-- by the display functions.
--
-- A simplified view is that @'Doc' = ['SimpleDocStream']@, and the layout
-- functions pick one of the 'SimpleDocStream's based on which one fits the
-- layout constraints best. This means that 'SimpleDocStream' has all complexity
-- contained in 'Doc' resolved, making it very easy to convert it to other
-- formats, such as plain text or terminal output.
--
-- To write your own @'Doc'@ to X converter, it is therefore sufficient to
-- convert from @'SimpleDocStream'@. The »Render« submodules provide some
-- built-in converters to do so, and helpers to create own ones.
data SimpleDocStream ann =
      SFail
    | SEmpty
    | SChar Char (SimpleDocStream ann)

    -- | Some layout algorithms use the Since the frequently used 'T.length' of
    -- the 'Text', which scales linearly with its length, we cache it in this
    -- constructor.
    | SText !Int Text (SimpleDocStream ann)

    -- | @Int@ = indentation level for the (next) line
    | SLine !Int (SimpleDocStream ann)

    -- | Add an annotation to the remaining document.
    | SAnnPush ann (SimpleDocStream ann)

    -- | Remove a previously pushed annotation.
    | SAnnPop (SimpleDocStream ann)
    deriving (Eq, Ord, Show, Generic, Typeable)

-- | Remove all trailing space characters.
--
-- This has some performance impact, because it does an entire additional pass
-- over the 'SimpleDocStream'.
--
-- No trimming will be done inside annotations, which are considered to contain
-- no (trimmable) whitespace, since the annotation might actually be /about/ the
-- whitespace, for example a renderer that colors the background of trailing
-- whitespace, as e.g. @git diff@ can be configured to do.
removeTrailingWhitespace :: SimpleDocStream ann -> SimpleDocStream ann
removeTrailingWhitespace = go (RecordedWhitespace [] 0)
  where
    commitSpaces
        :: [Int] -- Withheld lines
        -> Int -- Withheld spaces
        -> SimpleDocStream ann
        -> SimpleDocStream ann
    commitSpaces [] 0 = id
    commitSpaces [] 1 = SChar ' '
    commitSpaces [] n = SText n (T.replicate n " ")
    commitSpaces [i] n = SLine i . commitSpaces [] n
    commitSpaces (_:is) n = SLine 0 . commitSpaces is n

    go :: WhitespaceStrippingState -> SimpleDocStream ann -> SimpleDocStream ann
    -- We do not strip whitespace inside annotated documents, since it might
    -- actually be relevant there.
    go annLevel@(AnnotationLevel annLvl) = \sds -> case sds of
        SFail             -> SFail
        SEmpty            -> SEmpty
        SChar c rest      -> SChar c (go annLevel rest)
        SText l text rest -> SText l text (go annLevel rest)
        SLine i rest      -> SLine i (go annLevel rest)
        SAnnPush ann rest -> let !annLvl' = annLvl+1
                             in SAnnPush ann (go (AnnotationLevel annLvl') rest)
        SAnnPop rest
            | annLvl > 1  -> let !annLvl' = annLvl-1
                             in SAnnPop (go (AnnotationLevel annLvl') rest)
            | otherwise   -> SAnnPop (go (RecordedWhitespace [] 0) rest)
    -- Record all spaces/lines encountered, and once proper text starts again,
    -- release only the necessary ones.
    go (RecordedWhitespace withheldLines withheldSpaces) = \sds -> case sds of
        SFail -> SFail
        SEmpty -> foldr (\_i sds' -> SLine 0 sds') SEmpty withheldLines
        SChar c rest
            | c == ' ' -> go (RecordedWhitespace withheldLines (withheldSpaces+1)) rest
            | otherwise -> commitSpaces
                               withheldLines
                               withheldSpaces
                               (SChar c (go (RecordedWhitespace [] 0) rest))
        SText textLength text rest ->
            let stripped = T.dropWhileEnd (== ' ') text
                strippedLength = T.length stripped
                trailingLength = textLength - strippedLength
                isOnlySpace = strippedLength == 0
            in if isOnlySpace
                then go (RecordedWhitespace withheldLines (withheldSpaces + textLength)) rest
                else commitSpaces
                        withheldLines
                        withheldSpaces
                        (SText strippedLength
                               stripped
                               (go (RecordedWhitespace [] trailingLength) rest))
        SLine i rest -> go (RecordedWhitespace (i:withheldLines) 0) rest
        SAnnPush ann rest -> commitSpaces
                                 withheldLines
                                 withheldSpaces
                                 (SAnnPush ann (go (AnnotationLevel 1) rest))
        SAnnPop _ -> error "Tried skipping spaces in unannotated data! Please report this as a bug in 'prettyprinter'."

data WhitespaceStrippingState
    = AnnotationLevel !Int
    | RecordedWhitespace [Int] !Int
      -- ^ [Newline with indentation i] Spaces
  deriving Typeable


-- $
-- >>> import qualified Data.Text.IO as T
-- >>> doc = "lorem" <> hardline <> hardline <> pretty "ipsum"
-- >>> go = T.putStrLn . renderStrict . removeTrailingWhitespace . layoutPretty defaultLayoutOptions
-- >>> go doc
-- lorem
-- <BLANKLINE>
-- ipsum



-- | Alter the document’s annotations.
--
-- This instance makes 'SimpleDocStream' more flexible (because it can be used in
-- 'Functor'-polymorphic values), but @'fmap'@ is much less readable compared to
-- using @'reAnnotateST'@ in code that only works for @'SimpleDocStream'@ anyway.
-- Consider using the latter when the type does not matter.
instance Functor SimpleDocStream where
    fmap = reAnnotateS

-- | Collect all annotations from a document.
instance Foldable SimpleDocStream where
    foldMap f = go
      where
        go = \sds -> case sds of
            SFail             -> mempty
            SEmpty            -> mempty
            SChar _ rest      -> go rest
            SText _ _ rest    -> go rest
            SLine _ rest      -> go rest
            SAnnPush ann rest -> f ann `mappend` go rest
            SAnnPop rest      -> go rest

-- | Transform a document based on its annotations, possibly leveraging
-- 'Applicative' effects.
instance Traversable SimpleDocStream where
    traverse f = go
      where
        go = \sds -> case sds of
            SFail             -> pure SFail
            SEmpty            -> pure SEmpty
            SChar c rest      -> SChar c   <$> go rest
            SText l t rest    -> SText l t <$> go rest
            SLine i rest      -> SLine i   <$> go rest
            SAnnPush ann rest -> SAnnPush  <$> f ann <*> go rest
            SAnnPop rest      -> SAnnPop   <$> go rest

-- | Decide whether a 'SimpleDocStream' fits the constraints given, namely
--
--   - page width
--   - minimum nesting level to fit in
--   - width in which to fit the first line; Nothing is unbounded
newtype FittingPredicate ann
  = FittingPredicate (PageWidth
                   -> Int
                   -> Maybe Int
                   -> SimpleDocStream ann
                   -> Bool)
  deriving Typeable

-- | List of nesting level/document pairs yet to be laid out.
data LayoutPipeline ann =
      Nil
    | Cons !Int (Doc ann) (LayoutPipeline ann)
    | UndoAnn (LayoutPipeline ann)
  deriving Typeable

-- | Maximum number of characters that fit in one line. The layout algorithms
-- will try not to exceed the set limit by inserting line breaks when applicable
-- (e.g. via 'softline'').
data PageWidth

    = AvailablePerLine Int Double
    -- ^ Layouters should not exceed the specified space per line.
    --
    --   - The 'Int' is the number of characters, including whitespace, that
    --     fit in a line. A typical value is 80.
    --
    --   - The 'Double' is the ribbon with, i.e. the fraction of the total
    --     page width that can be printed on. This allows limiting the length
    --     of printable text per line. Values must be between 0 and 1, and
    --     0.4 to 1 is typical.

    | Unbounded
    -- ^ Layouters should not introduce line breaks on their own.

    deriving (Eq, Ord, Show, Typeable)

-- $ Test to avoid surprising behaviour
-- >>> Unbounded > AvailablePerLine maxBound 1
-- True

-- | Options to influence the layout algorithms.
newtype LayoutOptions = LayoutOptions { layoutPageWidth :: PageWidth }
    deriving (Eq, Ord, Show, Typeable)

-- | The default layout options, suitable when you just want some output, and
-- don’t particularly care about the details. Used by the 'Show' instance, for
-- example.
--
-- >>> defaultLayoutOptions
-- LayoutOptions {layoutPageWidth = AvailablePerLine 80 1.0}
defaultLayoutOptions :: LayoutOptions
defaultLayoutOptions = LayoutOptions { layoutPageWidth = AvailablePerLine 80 1 }

-- | This is the default layout algorithm, and it is used by 'show', 'putDoc'
-- and 'hPutDoc'.
--
-- @'layoutPretty'@ commits to rendering something in a certain way if the next
-- element fits the layout constraints; in other words, it has one
-- 'SimpleDocStream' element lookahead when rendering. Consider using the
-- smarter, but a bit less performant, @'layoutSmart'@ algorithm if the results
-- seem to run off to the right before having lots of line breaks.
layoutPretty
    :: LayoutOptions
    -> Doc ann
    -> SimpleDocStream ann
layoutPretty = layoutWadlerLeijen
    (FittingPredicate (\_pWidth _minNestingLevel maxWidth sdoc -> case maxWidth of
        Nothing -> True
        Just w -> fits w sdoc ))
  where
    fits :: Int -- ^ Width in which to fit the first line
         -> SimpleDocStream ann
         -> Bool
    fits w _ | w < 0      = False
    fits _ SFail          = False
    fits _ SEmpty         = True
    fits w (SChar _ x)    = fits (w - 1) x
    fits w (SText l _t x) = fits (w - l) x
    fits _ SLine{}        = True
    fits w (SAnnPush _ x) = fits w x
    fits w (SAnnPop x)    = fits w x

-- | A layout algorithm with more lookahead than 'layoutPretty', that introduces
-- line breaks earlier if the content does not (or will not, rather) fit into
-- one line.
--
-- Considre the following python-ish document,
--
-- >>> let fun x = hang 2 ("fun(" <> softline' <> x) <> ")"
-- >>> let doc = (fun . fun . fun . fun . fun) (align (list ["abcdef", "ghijklm"]))
--
-- which we’ll be rendering using the following pipeline (where the layout
-- algorithm has been left open),
--
-- >>> import Data.Text.IO as T
-- >>> import Data.Text.Prettyprint.Doc.Render.Text
-- >>> let hr = pipe <> pretty (replicate (26-2) '-') <> pipe
-- >>> let go layouter x = (T.putStrLn . renderStrict . layouter (LayoutOptions (AvailablePerLine 26 1))) (vsep [hr, x, hr])
--
-- If we render this using @'layoutPretty'@ with a page width of 26 characters
-- per line, all the @fun@ calls fit into the first line so they will be put
-- there,
--
-- >>> go layoutPretty doc
-- |------------------------|
-- fun(fun(fun(fun(fun(
--                   [ abcdef
--                   , ghijklm ])))))
-- |------------------------|
--
-- Note that this exceeds the desired 26 character page width. The same
-- document, rendered with @'layoutSmart'@, fits the layout contstraints:
--
-- >>> go layoutSmart doc
-- |------------------------|
-- fun(
--   fun(
--     fun(
--       fun(
--         fun(
--           [ abcdef
--           , ghijklm ])))))
-- |------------------------|
--
-- The key difference between @'layoutPretty'@ and @'layoutSmart'@ is that the
-- latter will check the potential document up to the end of the current
-- indentation level, instead of just having one element lookahead.
layoutSmart
    :: LayoutOptions
    -> Doc ann
    -> SimpleDocStream ann
layoutSmart = layoutWadlerLeijen
    (FittingPredicate (\pWidth minNestingLevel maxWidth sdoc -> case maxWidth of
        Nothing -> True
        Just w -> fits pWidth minNestingLevel w sdoc ))
  where
    -- Search with more lookahead: assuming that nesting roughly corresponds to
    -- syntactic depth, @fits@ checks that not only the current line fits, but
    -- the entire syntactic structure being formatted at this level of
    -- indentation fits. If we were to remove the second case for @SLine@, we
    -- would check that not only the current structure fits, but also the rest
    -- of the document, which would be slightly more intelligent but would have
    -- exponential runtime (and is prohibitively expensive in practice).
    fits :: PageWidth
         -> Int -- ^ Minimum nesting level to fit in
         -> Int -- ^ Width in which to fit the first line
         -> SimpleDocStream ann
         -> Bool
    fits _ _ w _ | w < 0                    = False
    fits _ _ _ SFail                        = False
    fits _ _ _ SEmpty                       = True
    fits pw m w (SChar _ x)                 = fits pw m (w - 1) x
    fits pw m w (SText l _t x)              = fits pw m (w - l) x
    fits pw m _ (SLine i x)
      | m < i, AvailablePerLine cpl _ <- pw = fits pw m (cpl - i) x
      | otherwise                           = True
    fits pw m w (SAnnPush _ x)              = fits pw m w x
    fits pw m w (SAnnPop x)                 = fits pw m w x

-- | The Wadler/Leijen layout algorithm
layoutWadlerLeijen
    :: forall ann. FittingPredicate ann
    -> LayoutOptions
    -> Doc ann
    -> SimpleDocStream ann
layoutWadlerLeijen
    fittingPredicate
    LayoutOptions { layoutPageWidth = pWidth }
    doc
  = best 0 0 (Cons 0 doc Nil)
  where

    -- * current column >= current nesting level
    -- * current column - current indentaion = number of chars inserted in line
    best
        :: Int -- Current nesting level
        -> Int -- Current column, i.e. "where the cursor is"
        -> LayoutPipeline ann -- Documents remaining to be handled (in order)
        -> SimpleDocStream ann
    best !_ !_ Nil           = SEmpty
    best nl cc (UndoAnn ds)  = SAnnPop (best nl cc ds)
    best nl cc (Cons i d ds) = case d of
        Fail            -> SFail
        Empty           -> best nl cc ds
        Char c          -> let !cc' = cc+1 in SChar c (best nl cc' ds)
        Text l t        -> let !cc' = cc+l in SText l t (best nl cc' ds)
        Line            -> SLine i (best i i ds)
        FlatAlt x _     -> best nl cc (Cons i x ds)
        Cat x y         -> best nl cc (Cons i x (Cons i y ds))
        Nest j x        -> let !ij = i+j in best nl cc (Cons ij x ds)
        Union x y       -> let x' = best nl cc (Cons i x ds)
                               y' = best nl cc (Cons i y ds)
                           in selectNicer fittingPredicate nl cc x' y'
        Column f        -> best nl cc (Cons i (f cc) ds)
        WithPageWidth f -> best nl cc (Cons i (f pWidth) ds)
        Nesting f       -> best nl cc (Cons i (f i) ds)
        Annotated ann x -> SAnnPush ann (best nl cc (Cons i x (UndoAnn ds)))

    selectNicer
        :: FittingPredicate ann
        -> Int           -- ^ Current nesting level
        -> Int           -- ^ Current column
        -> SimpleDocStream ann -- ^ Choice A. Invariant: first lines should not be longer than B's.
        -> SimpleDocStream ann -- ^ Choice B.
        -> SimpleDocStream ann -- ^ Choice A if it fits, otherwise B.
    selectNicer (FittingPredicate fits) lineIndent currentColumn x y
      | fits pWidth minNestingLevel availableWidth x = x
      | otherwise = y
      where
        minNestingLevel = min lineIndent currentColumn
        ribbonWidth = case pWidth of
            AvailablePerLine lineLength ribbonFraction ->
                (Just . max 0 . min lineLength . round)
                    (fromIntegral lineLength * ribbonFraction)
            Unbounded -> Nothing
        availableWidth = do
            columnsLeftInLine <- case pWidth of
                AvailablePerLine cpl _ribbonFrac -> Just (cpl - currentColumn)
                Unbounded -> Nothing
            columnsLeftInRibbon <- do
                li <- Just lineIndent
                rw <- ribbonWidth
                cc <- Just currentColumn
                Just (li + rw - cc)
            Just (min columnsLeftInLine columnsLeftInRibbon)

-- | @(layoutCompact x)@ lays out the document @x@ without adding any
-- indentation. Since no \'pretty\' printing is involved, this layouter is very
-- fast. The resulting output contains fewer characters than a prettyprinted
-- version and can be used for output that is read by other programs.
--
-- >>> let doc = hang 4 (vsep ["lorem", "ipsum", hang 4 (vsep ["dolor", "sit"])])
-- >>> doc
-- lorem
--     ipsum
--     dolor
--         sit
--
-- >>> let putDocCompact = renderIO System.IO.stdout . layoutCompact
-- >>> putDocCompact doc
-- lorem
-- ipsum
-- dolor
-- sit
layoutCompact :: Doc ann -> SimpleDocStream ann
layoutCompact doc = scan 0 [doc]
  where
    scan _ [] = SEmpty
    scan !col (d:ds) = case d of
        Fail            -> SFail
        Empty           -> scan col ds
        Char c          -> SChar c (scan (col+1) ds)
        Text l t        -> let !col' = col+l in SText l t (scan col' ds)
        FlatAlt x _     -> scan col (x:ds)
        Line            -> SLine 0 (scan 0 ds)
        Cat x y         -> scan col (x:y:ds)
        Nest _ x        -> scan col (x:ds)
        Union _ y       -> scan col (y:ds)
        Column f        -> scan col (f col:ds)
        WithPageWidth f -> scan col (f Unbounded : ds)
        Nesting f       -> scan col (f 0 : ds)
        Annotated _ x   -> scan col (x:ds)

-- | @('show' doc)@ prettyprints document @doc@ with 'defaultLayoutOptions',
-- ignoring all annotations.
instance Show (Doc ann) where
    showsPrec _ doc = renderShowS (layoutPretty defaultLayoutOptions doc)

-- | Render a 'SimpleDocStream' to a 'ShowS', useful to write 'Show' instances
-- based on the prettyprinter.
--
-- @
-- instance 'Show' MyType where
--     'showsPrec' _ = 'renderShowS' . 'layoutPretty' 'defaultLayoutOptions' . 'pretty'
-- @
renderShowS :: SimpleDocStream ann -> ShowS
renderShowS = \sds -> case sds of
    SFail        -> panicUncaughtFail
    SEmpty       -> id
    SChar c x    -> showChar c . renderShowS x
    SText _l t x -> showString (T.unpack t) . renderShowS x
    SLine i x    -> showString ('\n' : replicate i ' ') . renderShowS x
    SAnnPush _ x -> renderShowS x
    SAnnPop x    -> renderShowS x



-- $setup
--
-- (Definitions for the doctests)
--
-- >>> :set -XOverloadedStrings
-- >>> import Data.Text.Prettyprint.Doc.Render.Text
-- >>> import Data.Text.Prettyprint.Doc.Symbols.Ascii
-- >>> import Data.Text.Prettyprint.Doc.Util as Util
-- >>> import Test.QuickCheck.Modifiers