MonadicPrettyPrintInternal.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Text.PrettyPrint.Reader
-- Copyright   :  (c) Warren Harris 2012
-- License     :  BSD-style (see the file LICENSE)
--
-- Maintainer  :  Warren Harris <warrensomebody@gmail.com>
-- Stability   :  stable
-- Portability :  portable
--
-- A wrapper around the John Hughes's and Simon Peyton Jones's Pretty
-- Printer combinators based on the ReaderT monad transformer, allowing
-- lookups to be performed during the pretty-printing process.
-----------------------------------------------------------------------------

-- Taken from https://github.com/haskell/pretty/pull/6 - merge back in when
-- finished

module Util.MonadicPrettyPrintInternal(
    -- * The document type
    P.Doc, P.TextDetails(..),

    -- * 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,

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

    -- * Predicates on documents
    isEmpty,

    {-
    -- * Utility functions for documents
    first, reduceDoc,
    -- TODO: Should these be exported? Previously they weren't
    -- WH: These don't make sense because RDoc isn't exposed or otherwise used.
    -}

    -- * Rendering documents

    -- ** Default rendering
    render,

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

    -- ** General rendering
    fullRender,
) where

import Control.Applicative hiding (empty)
--import Control.Monad.Reader
--import Control.Monad.Trans.Class
import qualified Text.PrettyPrint.HughesPJ as P

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

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

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

-- | A document of height and width 1, containing a literal character.
char :: (Monad m, Applicative m) => Char -> m P.Doc
char c = return $ P.char c

-- | 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 :: (Monad m, Applicative m) => String -> m P.Doc
text s = return $ P.text s

-- | Same as @text@. Used to be used for Bytestrings.
ptext :: (Monad m, Applicative m) => String -> m P.Doc
ptext s = return $ P.ptext s

-- | Some text with any width. (@text s = sizedText (length s) s@)
sizedText :: (Monad m, Applicative m) => Int -> String -> m P.Doc
sizedText l s = return $ P.sizedText l s

-- | Some text, but without any width. Use for non-printing text
-- such as a HTML or Latex tags
zeroWidthText :: (Monad m, Applicative m) => String -> m P.Doc
zeroWidthText s = return $ P.zeroWidthText s

-- | 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 :: (Monad m, Applicative m) => m P.Doc
empty = return P.empty

-- | Returns 'True' if the document is empty
isEmpty :: (Monad m, Applicative m) => m P.Doc -> m Bool
isEmpty doc = P.isEmpty <$> doc

-- | A ';' character
semi   :: (Monad m, Applicative m) => m P.Doc
semi = return P.semi

-- | A ',' character
comma  :: (Monad m, Applicative m) => m P.Doc
comma = return P.comma

-- | A ':' character
colon  :: (Monad m, Applicative m) => m P.Doc
colon = return P.colon

-- | A space character
space  :: (Monad m, Applicative m) => m P.Doc
space = return P.space

-- | A '=' character
equals :: (Monad m, Applicative m) => m P.Doc
equals = return P.equals

-- | A '(' character
lparen :: (Monad m, Applicative m) => m P.Doc
lparen = return P.lparen

-- | A ')' character
rparen :: (Monad m, Applicative m) => m P.Doc
rparen = return P.rparen

-- | A '[' character
lbrack :: (Monad m, Applicative m) => m P.Doc
lbrack = return P.lbrack

-- | A ']' character
rbrack :: (Monad m, Applicative m) => m P.Doc
rbrack = return P.rbrack

-- | A '{' character
lbrace :: (Monad m, Applicative m) => m P.Doc
lbrace = return P.lbrace

-- | A '}' character
rbrace :: (Monad m, Applicative m) => m P.Doc
rbrace = return P.rbrace

-- | @int n = text (show n)@
int      :: (Monad m, Applicative m) => Int      -> m P.Doc
int      = return . P.int

-- | @integer n = text (show n)@
integer  :: (Monad m, Applicative m) => Integer  -> m P.Doc
integer  = return . P.integer

-- | @float n = text (show n)@
float    :: (Monad m, Applicative m) => Float    -> m P.Doc
float    = return . P.float

-- | @double n = text (show n)@
double   :: (Monad m, Applicative m) => Double   -> m P.Doc
double   = return . P.double

-- | @rational n = text (show n)@
rational :: (Monad m, Applicative m) => Rational -> m P.Doc
rational = return . P.rational

-- | Wrap document in @(...)@
parens       :: (Monad m, Applicative m) => m P.Doc -> m P.Doc
parens p     = P.parens <$> p

-- | Wrap document in @[...]@
brackets     :: (Monad m, Applicative m) => m P.Doc -> m P.Doc
brackets p   = P.brackets <$> p

-- | Wrap document in @{...}@
braces       :: (Monad m, Applicative m) => m P.Doc -> m P.Doc
braces p     = P.braces <$> p

-- | Wrap document in @\'...\'@
quotes       :: (Monad m, Applicative m) => m P.Doc -> m P.Doc
quotes p     = P.quotes <$> p

-- | Wrap document in @\"...\"@
doubleQuotes :: (Monad m, Applicative m) => m P.Doc -> m P.Doc
doubleQuotes p = P.doubleQuotes <$> p

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

{-
-- | Perform some simplification of a built up @GDoc@.
reduceDoc :: (Monad m, Applicative m) => m P.Doc -> m P.RDoc
reduceDoc p = p >>= return . P.reduceDoc
-}

-- | List version of '<>'.
hcat :: (Monad m, Applicative m) => m [P.Doc] -> m P.Doc
hcat l = P.hcat <$> l

-- | List version of '<+>'.
hsep :: (Monad m, Applicative m) => m [P.Doc] -> m P.Doc
hsep l = P.hsep <$> l

-- | List version of '$$'.
vcat :: (Monad m, Applicative m) => m [P.Doc] -> m P.Doc
vcat l = P.vcat <$> l

-- | 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 :: (Monad m, Applicative m) => Int -> m P.Doc -> m P.Doc
nest k p = P.nest k <$> p

-- | @hang d1 n d2 = sep [d1, nest n d2]@
hang :: (Monad m, Applicative m) => m P.Doc -> Int -> m P.Doc -> m P.Doc
--hang d1 n d2 = do d1' <- d1; d2' <- d2; return $ P.hang d1' n d2'
hang d1 n d2 = flip P.hang n <$> d1 <*> d2

-- | @punctuate p [d1, ... dn] = [d1 \<> p, d2 \<> p, ... dn-1 \<> p, dn]@
punctuate :: (Monad m, Applicative m) => m P.Doc -> m [P.Doc] -> m [P.Doc]
punctuate p l = --(liftA2 P.punctuate p (l >>= sequence)) >>= return . map return
    P.punctuate <$> p <*> l

-- ---------------------------------------------------------------------------
-- 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.
--
($$) :: (Monad m, Applicative m) => m P.Doc -> m P.Doc -> m P.Doc
p $$ q = (P.$$) <$> p <*> q

-- | Above, with no overlapping.
-- '$+$' is associative, with identity 'empty'.
($+$) :: (Monad m, Applicative m) => m P.Doc -> m P.Doc -> m P.Doc
p $+$ q = (P.$+$) <$> p <*> 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'.
(<>) :: (Monad m, Applicative m) => m P.Doc -> m P.Doc -> m P.Doc
p <> q = (P.<>) <$> p <*> q

-- | Beside, separated by space, unless one of the arguments is 'empty'.
-- '<+>' is associative, with identity 'empty'.
(<+>) :: (Monad m, Applicative m) => m P.Doc -> m P.Doc -> m P.Doc
p <+> q = (P.<+>) <$> p <*> q

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

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

-- | Either 'hsep' or 'vcat'.
sep :: (Monad m, Applicative m) => m [P.Doc] -> m P.Doc
sep l = P.sep <$> l

-- | Either 'hcat' or 'vcat'.
cat :: (Monad m, Applicative m) => m [P.Doc] -> m P.Doc
cat l = P.cat <$> l

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

-- | \"Paragraph fill\" version of 'cat'.
fcat :: (Monad m, Applicative m) => m [P.Doc] -> m P.Doc
fcat l = P.fcat <$> l

-- | \"Paragraph fill\" version of 'sep'.
fsep :: (Monad m, Applicative m) => m [P.Doc] -> m P.Doc
fsep l = P.fsep <$> l

-- ---------------------------------------------------------------------------
-- Selecting the best layout
{-
-- | @first@ returns its first argument if it is non-empty, otherwise its second.
first :: (Monad m, Applicative m) => m P.Doc -> m P.Doc -> m P.Doc
first p q = do p' <- p; q' <- q; return $ P.first p' q'
-}
-- ---------------------------------------------------------------------------
-- Rendering

-- | Render the @Doc@ to a String using the default @Style@.
render :: (Monad m, Applicative m) => m P.Doc -> m String
render doc = doc >>= return . P.render

-- | Render the @Doc@ to a String using the given @Style@.
renderStyle :: (Monad m, Applicative m) => P.Style -> m P.Doc -> m String
renderStyle s doc = doc >>= return . P.renderStyle s

-- | The general rendering interface.
fullRender :: (Monad m, Applicative m) =>
           P.Mode                   -- ^ Rendering mode
           -> Int                      -- ^ Line length
           -> Float                    -- ^ Ribbons per line
           -> (P.TextDetails -> a -> a)  -- ^ What to do with text
           -> a                        -- ^ What to do at the end
           -> m P.Doc             -- ^ The document
           -> m a                      -- ^ Result
fullRender m lineLen ribbons txt rest doc =
  doc >>= return . P.fullRender m lineLen ribbons txt rest

--------------------------------------------------------------------------------