module Text.Pandoc.Pretty (
Doc
, render
, cr
, blankline
, space
, text
, char
, prefixed
, flush
, nest
, hang
, nowrap
, offset
, height
, lblock
, cblock
, rblock
, (<>)
, (<+>)
, ($$)
, ($+$)
, isEmpty
, empty
, cat
, hcat
, hsep
, vcat
, vsep
, inside
, braces
, brackets
, parens
, quotes
, doubleQuotes
)
where
import Data.DList (DList, fromList, toList, cons, singleton)
import Data.List (intercalate)
import Data.Monoid
import Data.String
import Control.Monad.State
import Data.Char (isSpace)
data Monoid a =>
RenderState a = RenderState{
output :: [a]
, prefix :: String
, usePrefix :: Bool
, lineLength :: Maybe Int
, column :: Int
, newlines :: Int
}
type DocState a = State (RenderState a) ()
data D = Text Int String
| Block Int [String]
| Prefixed String Doc
| Flush Doc
| BreakingSpace
| CarriageReturn
| NewLine
| BlankLine
deriving (Show)
newtype Doc = Doc { unDoc :: DList D }
deriving (Monoid)
instance Show Doc where
show = render Nothing
instance IsString Doc where
fromString = text
isEmpty :: Doc -> Bool
isEmpty = null . toList . unDoc
empty :: Doc
empty = mempty
(<>) :: Doc -> Doc -> Doc
(<>) = mappend
cat :: [Doc] -> Doc
cat = mconcat
hcat :: [Doc] -> Doc
hcat = mconcat
(<+>) :: Doc -> Doc -> Doc
(<+>) x y = if isEmpty x
then y
else if isEmpty y
then x
else x <> space <> y
hsep :: [Doc] -> Doc
hsep = foldr (<+>) empty
($$) :: Doc -> Doc -> Doc
($$) x y = if isEmpty x
then y
else if isEmpty y
then x
else x <> cr <> y
($+$) :: Doc -> Doc -> Doc
($+$) x y = if isEmpty x
then y
else if isEmpty y
then x
else x <> blankline <> y
vcat :: [Doc] -> Doc
vcat = foldr ($$) empty
vsep :: [Doc] -> Doc
vsep = foldr ($+$) empty
outp :: (IsString a, Monoid a)
=> Int -> String -> DocState a
outp off s | off <= 0 = do
st' <- get
let rawpref = prefix st'
when (column st' == 0 && usePrefix st' && not (null rawpref)) $ do
let pref = reverse $ dropWhile isSpace $ reverse rawpref
modify $ \st -> st{ output = fromString pref : output st
, column = column st + length pref }
when (off < 0) $ do
modify $ \st -> st { output = fromString s : output st
, column = 0
, newlines = newlines st + 1 }
outp off s = do
st' <- get
let pref = prefix st'
when (column st' == 0 && usePrefix st' && not (null pref)) $ do
modify $ \st -> st{ output = fromString pref : output st
, column = column st + length pref }
modify $ \st -> st{ output = fromString s : output st
, column = column st + off
, newlines = 0 }
render :: (Monoid a, IsString a)
=> Maybe Int -> Doc -> a
render linelen doc = fromString . mconcat . reverse . output $
execState (renderDoc doc) startingState
where startingState = RenderState{
output = mempty
, prefix = ""
, usePrefix = True
, lineLength = linelen
, column = 0
, newlines = 2 }
renderDoc :: (IsString a, Monoid a)
=> Doc -> DocState a
renderDoc = renderList . toList . unDoc
renderList :: (IsString a, Monoid a)
=> [D] -> DocState a
renderList [] = return ()
renderList (Text off s : xs) = do
outp off s
renderList xs
renderList (Prefixed pref d : xs) = do
st <- get
let oldPref = prefix st
put st{ prefix = prefix st ++ pref }
renderDoc d
modify $ \s -> s{ prefix = oldPref }
renderList xs
renderList (Flush d : xs) = do
st <- get
let oldUsePrefix = usePrefix st
put st{ usePrefix = False }
renderDoc d
modify $ \s -> s{ usePrefix = oldUsePrefix }
renderList xs
renderList (BlankLine : xs) = do
st <- get
case output st of
_ | newlines st > 1 || null xs -> return ()
_ | column st == 0 -> do
outp (1) "\n"
_ -> do
outp (1) "\n"
outp (1) "\n"
renderList xs
renderList (CarriageReturn : xs) = do
st <- get
if newlines st > 0 || null xs
then renderList xs
else do
outp (1) "\n"
renderList xs
renderList (NewLine : xs) = do
outp (1) "\n"
renderList xs
renderList (BreakingSpace : CarriageReturn : xs) = renderList (CarriageReturn:xs)
renderList (BreakingSpace : NewLine : xs) = renderList (NewLine:xs)
renderList (BreakingSpace : BlankLine : xs) = renderList (BlankLine:xs)
renderList (BreakingSpace : BreakingSpace : xs) = renderList (BreakingSpace:xs)
renderList (BreakingSpace : xs) = do
let isText (Text _ _) = True
isText (Block _ _) = True
isText _ = False
let isBreakingSpace BreakingSpace = True
isBreakingSpace _ = False
let xs' = dropWhile isBreakingSpace xs
let next = takeWhile isText xs'
st <- get
let off = sum $ map offsetOf next
case lineLength st of
Just l | column st + 1 + off > l -> do
outp (1) "\n"
renderList xs'
_ -> do
outp 1 " "
renderList xs'
renderList (b1@Block{} : b2@Block{} : xs) =
renderList (mergeBlocks False b1 b2 : xs)
renderList (b1@Block{} : BreakingSpace : b2@Block{} : xs) =
renderList (mergeBlocks True b1 b2 : xs)
renderList (Block width lns : xs) = do
st <- get
let oldPref = prefix st
case column st length oldPref of
n | n > 0 -> modify $ \s -> s{ prefix = oldPref ++ replicate n ' ' }
_ -> return ()
renderDoc $ blockToDoc width lns
modify $ \s -> s{ prefix = oldPref }
renderList xs
mergeBlocks :: Bool -> D -> D -> D
mergeBlocks addSpace (Block w1 lns1) (Block w2 lns2) =
Block (w1 + w2 + if addSpace then 1 else 0) $
zipWith (\l1 l2 -> pad w1 l1 ++ l2) (lns1 ++ empties) (map sp lns2 ++ empties)
where empties = replicate (abs $ length lns1 length lns2) ""
pad n s = s ++ replicate (n length s) ' '
sp "" = ""
sp xs = if addSpace then (' ' : xs) else xs
mergeBlocks _ _ _ = error "mergeBlocks tried on non-Block!"
blockToDoc :: Int -> [String] -> Doc
blockToDoc _ lns = text $ intercalate "\n" lns
offsetOf :: D -> Int
offsetOf (Text o _) = o
offsetOf (Block w _) = w
offsetOf BreakingSpace = 1
offsetOf _ = 0
text :: String -> Doc
text = Doc . toChunks
where toChunks :: String -> DList D
toChunks [] = mempty
toChunks s = case break (=='\n') s of
([], _:ys) -> NewLine `cons` toChunks ys
(xs, _:ys) -> Text (length xs) xs `cons`
NewLine `cons` toChunks ys
(xs, []) -> singleton $ Text (length xs) xs
char :: Char -> Doc
char c = text [c]
space :: Doc
space = Doc $ singleton BreakingSpace
cr :: Doc
cr = Doc $ singleton CarriageReturn
blankline :: Doc
blankline = Doc $ singleton BlankLine
prefixed :: String -> Doc -> Doc
prefixed pref doc = Doc $ singleton $ Prefixed pref doc
flush :: Doc -> Doc
flush doc = Doc $ singleton $ Flush doc
nest :: Int -> Doc -> Doc
nest ind = prefixed (replicate ind ' ')
hang :: Int -> Doc -> Doc -> Doc
hang ind start doc = start <> nest ind doc
nowrap :: Doc -> Doc
nowrap doc = Doc $ fromList $ map replaceSpace $ toList $ unDoc doc
where replaceSpace BreakingSpace = Text 1 " "
replaceSpace x = x
offset :: Doc -> Int
offset d = case map length . lines . render Nothing $ d of
[] -> 0
os -> maximum os
block :: (String -> String) -> Int -> Doc -> Doc
block filler width = Doc . singleton . Block width .
map filler . chop width . render (Just width)
lblock :: Int -> Doc -> Doc
lblock = block id
rblock :: Int -> Doc -> Doc
rblock w = block (\s -> replicate (w length s) ' ' ++ s) w
cblock :: Int -> Doc -> Doc
cblock w = block (\s -> replicate ((w length s) `div` 2) ' ' ++ s) w
height :: Doc -> Int
height = length . lines . render Nothing
chop :: Int -> String -> [String]
chop _ [] = []
chop n cs = case break (=='\n') cs of
(xs, ys) -> if len <= n
then case ys of
[] -> [xs]
(_:[]) -> [xs, ""]
(_:zs) -> xs : chop n zs
else take n xs : chop n (drop n xs ++ ys)
where len = length xs
inside :: Doc -> Doc -> Doc -> Doc
inside start end contents =
start <> contents <> end
braces :: Doc -> Doc
braces = inside (char '{') (char '}')
brackets :: Doc -> Doc
brackets = inside (char '[') (char ']')
parens :: Doc -> Doc
parens = inside (char '(') (char ')')
quotes :: Doc -> Doc
quotes = inside (char '\'') (char '\'')
doubleQuotes :: Doc -> Doc
doubleQuotes = inside (char '"') (char '"')