-- | A 'Document' is at heart 'ShowS' from the prelude
--
-- Essentially, if you give a Doc a string it'll print out whatever it
-- wants followed by that string. So @text "foo"@ makes the Doc that
-- prints @"foo"@ followed by its argument. The combinator names are taken
-- from 'Text.PrettyPrint.HughesPJ', although the behaviour of the two libraries is
-- slightly different.
--
-- The advantage of Printer over simple string appending/concatenating is
-- that the appends end up associating to the right, e.g.:
--
-- >   (text "foo" <> text "bar") <> (text "baz" <> text "quux") ""
-- > = \s -> (text "foo" <> text "bar") ((text "baz" <> text "quux") s) ""
-- > = (text "foo" <> text "bar") ((text "baz" <> text "quux") "")
-- > = (\s -> (text "foo") (text "bar" s)) ((text "baz" <> text "quux") "")
-- > = text "foo" (text "bar" ((text "baz" <> text "quux") ""))
-- > = (\s -> "foo" ++ s) (text "bar" ((text "baz" <> text "quux") ""))
-- > = "foo" ++ (text "bar" ((text "baz" <> text "quux") ""))
-- > = "foo" ++ ("bar" ++ ((text "baz" <> text "quux") ""))
-- > = "foo" ++ ("bar" ++ ((\s -> text "baz" (text "quux" s)) ""))
-- > = "foo" ++ ("bar" ++ (text "baz" (text "quux" "")))
-- > = "foo" ++ ("bar" ++ ("baz" ++ (text "quux" "")))
-- > = "foo" ++ ("bar" ++ ("baz" ++ ("quux" ++ "")))
--
-- The Empty alternative comes in because you want
--
-- > text "a" $$ vcat xs $$ text "b"
--
-- '$$' means above, 'vcat' is the list version of '$$'
-- (to be @\"a\\nb\"@ when @xs@  is @[]@), but without the concept of an
-- Empty Document each @$$@ would add a @'\n'@ and you'd end up with
-- @\"a\\n\\nb\"@.
-- Note that @Empty \/= text \"\"@ (the latter would cause two
-- @'\\n'@).
--
-- This code was made generic in the element type by Juliusz Chroboczek.
module Darcs.Util.Printer
    (
    -- * 'Doc' type and structural combinators
      Doc(Doc,unDoc)
    , empty, (<>), (<?>), (<+>), ($$), vcat, vsep, hcat, hsep
    , minus, newline, plus, space, backslash, lparen, rparen
    , parens
    -- * Constructing 'Doc's
    , text
    , hiddenText
    , invisibleText
    , wrapText, quoted
    , userchunk, packedString
    , prefix
    , hiddenPrefix
    , insertBeforeLastline
    , prefixLines
    , invisiblePS, userchunkPS
    -- * Rendering to 'String'
    , renderString, renderStringWith
    -- * Rendering to 'ByteString'
    , renderPS, renderPSWith
    , renderPSs, renderPSsWith
    -- * Printers
    , Printers
    , Printers'(..)
    , Printer
    , simplePrinters, invisiblePrinter, simplePrinter
    -- * Printables
    , Printable(..)
    , doc
    , printable, invisiblePrintable, hiddenPrintable, userchunkPrintable
    -- * Constructing colored 'Doc's
    , Color(..)
    , blueText, redText, greenText, magentaText, cyanText
    , colorText
    , lineColor
    -- * IO, uses 'Data.ByteString.hPut' for output
    , hPutDoc,     hPutDocLn,     putDoc,     putDocLn
    , hPutDocWith, hPutDocLnWith, putDocWith, putDocLnWith
    , hPutDocCompr
    , debugDocLn
    , ePutDocLn
    , errorDoc
    -- * TODO: It is unclear what is unsafe about these constructors
    , unsafeText, unsafeBoth, unsafeBothText, unsafeChar
    , unsafePackedString
    ) where

import Prelude ()
import Darcs.Prelude

import Data.String ( IsString(..) )
import System.IO ( Handle, stdout, stderr )
import qualified Data.ByteString as B ( ByteString, hPut, concat )
import qualified Data.ByteString.Char8 as BC ( singleton )

import Darcs.Util.ByteString ( linesPS, decodeLocale, encodeLocale, gzWriteHandle )
import Darcs.Util.Global ( debugMessage )

-- | A 'Printable' is either a String, a packed string, or a chunk of
-- text with both representations.
data Printable = S !String
               | PS !B.ByteString
               | Both !String !B.ByteString

-- | 'Printable' representation of a space
spaceP :: Printable
spaceP :: Printable
spaceP   = String -> ByteString -> Printable
Both " "  (Char -> ByteString
BC.singleton ' ')

-- | 'Printable' representation of a newline.
newlineP :: Printable
newlineP :: Printable
newlineP = String -> Printable
S "\n"

-- | A 'Doc' representing a space (\" \")
space :: Doc
space :: Doc
space = String -> ByteString -> Doc
unsafeBoth " "  (Char -> ByteString
BC.singleton ' ')

-- | A 'Doc' representing a newline
newline :: Doc
newline :: Doc
newline = Char -> Doc
unsafeChar '\n'

-- | A 'Doc' representing a \"-\"
minus :: Doc
minus :: Doc
minus = String -> ByteString -> Doc
unsafeBoth "-"  (Char -> ByteString
BC.singleton '-')

-- | A 'Doc' representing a \"+\"
plus :: Doc
plus :: Doc
plus = String -> ByteString -> Doc
unsafeBoth "+"  (Char -> ByteString
BC.singleton '+')

-- | A 'Doc' representing a \"\\\"
backslash :: Doc
backslash :: Doc
backslash = String -> ByteString -> Doc
unsafeBoth "\\" (Char -> ByteString
BC.singleton '\\')

-- | A 'Doc' that represents @\"(\"@
lparen :: Doc
lparen :: Doc
lparen = String -> ByteString -> Doc
unsafeBoth  "(" (Char -> ByteString
BC.singleton '(')

-- | A 'Doc' that represents @\")\"@
rparen :: Doc
rparen :: Doc
rparen = String -> ByteString -> Doc
unsafeBoth ")" (Char -> ByteString
BC.singleton ')')

-- | prop> parens d = lparen <> d <> rparen
parens :: Doc -> Doc
parens :: Doc -> Doc
parens d :: Doc
d = Doc
lparen Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
d Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
rparen

-- | Fail with a stack trace and the given 'Doc' as error message.
errorDoc :: Doc -> a
errorDoc :: Doc -> a
errorDoc x :: Doc
x = String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ Doc -> String
renderString Doc
x

-- | 'putDocWith' puts a 'Doc' on stdout using the given printer.
putDocWith :: Printers -> Doc -> IO ()
putDocWith :: Printers -> Doc -> IO ()
putDocWith prs :: Printers
prs = Printers -> Handle -> Doc -> IO ()
hPutDocWith Printers
prs Handle
stdout

-- | 'putDocLnWith' puts a 'Doc', followed by a newline on stdout using
-- the given printer.
putDocLnWith :: Printers -> Doc -> IO ()
putDocLnWith :: Printers -> Doc -> IO ()
putDocLnWith prs :: Printers
prs = Printers -> Handle -> Doc -> IO ()
hPutDocLnWith Printers
prs Handle
stdout

-- | 'putDoc' puts a 'Doc' on stdout using the simple printer 'simplePrinters'.
putDoc :: Doc -> IO ()
putDoc :: Doc -> IO ()
putDoc = Handle -> Doc -> IO ()
hPutDoc Handle
stdout

-- | 'putDocLn' puts a 'Doc', followed by a newline on stdout using
-- 'simplePrinters'
putDocLn :: Doc -> IO ()
putDocLn :: Doc -> IO ()
putDocLn = Handle -> Doc -> IO ()
hPutDocLn Handle
stdout

-- | 'eputDocLn' puts a 'Doc', followed by a newline to stderr using
-- 'simplePrinters'. Like putDocLn, it encodes with the user's locale.
-- This function is the recommended way to output messages that should
-- be visible to users on the console, but cannot (or should not) be
-- silenced even when --quiet is in effect.
ePutDocLn :: Doc -> IO ()
ePutDocLn :: Doc -> IO ()
ePutDocLn = Handle -> Doc -> IO ()
hPutDocLn Handle
stderr

-- | 'hputDocWith' puts a 'Doc' on the given handle using the given printer.
hPutDocWith :: Printers -> Handle -> Doc -> IO ()
hPutDocWith :: Printers -> Handle -> Doc -> IO ()
hPutDocWith prs :: Printers
prs h :: Handle
h d :: Doc
d = Handle -> [Printable] -> IO ()
hPrintPrintables Handle
h (Printers' -> Doc -> [Printable]
renderWith (Printers
prs Handle
h) Doc
d)

-- | 'hputDocLnWith' puts a 'Doc', followed by a newline on the given
-- handle using the given printer.
hPutDocLnWith :: Printers -> Handle -> Doc -> IO ()
hPutDocLnWith :: Printers -> Handle -> Doc -> IO ()
hPutDocLnWith prs :: Printers
prs h :: Handle
h d :: Doc
d = Printers -> Handle -> Doc -> IO ()
hPutDocWith Printers
prs Handle
h (Doc
d Doc -> Doc -> Doc
<?> Doc
newline)

-- |'hputDoc' puts a 'Doc' on the given handle using 'simplePrinters'
hPutDoc :: Handle -> Doc -> IO ()
hPutDoc :: Handle -> Doc -> IO ()
hPutDoc = Printers -> Handle -> Doc -> IO ()
hPutDocWith Printers
simplePrinters

-- | 'hputDocLn' puts a 'Doc', followed by a newline on the given handle using
-- 'simplePrinters'.
hPutDocLn :: Handle -> Doc -> IO ()
hPutDocLn :: Handle -> Doc -> IO ()
hPutDocLn = Printers -> Handle -> Doc -> IO ()
hPutDocLnWith Printers
simplePrinters

-- | like 'hPutDoc' but with compress data before writing
hPutDocCompr :: Handle -> Doc -> IO ()
hPutDocCompr :: Handle -> Doc -> IO ()
hPutDocCompr h :: Handle
h = Handle -> [ByteString] -> IO ()
gzWriteHandle Handle
h ([ByteString] -> IO ()) -> (Doc -> [ByteString]) -> Doc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [ByteString]
renderPSs

-- | Write a 'Doc' to stderr if debugging is turned on.
debugDocLn :: Doc -> IO ()
debugDocLn :: Doc -> IO ()
debugDocLn = String -> IO ()
debugMessage (String -> IO ()) -> (Doc -> String) -> Doc -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> String
renderString

-- | @'hPrintPrintables' h@ prints a list of 'Printable's to the handle @h@
-- It uses binary output of 'ByteString's. If these not available,
-- converts according to locale.
hPrintPrintables :: Handle -> [Printable] -> IO ()
hPrintPrintables :: Handle -> [Printable] -> IO ()
hPrintPrintables h :: Handle
h = (Printable -> IO ()) -> [Printable] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Handle -> Printable -> IO ()
hPrintPrintable Handle
h)

-- | @'hPrintPrintable' h@ prints a 'Printable' to the handle @h@.
hPrintPrintable :: Handle -> Printable -> IO ()
hPrintPrintable :: Handle -> Printable -> IO ()
hPrintPrintable h :: Handle
h (S ps :: String
ps) = Handle -> ByteString -> IO ()
B.hPut Handle
h (String -> ByteString
encodeLocale String
ps)
hPrintPrintable h :: Handle
h (PS ps :: ByteString
ps) = Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
ps
hPrintPrintable h :: Handle
h (Both _ ps :: ByteString
ps) = Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
ps

-- | A 'Doc' is a bit of enriched text. 'Doc's are concatenated using
-- '<>' from class 'Monoid', which is right-associative.
newtype Doc = Doc { Doc -> St -> Document
unDoc :: St -> Document }

-- | Together with the language extension OverloadedStrings, this allows to
-- use string literals where a 'Doc' is expected.
instance IsString Doc where
   fromString :: String -> Doc
fromString = String -> Doc
text

-- | The State associated with a 'Doc'. Contains a set of printers for each
-- hanlde, and the current prefix of the document.
data St = St { St -> Printers'
printers :: !Printers',
               St -> [Printable] -> [Printable]
currentPrefix :: !([Printable] -> [Printable]) }
type Printers = Handle -> Printers'

-- | A set of printers to print different types of text to a handle.
data Printers' = Printers {Printers' -> Color -> Printer
colorP :: !(Color -> Printer),
                           Printers' -> Printer
invisibleP :: !Printer,
                           Printers' -> Printer
hiddenP :: !Printer,
                           Printers' -> Printer
userchunkP :: !Printer,
                           Printers' -> Printer
defP :: !Printer,
                           Printers' -> Color -> Doc -> Doc
lineColorT :: !(Color -> Doc -> Doc),
                           Printers' -> [Printable] -> [Printable]
lineColorS :: !([Printable] -> [Printable])
                          }
type Printer = Printable -> St -> Document

data Color = Blue | Red | Green | Cyan | Magenta

-- | 'Document' is a wrapper around '[Printable] -> [Printable]' which allows
-- to handle the special case of an empty 'Document' in a non-uniform manner.
-- The simplest 'Documents' are built from 'String's using 'text'.
data Document = Document ([Printable] -> [Printable])
              | Empty

-- | renders a 'Doc' into a 'String' with control codes for the
-- special features of the 'Doc'.
renderString :: Doc -> String
renderString :: Doc -> String
renderString = Printers' -> Doc -> String
renderStringWith Printers'
simplePrinters'

-- | renders a 'Doc' into a 'String' using a given set of printers.
-- If content is only available as 'ByteString', decode according to
-- the current locale.
renderStringWith :: Printers' -> Doc -> String
renderStringWith :: Printers' -> Doc -> String
renderStringWith prs :: Printers'
prs d :: Doc
d = (Printable -> String) -> [Printable] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Printable -> String
toString) ([Printable] -> String) -> [Printable] -> String
forall a b. (a -> b) -> a -> b
$ Printers' -> Doc -> [Printable]
renderWith Printers'
prs Doc
d
    where toString :: Printable -> String
toString (S s :: String
s) = String
s
          toString (PS ps :: ByteString
ps) = ByteString -> String
decodeLocale ByteString
ps
          toString (Both s :: String
s _) = String
s

-- | renders a 'Doc' into 'B.ByteString' with control codes for the
-- special features of the Doc. See also 'readerString'.
renderPS :: Doc -> B.ByteString
renderPS :: Doc -> ByteString
renderPS = Printers' -> Doc -> ByteString
renderPSWith Printers'
simplePrinters'

-- | renders a 'Doc' into a list of 'PackedStrings', one for each line.
renderPSs :: Doc -> [B.ByteString]
renderPSs :: Doc -> [ByteString]
renderPSs = Printers' -> Doc -> [ByteString]
renderPSsWith Printers'
simplePrinters'

-- | renders a 'Doc' into a 'B.ByteString' using a given set of printers.
renderPSWith :: Printers' -> Doc -> B.ByteString
renderPSWith :: Printers' -> Doc -> ByteString
renderPSWith prs :: Printers'
prs d :: Doc
d = [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ Printers' -> Doc -> [ByteString]
renderPSsWith Printers'
prs Doc
d

-- | renders a 'Doc' into a list of 'PackedStrings', one for each
-- chunk of text that was added to the 'Doc', using the given set of
-- printers.
renderPSsWith :: Printers' -> Doc -> [B.ByteString]
renderPSsWith :: Printers' -> Doc -> [ByteString]
renderPSsWith prs :: Printers'
prs d :: Doc
d = (Printable -> ByteString) -> [Printable] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Printable -> ByteString
toPS ([Printable] -> [ByteString]) -> [Printable] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Printers' -> Doc -> [Printable]
renderWith Printers'
prs Doc
d
    where toPS :: Printable -> ByteString
toPS (S s :: String
s)        = String -> ByteString
encodeLocale String
s
          toPS (PS ps :: ByteString
ps)      = ByteString
ps
          toPS (Both _ ps :: ByteString
ps)  = ByteString
ps

-- | renders a 'Doc' into a list of 'Printables' using a set of
-- printers. Each item of the list corresponds to a string that was
-- added to the 'Doc'.
renderWith :: Printers' -> Doc -> [Printable]
renderWith :: Printers' -> Doc -> [Printable]
renderWith ps :: Printers'
ps (Doc d :: St -> Document
d) = case St -> Document
d (Printers' -> St
initState Printers'
ps) of
                        Empty -> []
                        Document f :: [Printable] -> [Printable]
f -> [Printable] -> [Printable]
f []

initState :: Printers' -> St
initState :: Printers' -> St
initState prs :: Printers'
prs = $WSt :: Printers' -> ([Printable] -> [Printable]) -> St
St { printers :: Printers'
printers = Printers'
prs, currentPrefix :: [Printable] -> [Printable]
currentPrefix = [Printable] -> [Printable]
forall a. a -> a
id }

prefix :: String -> Doc -> Doc
prefix :: String -> Doc -> Doc
prefix s :: String
s (Doc d :: St -> Document
d) = (St -> Document) -> Doc
Doc ((St -> Document) -> Doc) -> (St -> Document) -> Doc
forall a b. (a -> b) -> a -> b
$ \st :: St
st ->
                   let p :: Printable
p = String -> Printable
S String
s
                       st' :: St
st' = St
st { currentPrefix :: [Printable] -> [Printable]
currentPrefix = St -> [Printable] -> [Printable]
currentPrefix St
st ([Printable] -> [Printable])
-> ([Printable] -> [Printable]) -> [Printable] -> [Printable]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Printable
pPrintable -> [Printable] -> [Printable]
forall a. a -> [a] -> [a]
:) } in
                   case St -> Document
d St
st' of
                     Document d'' :: [Printable] -> [Printable]
d'' -> ([Printable] -> [Printable]) -> Document
Document (([Printable] -> [Printable]) -> Document)
-> ([Printable] -> [Printable]) -> Document
forall a b. (a -> b) -> a -> b
$ (Printable
pPrintable -> [Printable] -> [Printable]
forall a. a -> [a] -> [a]
:) ([Printable] -> [Printable])
-> ([Printable] -> [Printable]) -> [Printable] -> [Printable]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Printable] -> [Printable]
d''
                     Empty -> Document
Empty

-- TODO try to find another way to do this, it's rather a violation
-- of the Doc abstraction
prefixLines :: Doc -> Doc -> Doc
prefixLines :: Doc -> Doc -> Doc
prefixLines prefixer :: Doc
prefixer prefixee :: Doc
prefixee =
  [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Doc -> Doc) -> [Doc] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Doc
prefixer Doc -> Doc -> Doc
<+>) ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (ByteString -> Doc) -> [ByteString] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Doc
packedString ([ByteString] -> [Doc]) -> [ByteString] -> [Doc]
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
linesPS (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Doc -> ByteString
renderPS Doc
prefixee

-- TODO try to find another way to do this, it's rather a violation
-- of the Doc abstraction
insertBeforeLastline :: Doc -> Doc -> Doc
insertBeforeLastline :: Doc -> Doc -> Doc
insertBeforeLastline a :: Doc
a b :: Doc
b =
  case [Doc] -> [Doc]
forall a. [a] -> [a]
reverse ([Doc] -> [Doc]) -> [Doc] -> [Doc]
forall a b. (a -> b) -> a -> b
$ (ByteString -> Doc) -> [ByteString] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Doc
packedString ([ByteString] -> [Doc]) -> [ByteString] -> [Doc]
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
linesPS (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Doc -> ByteString
renderPS Doc
a of
    (ll :: Doc
ll:ls :: [Doc]
ls) -> [Doc] -> Doc
vcat ([Doc] -> [Doc]
forall a. [a] -> [a]
reverse [Doc]
ls) Doc -> Doc -> Doc
$$ Doc
b Doc -> Doc -> Doc
$$ Doc
ll
    [] ->
      String -> Doc
forall a. HasCallStack => String -> a
error "empty Doc given as first argument of Printer.insert_before_last_line"

lineColor :: Color -> Doc -> Doc
lineColor :: Color -> Doc -> Doc
lineColor c :: Color
c d :: Doc
d = (St -> Document) -> Doc
Doc ((St -> Document) -> Doc) -> (St -> Document) -> Doc
forall a b. (a -> b) -> a -> b
$ \st :: St
st -> case Printers' -> Color -> Doc -> Doc
lineColorT (St -> Printers'
printers St
st) Color
c Doc
d of
                             Doc d' :: St -> Document
d' -> St -> Document
d' St
st

hiddenPrefix :: String -> Doc -> Doc
hiddenPrefix :: String -> Doc -> Doc
hiddenPrefix s :: String
s (Doc d :: St -> Document
d) =
    (St -> Document) -> Doc
Doc ((St -> Document) -> Doc) -> (St -> Document) -> Doc
forall a b. (a -> b) -> a -> b
$ \st :: St
st -> let pr :: Printers'
pr = St -> Printers'
printers St
st
                     p :: Printable
p = String -> Printable
S (Printers' -> Doc -> String
renderStringWith Printers'
pr (Doc -> String) -> Doc -> String
forall a b. (a -> b) -> a -> b
$ String -> Doc
hiddenText String
s)
                     st' :: St
st' = St
st { currentPrefix :: [Printable] -> [Printable]
currentPrefix = St -> [Printable] -> [Printable]
currentPrefix St
st ([Printable] -> [Printable])
-> ([Printable] -> [Printable]) -> [Printable] -> [Printable]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Printable
pPrintable -> [Printable] -> [Printable]
forall a. a -> [a] -> [a]
:) }
                 in case St -> Document
d St
st' of
                      Document d'' :: [Printable] -> [Printable]
d'' -> ([Printable] -> [Printable]) -> Document
Document (([Printable] -> [Printable]) -> Document)
-> ([Printable] -> [Printable]) -> Document
forall a b. (a -> b) -> a -> b
$ (Printable
pPrintable -> [Printable] -> [Printable]
forall a. a -> [a] -> [a]
:) ([Printable] -> [Printable])
-> ([Printable] -> [Printable]) -> [Printable] -> [Printable]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Printable] -> [Printable]
d''
                      Empty -> Document
Empty

-- | 'unsafeBoth' builds a Doc from a 'String' and a 'B.ByteString' representing
-- the same text, but does not check that they do.
unsafeBoth :: String -> B.ByteString -> Doc
unsafeBoth :: String -> ByteString -> Doc
unsafeBoth s :: String
s ps :: ByteString
ps = (St -> Document) -> Doc
Doc ((St -> Document) -> Doc) -> (St -> Document) -> Doc
forall a b. (a -> b) -> a -> b
$ Printer
simplePrinter (String -> ByteString -> Printable
Both String
s ByteString
ps)

-- | 'unsafeBothText' builds a 'Doc' from a 'String'. The string is stored in the
-- Doc as both a String and a 'B.ByteString'.
unsafeBothText :: String -> Doc
unsafeBothText :: String -> Doc
unsafeBothText s :: String
s = (St -> Document) -> Doc
Doc ((St -> Document) -> Doc) -> (St -> Document) -> Doc
forall a b. (a -> b) -> a -> b
$ Printer
simplePrinter (String -> ByteString -> Printable
Both String
s (String -> ByteString
encodeLocale String
s))

-- | 'packedString' builds a 'Doc' from a 'B.ByteString' using 'printable'
packedString :: B.ByteString -> Doc
packedString :: ByteString -> Doc
packedString = Printable -> Doc
printable (Printable -> Doc)
-> (ByteString -> Printable) -> ByteString -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Printable
PS

-- | 'unsafePackedString' builds a 'Doc' from a 'B.ByteString' using 'simplePrinter'
unsafePackedString :: B.ByteString -> Doc
unsafePackedString :: ByteString -> Doc
unsafePackedString = (St -> Document) -> Doc
Doc ((St -> Document) -> Doc)
-> (ByteString -> St -> Document) -> ByteString -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Printer
simplePrinter Printer
-> (ByteString -> Printable) -> ByteString -> St -> Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Printable
PS

-- | 'invisiblePS' creates a 'Doc' with invisible text from a 'B.ByteString'
invisiblePS :: B.ByteString -> Doc
invisiblePS :: ByteString -> Doc
invisiblePS = Printable -> Doc
invisiblePrintable (Printable -> Doc)
-> (ByteString -> Printable) -> ByteString -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Printable
PS

-- | 'userchunkPS' creates a 'Doc' representing a user chunk from a 'B.ByteString'.
--
-- Rrrright. And what, please is that supposed to mean?
userchunkPS :: B.ByteString -> Doc
userchunkPS :: ByteString -> Doc
userchunkPS = Printable -> Doc
userchunkPrintable (Printable -> Doc)
-> (ByteString -> Printable) -> ByteString -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Printable
PS

-- | 'unsafeChar' creates a Doc containing just one character.
unsafeChar :: Char -> Doc
unsafeChar :: Char -> Doc
unsafeChar = String -> Doc
unsafeText (String -> Doc) -> (Char -> String) -> Char -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> String -> String
forall a. a -> [a] -> [a]
:"")

-- | 'text' creates a 'Doc' from a @String@, using 'printable'.
text :: String -> Doc
text :: String -> Doc
text = Printable -> Doc
printable (Printable -> Doc) -> (String -> Printable) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Printable
S

-- | 'unsafeText' creates a 'Doc' from a 'String', using 'simplePrinter' directly
unsafeText :: String -> Doc
unsafeText :: String -> Doc
unsafeText = (St -> Document) -> Doc
Doc ((St -> Document) -> Doc)
-> (String -> St -> Document) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Printer
simplePrinter Printer -> (String -> Printable) -> String -> St -> Document
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Printable
S

-- | 'invisibleText' creates a 'Doc' containing invisible text from a @String@
invisibleText :: String -> Doc
invisibleText :: String -> Doc
invisibleText = Printable -> Doc
invisiblePrintable (Printable -> Doc) -> (String -> Printable) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Printable
S

-- | 'hiddenText' creates a 'Doc' containing hidden text from a @String@
hiddenText :: String -> Doc
hiddenText :: String -> Doc
hiddenText = Printable -> Doc
hiddenPrintable (Printable -> Doc) -> (String -> Printable) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Printable
S

-- | 'userchunk' creates a 'Doc' containing a user chunk from a @String@
userchunk :: String -> Doc
userchunk :: String -> Doc
userchunk = Printable -> Doc
userchunkPrintable (Printable -> Doc) -> (String -> Printable) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Printable
S

blueText, redText, greenText, magentaText, cyanText :: String -> Doc
blueText :: String -> Doc
blueText = Color -> String -> Doc
colorText Color
Blue
redText :: String -> Doc
redText = Color -> String -> Doc
colorText Color
Red
greenText :: String -> Doc
greenText = Color -> String -> Doc
colorText Color
Green
magentaText :: String -> Doc
magentaText = Color -> String -> Doc
colorText Color
Magenta
cyanText :: String -> Doc
cyanText = Color -> String -> Doc
colorText Color
Cyan

-- | 'colorText' creates a 'Doc' containing colored text from a @String@
colorText :: Color -> String -> Doc
colorText :: Color -> String -> Doc
colorText c :: Color
c = Color -> Printable -> Doc
mkColorPrintable Color
c (Printable -> Doc) -> (String -> Printable) -> String -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Printable
S

-- | @'wrapText' n s@ is a 'Doc' representing @s@ line-wrapped at 'n' characters
wrapText :: Int -> String -> Doc
wrapText :: Int -> String -> Doc
wrapText n :: Int
n s :: String
s =
    [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([String] -> [Doc]) -> [String] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Doc) -> [String] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map String -> Doc
text ([String] -> [Doc]) -> ([String] -> [String]) -> [String] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> [String]
forall a. [a] -> [a]
reverse ([String] -> Doc) -> [String] -> Doc
forall a b. (a -> b) -> a -> b
$ "" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: ([String] -> String -> [String])
-> [String] -> [String] -> [String]
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl [String] -> String -> [String]
add_to_line [] (String -> [String]
words String
s)
  where add_to_line :: [String] -> String -> [String]
add_to_line [] a :: String
a = [String
a]
        add_to_line ("":d :: [String]
d) a :: String
a = String
aString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
d
        add_to_line (l :: String
l:ls :: [String]
ls) new :: String
new | String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
new Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
n = String
newString -> [String] -> [String]
forall a. a -> [a] -> [a]
:String
lString -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
ls
        add_to_line (l :: String
l:ls :: [String]
ls) new :: String
new = (String
l String -> String -> String
forall a. [a] -> [a] -> [a]
++ " " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
new)String -> [String] -> [String]
forall a. a -> [a] -> [a]
:[String]
ls

-- | Creates a 'Doc' from any 'Printable'.
printable :: Printable -> Doc
printable :: Printable -> Doc
printable x :: Printable
x = (St -> Document) -> Doc
Doc ((St -> Document) -> Doc) -> (St -> Document) -> Doc
forall a b. (a -> b) -> a -> b
$ \st :: St
st -> Printers' -> Printer
defP (St -> Printers'
printers St
st) Printable
x St
st

mkColorPrintable :: Color -> Printable -> Doc
mkColorPrintable :: Color -> Printable -> Doc
mkColorPrintable c :: Color
c x :: Printable
x = (St -> Document) -> Doc
Doc ((St -> Document) -> Doc) -> (St -> Document) -> Doc
forall a b. (a -> b) -> a -> b
$ \st :: St
st -> Printers' -> Color -> Printer
colorP (St -> Printers'
printers St
st) Color
c Printable
x St
st

-- | Creates an invisible 'Doc' from any 'Printable'.
invisiblePrintable :: Printable -> Doc
invisiblePrintable :: Printable -> Doc
invisiblePrintable x :: Printable
x = (St -> Document) -> Doc
Doc ((St -> Document) -> Doc) -> (St -> Document) -> Doc
forall a b. (a -> b) -> a -> b
$ \st :: St
st -> Printers' -> Printer
invisibleP (St -> Printers'
printers St
st) Printable
x St
st

-- | Creates a hidden 'Doc' from any 'Printable'.
hiddenPrintable :: Printable -> Doc
hiddenPrintable :: Printable -> Doc
hiddenPrintable x :: Printable
x = (St -> Document) -> Doc
Doc ((St -> Document) -> Doc) -> (St -> Document) -> Doc
forall a b. (a -> b) -> a -> b
$ \st :: St
st -> Printers' -> Printer
hiddenP (St -> Printers'
printers St
st) Printable
x St
st

-- | Creates... WTF is a userchunk???
userchunkPrintable :: Printable -> Doc
userchunkPrintable :: Printable -> Doc
userchunkPrintable x :: Printable
x = (St -> Document) -> Doc
Doc ((St -> Document) -> Doc) -> (St -> Document) -> Doc
forall a b. (a -> b) -> a -> b
$ \st :: St
st -> Printers' -> Printer
userchunkP (St -> Printers'
printers St
st) Printable
x St
st

-- | 'simplePrinters' is a 'Printers' which uses the set 'simplePriners\'' on any
-- handle.
simplePrinters :: Printers
simplePrinters :: Printers
simplePrinters _ = Printers'
simplePrinters'

-- | A set of default printers suitable for any handle. Does not use color.
simplePrinters' :: Printers'
simplePrinters' :: Printers'
simplePrinters'  = $WPrinters :: (Color -> Printer)
-> Printer
-> Printer
-> Printer
-> Printer
-> (Color -> Doc -> Doc)
-> ([Printable] -> [Printable])
-> Printers'
Printers { colorP :: Color -> Printer
colorP = Printer -> Color -> Printer
forall a b. a -> b -> a
const Printer
simplePrinter,
                              invisibleP :: Printer
invisibleP = Printer
simplePrinter,
                              hiddenP :: Printer
hiddenP = Printer
invisiblePrinter,
                              userchunkP :: Printer
userchunkP = Printer
simplePrinter,
                              defP :: Printer
defP = Printer
simplePrinter,
                              lineColorT :: Color -> Doc -> Doc
lineColorT = (Doc -> Doc) -> Color -> Doc -> Doc
forall a b. a -> b -> a
const Doc -> Doc
forall a. a -> a
id,
                              lineColorS :: [Printable] -> [Printable]
lineColorS = [Printable] -> [Printable]
forall a. a -> a
id
                            }

-- | 'simplePrinter' is the simplest 'Printer': it just concatenates together
-- the pieces of the 'Doc'
simplePrinter :: Printer
simplePrinter :: Printer
simplePrinter x :: Printable
x = Doc -> St -> Document
unDoc (Doc -> St -> Document) -> Doc -> St -> Document
forall a b. (a -> b) -> a -> b
$ ([Printable] -> [Printable]) -> Doc
doc (\s :: [Printable]
s -> Printable
xPrintable -> [Printable] -> [Printable]
forall a. a -> [a] -> [a]
:[Printable]
s)

-- | 'invisiblePrinter' is the 'Printer' for hidden text. It just replaces
-- the document with 'empty'.  It's useful to have a printer that doesn't
-- actually do anything because this allows you to have tunable policies,
-- for example, only printing some text if it's to the terminal, but not
-- if it's to a file or vice-versa.
invisiblePrinter :: Printer
invisiblePrinter :: Printer
invisiblePrinter _ = Doc -> St -> Document
unDoc Doc
empty

infixr 6 `append`
infixr 6 <+>
infixr 5 `vplus`
infixr 5 $$

-- | The empty 'Doc'
empty :: Doc
empty :: Doc
empty = (St -> Document) -> Doc
Doc ((St -> Document) -> Doc) -> (St -> Document) -> Doc
forall a b. (a -> b) -> a -> b
$ Document -> St -> Document
forall a b. a -> b -> a
const Document
Empty

doc :: ([Printable] -> [Printable]) -> Doc
doc :: ([Printable] -> [Printable]) -> Doc
doc f :: [Printable] -> [Printable]
f = (St -> Document) -> Doc
Doc ((St -> Document) -> Doc) -> (St -> Document) -> Doc
forall a b. (a -> b) -> a -> b
$ Document -> St -> Document
forall a b. a -> b -> a
const (Document -> St -> Document) -> Document -> St -> Document
forall a b. (a -> b) -> a -> b
$ ([Printable] -> [Printable]) -> Document
Document [Printable] -> [Printable]
f

instance Semigroup Doc where
  <> :: Doc -> Doc -> Doc
(<>) = Doc -> Doc -> Doc
append

-- | 'mappend' ('<>') is concatenation, 'mempty' is the 'empty' 'Doc'
instance Monoid Doc where
  mempty :: Doc
mempty = Doc
empty
  mappend :: Doc -> Doc -> Doc
mappend = Doc -> Doc -> Doc
append

-- | Concatenation of two 'Doc's
append :: Doc -> Doc -> Doc
Doc a :: St -> Document
a append :: Doc -> Doc -> Doc
`append` Doc b :: St -> Document
b =
   (St -> Document) -> Doc
Doc ((St -> Document) -> Doc) -> (St -> Document) -> Doc
forall a b. (a -> b) -> a -> b
$ \st :: St
st -> case St -> Document
a St
st of
                Empty -> St -> Document
b St
st
                Document af :: [Printable] -> [Printable]
af ->
                    ([Printable] -> [Printable]) -> Document
Document (\s :: [Printable]
s -> [Printable] -> [Printable]
af ([Printable] -> [Printable]) -> [Printable] -> [Printable]
forall a b. (a -> b) -> a -> b
$ case St -> Document
b St
st of
                                         Empty -> [Printable]
s
                                         Document bf :: [Printable] -> [Printable]
bf -> [Printable] -> [Printable]
bf [Printable]
s)

-- | @a '<?>' b@ is @a '<>' b@ if @a@ is not empty, else empty
(<?>) :: Doc -> Doc -> Doc
Doc a :: St -> Document
a <?> :: Doc -> Doc -> Doc
<?> Doc b :: St -> Document
b =
    (St -> Document) -> Doc
Doc ((St -> Document) -> Doc) -> (St -> Document) -> Doc
forall a b. (a -> b) -> a -> b
$ \st :: St
st -> case St -> Document
a St
st of
                 Empty -> Document
Empty
                 Document af :: [Printable] -> [Printable]
af -> ([Printable] -> [Printable]) -> Document
Document (\s :: [Printable]
s -> [Printable] -> [Printable]
af ([Printable] -> [Printable]) -> [Printable] -> [Printable]
forall a b. (a -> b) -> a -> b
$ case St -> Document
b St
st of
                                                     Empty -> [Printable]
s
                                                     Document bf :: [Printable] -> [Printable]
bf -> [Printable] -> [Printable]
bf [Printable]
s)

-- | @a '<+>' b@ is @a@ followed by @b@ with a space in between if both are non-empty
(<+>) :: Doc -> Doc -> Doc
Doc a :: St -> Document
a <+> :: Doc -> Doc -> Doc
<+> Doc b :: St -> Document
b =
    (St -> Document) -> Doc
Doc ((St -> Document) -> Doc) -> (St -> Document) -> Doc
forall a b. (a -> b) -> a -> b
$ \st :: St
st -> case St -> Document
a St
st of
                 Empty -> St -> Document
b St
st
                 Document af :: [Printable] -> [Printable]
af -> ([Printable] -> [Printable]) -> Document
Document (\s :: [Printable]
s -> [Printable] -> [Printable]
af ([Printable] -> [Printable]) -> [Printable] -> [Printable]
forall a b. (a -> b) -> a -> b
$ case St -> Document
b St
st of
                                                     Empty -> [Printable]
s
                                                     Document bf :: [Printable] -> [Printable]
bf ->
                                                         Printable
spacePPrintable -> [Printable] -> [Printable]
forall a. a -> [a] -> [a]
:[Printable] -> [Printable]
bf [Printable]
s)

-- | @a '$$' b@ is @a@ above @b@
($$) :: Doc -> Doc -> Doc
Doc a :: St -> Document
a $$ :: Doc -> Doc -> Doc
$$ Doc b :: St -> Document
b =
   (St -> Document) -> Doc
Doc ((St -> Document) -> Doc) -> (St -> Document) -> Doc
forall a b. (a -> b) -> a -> b
$ \st :: St
st -> case St -> Document
a St
st of
                Empty -> St -> Document
b St
st
                Document af :: [Printable] -> [Printable]
af ->
                    ([Printable] -> [Printable]) -> Document
Document (\s :: [Printable]
s -> [Printable] -> [Printable]
af ([Printable] -> [Printable]) -> [Printable] -> [Printable]
forall a b. (a -> b) -> a -> b
$ case St -> Document
b St
st of
                                         Empty -> [Printable]
s
                                         Document bf :: [Printable] -> [Printable]
bf -> [Printable] -> [Printable]
sf (Printable
newlinePPrintable -> [Printable] -> [Printable]
forall a. a -> [a] -> [a]
:[Printable] -> [Printable]
pf ([Printable] -> [Printable]
bf [Printable]
s)))
                        where pf :: [Printable] -> [Printable]
pf = St -> [Printable] -> [Printable]
currentPrefix St
st
                              sf :: [Printable] -> [Printable]
sf = Printers' -> [Printable] -> [Printable]
lineColorS (Printers' -> [Printable] -> [Printable])
-> Printers' -> [Printable] -> [Printable]
forall a b. (a -> b) -> a -> b
$ St -> Printers'
printers St
st

-- | @vplus a b@ is @a@ above @b@ with an empty line in between if both are non-empty
vplus :: Doc -> Doc -> Doc
Doc a :: St -> Document
a vplus :: Doc -> Doc -> Doc
`vplus` Doc b :: St -> Document
b =
   (St -> Document) -> Doc
Doc ((St -> Document) -> Doc) -> (St -> Document) -> Doc
forall a b. (a -> b) -> a -> b
$ \st :: St
st -> case St -> Document
a St
st of
                Empty -> St -> Document
b St
st
                Document af :: [Printable] -> [Printable]
af ->
                    ([Printable] -> [Printable]) -> Document
Document (\s :: [Printable]
s -> [Printable] -> [Printable]
af ([Printable] -> [Printable]) -> [Printable] -> [Printable]
forall a b. (a -> b) -> a -> b
$ case St -> Document
b St
st of
                                         Empty -> [Printable]
s
                                         Document bf :: [Printable] -> [Printable]
bf -> [Printable] -> [Printable]
sf (Printable
newlinePPrintable -> [Printable] -> [Printable]
forall a. a -> [a] -> [a]
:Printable
newlinePPrintable -> [Printable] -> [Printable]
forall a. a -> [a] -> [a]
:[Printable] -> [Printable]
pf ([Printable] -> [Printable]
bf [Printable]
s)))
                        where pf :: [Printable] -> [Printable]
pf = St -> [Printable] -> [Printable]
currentPrefix St
st
                              sf :: [Printable] -> [Printable]
sf = Printers' -> [Printable] -> [Printable]
lineColorS (Printers' -> [Printable] -> [Printable])
-> Printers' -> [Printable] -> [Printable]
forall a b. (a -> b) -> a -> b
$ St -> Printers'
printers St
st

-- | Pile 'Doc's vertically
vcat :: [Doc] -> Doc
vcat :: [Doc] -> Doc
vcat = (Doc -> Doc -> Doc) -> Doc -> [Doc] -> Doc
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Doc -> Doc -> Doc
($$) Doc
empty

-- | Pile 'Doc's vertically, with a blank line in between
vsep :: [Doc] -> Doc
vsep :: [Doc] -> Doc
vsep = (Doc -> Doc -> Doc) -> Doc -> [Doc] -> Doc
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Doc -> Doc -> Doc
vplus Doc
empty

-- | Concatenate 'Doc's horizontally
hcat :: [Doc] -> Doc
hcat :: [Doc] -> Doc
hcat = [Doc] -> Doc
forall a. Monoid a => [a] -> a
mconcat

-- | Concatenate 'Doc's horizontally with a space as separator
hsep :: [Doc] -> Doc
hsep :: [Doc] -> Doc
hsep = (Doc -> Doc -> Doc) -> Doc -> [Doc] -> Doc
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Doc -> Doc -> Doc
(<+>) Doc
empty

-- | Quote a string for screen output
quoted :: String -> Doc
quoted :: String -> Doc
quoted s :: String
s = String -> Doc
text "\"" Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text (String -> String
escape String
s) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> String -> Doc
text "\""
  where
    escape :: String -> String
escape "" = ""
    escape (c :: Char
c:cs :: String
cs) = if Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ['\\', '"']
                       then '\\' Char -> String -> String
forall a. a -> [a] -> [a]
: Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
escape String
cs
                       else Char
c Char -> String -> String
forall a. a -> [a] -> [a]
: String -> String
escape String
cs