diff options
Diffstat (limited to 'src/Text/Pandoc/Pretty.hs')
| -rw-r--r-- | src/Text/Pandoc/Pretty.hs | 120 |
1 files changed, 59 insertions, 61 deletions
diff --git a/src/Text/Pandoc/Pretty.hs b/src/Text/Pandoc/Pretty.hs index 256f38b0c..25c2373a6 100644 --- a/src/Text/Pandoc/Pretty.hs +++ b/src/Text/Pandoc/Pretty.hs @@ -1,6 +1,7 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving, CPP #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {- -Copyright (C) 2010-2016 John MacFarlane <jgm@berkeley.edu> +Copyright (C) 2010-2018 John MacFarlane <jgm@berkeley.edu> This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -19,7 +20,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111(-1)307 USA {- | Module : Text.Pandoc.Pretty - Copyright : Copyright (C) 2010-2016 John MacFarlane + Copyright : Copyright (C) 2010-2018 John MacFarlane License : GNU GPL, version 2 or above Maintainer : John MacFarlane <jgm@berkeley.edu> @@ -76,22 +77,24 @@ module Text.Pandoc.Pretty ( ) where -import Data.Sequence (Seq, fromList, (<|), singleton, mapWithIndex, viewl, ViewL(..)) -import qualified Data.Sequence as Seq +import Control.Monad +import Control.Monad.State.Strict +import Data.Char (isSpace) import Data.Foldable (toList) import Data.List (intersperse) -import Data.String -import Control.Monad.State -import Data.Char (isSpace) import Data.Monoid ((<>)) +import Data.Sequence (Seq, ViewL (..), fromList, mapWithIndex, singleton, viewl, + (<|)) +import qualified Data.Sequence as Seq +import Data.String data RenderState a = RenderState{ - output :: [a] -- ^ In reverse order - , prefix :: String - , usePrefix :: Bool - , lineLength :: Maybe Int -- ^ 'Nothing' means no wrapping - , column :: Int - , newlines :: Int -- ^ Number of preceding newlines + output :: [a] -- ^ In reverse order + , prefix :: String + , usePrefix :: Bool + , lineLength :: Maybe Int -- ^ 'Nothing' means no wrapping + , column :: Int + , newlines :: Int -- ^ Number of preceding newlines } type DocState a = State (RenderState a) () @@ -106,10 +109,10 @@ data D = Text Int String | CarriageReturn | NewLine | BlankLines Int -- number of blank lines - deriving (Show) + deriving (Show, Eq) newtype Doc = Doc { unDoc :: Seq D } - deriving (Monoid, Show) + deriving (Monoid, Show, Eq) instance IsString Doc where fromString = text @@ -142,11 +145,10 @@ hcat = mconcat -- between them. infixr 6 <+> (<+>) :: Doc -> Doc -> Doc -(<+>) x y = if isEmpty x - then y - else if isEmpty y - then x - else x <> space <> y +(<+>) x y + | isEmpty x = y + | isEmpty y = x + | otherwise = x <> space <> y -- | Same as 'cat', but putting breakable spaces between the -- 'Doc's. @@ -156,20 +158,18 @@ hsep = foldr (<+>) empty infixr 5 $$ -- | @a $$ b@ puts @a@ above @b@. ($$) :: Doc -> Doc -> Doc -($$) x y = if isEmpty x - then y - else if isEmpty y - then x - else x <> cr <> y +($$) x y + | isEmpty x = y + | isEmpty y = x + | otherwise = x <> cr <> y infixr 5 $+$ -- | @a $+$ b@ puts @a@ above @b@, with a blank line between. ($+$) :: Doc -> Doc -> Doc -($+$) x y = if isEmpty x - then y - else if isEmpty y - then x - else x <> blankline <> y +($+$) x y + | isEmpty x = y + | isEmpty y = x + | otherwise = x <> blankline <> y -- | List version of '$$'. vcat :: [Doc] -> Doc @@ -184,21 +184,21 @@ nestle :: Doc -> Doc nestle (Doc d) = Doc $ go d where go x = case viewl x of (BlankLines _ :< rest) -> go rest - (NewLine :< rest) -> go rest - _ -> x + (NewLine :< rest) -> go rest + _ -> x -- | Chomps trailing blank space off of a 'Doc'. chomp :: Doc -> Doc chomp d = Doc (fromList dl') where dl = toList (unDoc d) dl' = reverse $ go $ reverse dl - go [] = [] - go (BreakingSpace : xs) = go xs + go [] = [] + go (BreakingSpace : xs) = go xs go (CarriageReturn : xs) = go xs - go (NewLine : xs) = go xs - go (BlankLines _ : xs) = go xs - go (Prefixed s d' : xs) = Prefixed s (chomp d') : xs - go xs = xs + go (NewLine : xs) = go xs + go (BlankLines _ : xs) = go xs + go (Prefixed s d' : xs) = Prefixed s (chomp d') : xs + go xs = xs outp :: (IsString a) => Int -> String -> DocState a outp off s | off < 0 = do -- offset < 0 means newline characters @@ -215,9 +215,9 @@ outp off s | off < 0 = do -- offset < 0 means newline characters outp off s = do -- offset >= 0 (0 might be combining char) st' <- get let pref = prefix st' - when (column st' == 0 && usePrefix st' && not (null pref)) $ do + when (column st' == 0 && usePrefix st' && not (null pref)) $ modify $ \st -> st{ output = fromString pref : output st - , column = column st + realLength pref } + , column = column st + realLength pref } modify $ \st -> st{ output = fromString s : output st , column = column st + off , newlines = 0 } @@ -306,10 +306,10 @@ renderList (BreakingSpace : NewLine : xs) = renderList (NewLine:xs) renderList (BreakingSpace : BlankLines n : xs) = renderList (BlankLines n:xs) renderList (BreakingSpace : BreakingSpace : xs) = renderList (BreakingSpace:xs) renderList (BreakingSpace : xs) = do - let isText (Text _ _) = True - isText (Block _ _) = True - isText (AfterBreak _) = True - isText _ = False + let isText (Text _ _) = True + isText (Block _ _) = True + isText (AfterBreak _) = True + isText _ = False let isBreakingSpace BreakingSpace = True isBreakingSpace _ = False let xs' = dropWhile isBreakingSpace xs @@ -326,9 +326,7 @@ renderList (BreakingSpace : xs) = do renderList (AfterBreak s : xs) = do st <- get - if newlines st > 0 - then outp (realLength s) s - else return () + when (newlines st > 0) $ outp (realLength s) s renderList xs renderList (Block i1 s1 : Block i2 s2 : xs) = @@ -342,7 +340,7 @@ renderList (Block _width lns : xs) = do let oldPref = prefix st case column st - realLength oldPref of n | n > 0 -> modify $ \s -> s{ prefix = oldPref ++ replicate n ' ' } - _ -> return () + _ -> return () renderList $ intersperse CarriageReturn (map (Text 0) lns) modify $ \s -> s{ prefix = oldPref } renderList xs @@ -359,13 +357,13 @@ mergeBlocks addSpace (IsBlock w1 lns1) (IsBlock w2 lns2) = | otherwise -> (lns1, lns2) pad n s = s ++ replicate (n - realLength s) ' ' sp "" = "" - sp xs = if addSpace then (' ' : xs) else xs + sp xs = if addSpace then ' ' : xs else xs offsetOf :: D -> Int -offsetOf (Text o _) = o -offsetOf (Block w _) = w -offsetOf BreakingSpace = 1 -offsetOf _ = 0 +offsetOf (Text o _) = o +offsetOf (Block w _) = w +offsetOf BreakingSpace = 1 +offsetOf _ = 0 -- | A literal string. text :: String -> Doc @@ -396,8 +394,8 @@ cr = Doc $ singleton CarriageReturn blankline :: Doc blankline = Doc $ singleton (BlankLines 1) --- | Inserts a blank lines unless they exists already. --- (@blanklines m <> blanklines n@ has the same effect as @blankline (max m n)@. +-- | Inserts blank lines unless they exist already. +-- (@blanklines m <> blanklines n@ has the same effect as @blanklines (max m n)@. blanklines :: Int -> Doc blanklines n = Doc $ singleton (BlankLines n) @@ -430,7 +428,7 @@ beforeNonBlank d = Doc $ singleton (BeforeNonBlank d) nowrap :: Doc -> Doc nowrap doc = Doc $ mapWithIndex replaceSpace $ unDoc doc where replaceSpace _ BreakingSpace = Text 1 " " - replaceSpace _ x = x + replaceSpace _ x = x -- | Content to print only if it comes at the beginning of a line, -- to be used e.g. for escaping line-initial `.` in groff man. @@ -440,8 +438,8 @@ afterBreak s = Doc $ singleton (AfterBreak s) -- | Returns the width of a 'Doc'. offset :: Doc -> Int offset d = case map realLength . lines . render Nothing $ d of - [] -> 0 - os -> maximum os + [] -> 0 + os -> maximum os -- | Returns the minimal width of a 'Doc' when reflowed at breakable spaces. minOffset :: Doc -> Int @@ -466,7 +464,7 @@ height = length . lines . render Nothing block :: (String -> String) -> Int -> Doc -> Doc block filler width d - | width < 1 && not (isEmpty d) = error "Text.Pandoc.Pretty.block: width < 1" + | width < 1 && not (isEmpty d) = block filler 1 d | otherwise = Doc $ singleton $ Block width $ map filler $ chop width $ render (Just width) d @@ -554,4 +552,4 @@ charWidth c = -- | Get real length of string, taking into account combining and double-wide -- characters. realLength :: String -> Int -realLength = foldr (\a b -> charWidth a + b) 0 +realLength = sum . map charWidth |