2{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4Copyright (C) 2010-2016 John MacFarlane <jgm@berkeley.edu>
6This program is free software; you can redistribute it and/or modify
7it under the terms of the GNU General Public License as published by
8the Free Software Foundation; either version 2 of the License, or
9(at your option) any later version.
11This program is distributed in the hope that it will be useful,
12but WITHOUT ANY WARRANTY; without even the implied warranty of
13MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14GNU General Public License for more details.
16You should have received a copy of the GNU General Public License
17along with this program; if not, write to the Free Software
18Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111(-1)307 USA
22 Module : Text.Pandoc.Pretty
23 Copyright : Copyright (C) 2010-2016 John MacFarlane
24 License : GNU GPL, version 2 or above
26 Maintainer : John MacFarlane <jgm@berkeley.edu>
28 Portability : portable
30A prettyprinting library for the production of text documents,
31including wrapped text, indentated blocks, and tables.
34module Text.Pandoc.Pretty (
80import Control.Monad.State
81import Data.Char (isSpace)
82import Data.Foldable (toList)
83import Data.List (intersperse)
84import Data.Monoid ((<>))
85import Data.Sequence (Seq, ViewL (..), fromList, mapWithIndex, singleton, viewl,
87import qualified Data.Sequence as Seq
90data RenderState a = RenderState{
91 output :: [a] -- ^ In reverse order
94 , lineLength :: Maybe Int -- ^ 'Nothing' means no wrapping
96 , newlines :: Int -- ^ Number of preceding newlines
99type DocState a = State (RenderState a) ()
101data D = Text Int String
103 | Prefixed String Doc
110 | BlankLines Int -- number of blank lines
113newtype Doc = Doc { unDoc :: Seq D }
114 deriving (Monoid, Show)
116instance IsString Doc where
120isBlank BreakingSpace = True
121isBlank CarriageReturn = True
122isBlank NewLine = True
123isBlank (BlankLines _) = True
124isBlank (Text _ (c:_)) = isSpace c
127-- | True if the document is empty.
128isEmpty :: Doc -> Bool
129isEmpty = Seq.null . unDoc
131-- | The empty document.
135-- | Concatenate a list of 'Doc's.
143-- | Concatenate a list of 'Doc's, putting breakable spaces
146(<+>) :: Doc -> Doc -> Doc
147(<+>) x y = if isEmpty x
153-- | Same as 'cat', but putting breakable spaces between the
156hsep = foldr (<+>) empty
159-- | @a $$ b@ puts @a@ above @b@.
160($$) :: Doc -> Doc -> Doc
161($$) x y = if isEmpty x
168-- | @a $+$ b@ puts @a@ above @b@, with a blank line between.
169($+$) :: Doc -> Doc -> Doc
170($+$) x y = if isEmpty x
174 else x <> blankline <> y
176-- | List version of '$$'.
178vcat = foldr ($$) empty
180-- | List version of '$+$'.
182vsep = foldr ($+$) empty
184-- | Removes leading blank lines from a 'Doc'.
186nestle (Doc d) = Doc $ go d
187 where go x = case viewl x of
188 (BlankLines _ :< rest) -> go rest
189 (NewLine :< rest) -> go rest
192-- | Chomps trailing blank space off of a 'Doc'.
194chomp d = Doc (fromList dl')
195 where dl = toList (unDoc d)
196 dl' = reverse $ go $ reverse dl
198 go (BreakingSpace : xs) = go xs
199 go (CarriageReturn : xs) = go xs
200 go (NewLine : xs) = go xs
201 go (BlankLines _ : xs) = go xs
202 go (Prefixed s d' : xs) = Prefixed s (chomp d') : xs
205outp :: (IsString a) => Int -> String -> DocState a
206outp off s | off < 0 = do -- offset < 0 means newline characters
208 let rawpref = prefix st'
209 when (column st' == 0 && usePrefix st' && not (null rawpref)) $ do
210 let pref = reverse $ dropWhile isSpace $ reverse rawpref
211 modify $ \st -> st{ output = fromString pref : output st
212 , column = column st + realLength pref }
213 let numnewlines = length $ takeWhile (=='\n') $ reverse s
214 modify $ \st -> st { output = fromString s : output st
216 , newlines = newlines st + numnewlines }
217outp off s = do -- offset >= 0 (0 might be combining char)
219 let pref = prefix st'
220 when (column st' == 0 && usePrefix st' && not (null pref)) $ do
221 modify $ \st -> st{ output = fromString pref : output st
222 , column = column st + realLength pref }
223 modify $ \st -> st{ output = fromString s : output st
224 , column = column st + off
227-- | Renders a 'Doc'. @render (Just n)@ will use
228-- a line length of @n@ to reflow text on breakable spaces.
229-- @render Nothing@ will not reflow text.
230render :: (IsString a) => Maybe Int -> Doc -> a
231render linelen doc = fromString . mconcat . reverse . output $
232 execState (renderDoc doc) startingState
233 where startingState = RenderState{
237 , lineLength = linelen
241renderDoc :: (IsString a, Monoid a)
243renderDoc = renderList . toList . unDoc
245data IsBlock = IsBlock Int [String]
247-- This would be nicer with a pattern synonym
248-- pattern VBlock i s <- mkIsBlock -> Just (IsBlock ..)
250renderList :: (IsString a, Monoid a)
252renderList [] = return ()
253renderList (Text off s : xs) = do
257renderList (Prefixed pref d : xs) = do
259 let oldPref = prefix st
260 put st{ prefix = prefix st ++ pref }
262 modify $ \s -> s{ prefix = oldPref }
265renderList (Flush d : xs) = do
267 let oldUsePrefix = usePrefix st
268 put st{ usePrefix = False }
270 modify $ \s -> s{ usePrefix = oldUsePrefix }
273renderList (BeforeNonBlank d : xs) =
275 (x:_) | isBlank x -> renderList xs
276 | otherwise -> renderDoc d >> renderList xs
279renderList [BlankLines _] = return ()
281renderList (BlankLines m : BlankLines n : xs) =
282 renderList (BlankLines (max m n) : xs)
284renderList (BlankLines num : xs) = do
287 _ | newlines st > num -> return ()
288 | otherwise -> replicateM_ (1 + num - newlines st) (outp (-1) "\n")
291renderList (CarriageReturn : BlankLines m : xs) =
292 renderList (BlankLines m : xs)
294renderList (CarriageReturn : xs) = do
296 if newlines st > 0 || null xs
302renderList (NewLine : xs) = do
306renderList (BreakingSpace : CarriageReturn : xs) = renderList (CarriageReturn:xs)
307renderList (BreakingSpace : NewLine : xs) = renderList (NewLine:xs)
308renderList (BreakingSpace : BlankLines n : xs) = renderList (BlankLines n:xs)
309renderList (BreakingSpace : BreakingSpace : xs) = renderList (BreakingSpace:xs)
310renderList (BreakingSpace : xs) = do
311 let isText (Text _ _) = True
312 isText (Block _ _) = True
313 isText (AfterBreak _) = True
315 let isBreakingSpace BreakingSpace = True
316 isBreakingSpace _ = False
317 let xs' = dropWhile isBreakingSpace xs
318 let next = takeWhile isText xs'
320 let off = sum $ map offsetOf next
321 case lineLength st of
322 Just l | column st + 1 + off > l -> do
329renderList (AfterBreak s : xs) = do
332 then outp (realLength s) s
336renderList (Block i1 s1 : Block i2 s2 : xs) =
337 renderList (mergeBlocks False (IsBlock i1 s1) (IsBlock i2 s2) : xs)
339renderList (Block i1 s1 : BreakingSpace : Block i2 s2 : xs) =
340 renderList (mergeBlocks True (IsBlock i1 s1) (IsBlock i2 s2) : xs)
342renderList (Block _width lns : xs) = do
344 let oldPref = prefix st
345 case column st - realLength oldPref of
346 n | n > 0 -> modify $ \s -> s{ prefix = oldPref ++ replicate n ' ' }
348 renderList $ intersperse CarriageReturn (map (Text 0) lns)
349 modify $ \s -> s{ prefix = oldPref }
352mergeBlocks :: Bool -> IsBlock -> IsBlock -> D
353mergeBlocks addSpace (IsBlock w1 lns1) (IsBlock w2 lns2) =
354 Block (w1 + w2 + if addSpace then 1 else 0) $
355 zipWith (\l1 l2 -> pad w1 l1 ++ l2) lns1' (map sp lns2')
356 where (lns1', lns2') = case (length lns1, length lns2) of
357 (x, y) | x > y -> (lns1,
358 lns2 ++ replicate (x - y) "")
359 | x < y -> (lns1 ++ replicate (y - x) "",
361 | otherwise -> (lns1, lns2)
362 pad n s = s ++ replicate (n - realLength s) ' '
364 sp xs = if addSpace then (' ' : xs) else xs
367offsetOf (Text o _) = o
368offsetOf (Block w _) = w
369offsetOf BreakingSpace = 1
372-- | A literal string.
375 where toChunks :: String -> Seq D
377 toChunks s = case break (=='\n') s of
378 ([], _:ys) -> NewLine <| toChunks ys
379 (xs, _:ys) -> Text (realLength xs) xs <|
380 (NewLine <| toChunks ys)
381 (xs, []) -> singleton $ Text (realLength xs) xs
387-- | A breaking (reflowable) space.
389space = Doc $ singleton BreakingSpace
391-- | A carriage return. Does nothing if we're at the beginning of
392-- a line; otherwise inserts a newline.
394cr = Doc $ singleton CarriageReturn
396-- | Inserts a blank line unless one exists already.
397-- (@blankline <> blankline@ has the same effect as @blankline@.
399blankline = Doc $ singleton (BlankLines 1)
401-- | Inserts a blank lines unless they exists already.
402-- (@blanklines m <> blanklines n@ has the same effect as @blankline (max m n)@.
403blanklines :: Int -> Doc
404blanklines n = Doc $ singleton (BlankLines n)
406-- | Uses the specified string as a prefix for every line of
407-- the inside document (except the first, if not at the beginning
409prefixed :: String -> Doc -> Doc
410prefixed pref doc = Doc $ singleton $ Prefixed pref doc
412-- | Makes a 'Doc' flush against the left margin.
414flush doc = Doc $ singleton $ Flush doc
416-- | Indents a 'Doc' by the specified number of spaces.
417nest :: Int -> Doc -> Doc
418nest ind = prefixed (replicate ind ' ')
420-- | A hanging indent. @hang ind start doc@ prints @start@,
421-- then @doc@, leaving an indent of @ind@ spaces on every
422-- line but the first.
423hang :: Int -> Doc -> Doc -> Doc
424hang ind start doc = start <> nest ind doc
426-- | @beforeNonBlank d@ conditionally includes @d@ unless it is
427-- followed by blank space.
428beforeNonBlank :: Doc -> Doc
429beforeNonBlank d = Doc $ singleton (BeforeNonBlank d)
431-- | Makes a 'Doc' non-reflowable.
433nowrap doc = Doc $ mapWithIndex replaceSpace $ unDoc doc
434 where replaceSpace _ BreakingSpace = Text 1 " "
437-- | Content to print only if it comes at the beginning of a line,
438-- to be used e.g. for escaping line-initial `.` in groff man.
439afterBreak :: String -> Doc
440afterBreak s = Doc $ singleton (AfterBreak s)
442-- | Returns the width of a 'Doc'.
444offset d = case map realLength . lines . render Nothing $ d of
448-- | Returns the minimal width of a 'Doc' when reflowed at breakable spaces.
449minOffset :: Doc -> Int
450minOffset d = maximum (0: map realLength (lines $ render (Just 0) d))
452-- | @lblock n d@ is a block of width @n@ characters, with
453-- text derived from @d@ and aligned to the left.
454lblock :: Int -> Doc -> Doc
457-- | Like 'lblock' but aligned to the right.
458rblock :: Int -> Doc -> Doc
459rblock w = block (\s -> replicate (w - realLength s) ' ' ++ s) w
461-- | Like 'lblock' but aligned centered.
462cblock :: Int -> Doc -> Doc
463cblock w = block (\s -> replicate ((w - realLength s) `div` 2) ' ' ++ s) w
465-- | Returns the height of a block or other 'Doc'.
467height = length . lines . render Nothing
469block :: (String -> String) -> Int -> Doc -> Doc
471 | width < 1 && not (isEmpty d) = block filler 1 d
472 | otherwise = Doc $ singleton $ Block width $ map filler
473 $ chop width $ render (Just width) d
475chop :: Int -> String -> [String]
477chop n cs = case break (=='\n') cs of
478 (xs, ys) -> if len <= n
482 (_:zs) -> xs : chop n zs
483 else take n xs : chop n (drop n xs ++ ys)
484 where len = realLength xs
486-- | Encloses a 'Doc' inside a start and end 'Doc'.
487inside :: Doc -> Doc -> Doc -> Doc
488inside start end contents =
489 start <> contents <> end
491-- | Puts a 'Doc' in curly braces.
493braces = inside (char '{') (char '}')
495-- | Puts a 'Doc' in square brackets.
496brackets :: Doc -> Doc
497brackets = inside (char '[') (char ']')
499-- | Puts a 'Doc' in parentheses.
501parens = inside (char '(') (char ')')
503-- | Wraps a 'Doc' in single quotes.
505quotes = inside (char '\'') (char '\'')
507-- | Wraps a 'Doc' in double quotes.
508doubleQuotes :: Doc -> Doc
509doubleQuotes = inside (char '"') (char '"')
511-- | Returns width of a character in a monospace font: 0 for a combining
512-- character, 1 for a regular character, 2 for an East Asian wide character.
513charWidth :: Char -> Int
516 _ | c < '\x0300' -> 1
517 | c >= '\x0300' && c <= '\x036F' -> 0 -- combining
518 | c >= '\x0370' && c <= '\x10FC' -> 1
519 | c >= '\x1100' && c <= '\x115F' -> 2
520 | c >= '\x1160' && c <= '\x11A2' -> 1
521 | c >= '\x11A3' && c <= '\x11A7' -> 2
522 | c >= '\x11A8' && c <= '\x11F9' -> 1
523 | c >= '\x11FA' && c <= '\x11FF' -> 2
524 | c >= '\x1200' && c <= '\x2328' -> 1
525 | c >= '\x2329' && c <= '\x232A' -> 2
526 | c >= '\x232B' && c <= '\x2E31' -> 1
527 | c >= '\x2E80' && c <= '\x303E' -> 2
529 | c >= '\x3041' && c <= '\x3247' -> 2
530 | c >= '\x3248' && c <= '\x324F' -> 1 -- ambiguous
531 | c >= '\x3250' && c <= '\x4DBF' -> 2
532 | c >= '\x4DC0' && c <= '\x4DFF' -> 1
533 | c >= '\x4E00' && c <= '\xA4C6' -> 2
534 | c >= '\xA4D0' && c <= '\xA95F' -> 1
535 | c >= '\xA960' && c <= '\xA97C' -> 2
536 | c >= '\xA980' && c <= '\xABF9' -> 1
537 | c >= '\xAC00' && c <= '\xD7FB' -> 2
538 | c >= '\xD800' && c <= '\xDFFF' -> 1
539 | c >= '\xE000' && c <= '\xF8FF' -> 1 -- ambiguous
540 | c >= '\xF900' && c <= '\xFAFF' -> 2
541 | c >= '\xFB00' && c <= '\xFDFD' -> 1
542 | c >= '\xFE00' && c <= '\xFE0F' -> 1 -- ambiguous
543 | c >= '\xFE10' && c <= '\xFE19' -> 2
544 | c >= '\xFE20' && c <= '\xFE26' -> 1
545 | c >= '\xFE30' && c <= '\xFE6B' -> 2
546 | c >= '\xFE70' && c <= '\xFEFF' -> 1
547 | c >= '\xFF01' && c <= '\xFF60' -> 2
548 | c >= '\xFF61' && c <= '\x16A38' -> 1
549 | c >= '\x1B000' && c <= '\x1B001' -> 2
550 | c >= '\x1D000' && c <= '\x1F1FF' -> 1
551 | c >= '\x1F200' && c <= '\x1F251' -> 2
552 | c >= '\x1F300' && c <= '\x1F773' -> 1
553 | c >= '\x20000' && c <= '\x3FFFD' -> 2
556-- | Get real length of string, taking into account combining and double-wide
558realLength :: String -> Int
559realLength = sum . map charWidth
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list