doclayout-0.3/bench/0000755000000000000000000000000013527702245012633 5ustar0000000000000000doclayout-0.3/src/0000755000000000000000000000000013527526133012343 5ustar0000000000000000doclayout-0.3/src/Text/0000755000000000000000000000000013607012053013255 5ustar0000000000000000doclayout-0.3/test/0000755000000000000000000000000013606775147012544 5ustar0000000000000000doclayout-0.3/src/Text/DocLayout.hs0000644000000000000000000005723413607012053015527 0ustar0000000000000000{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveDataTypeable #-} {- | Module : Text.DocLayout Copyright : Copyright (C) 2010-2019 John MacFarlane License : BSD 3 Maintainer : John MacFarlane Stability : alpha Portability : portable A prettyprinting library for the production of text documents, including wrapped text, indentation and other prefixes, and blocks for tables. -} module Text.DocLayout ( -- * Rendering render -- * Doc constructors , cr , blankline , blanklines , space , literal , text , char , prefixed , flush , nest , hang , beforeNonBlank , nowrap , afterBreak , lblock , cblock , rblock , vfill , nestle , chomp , inside , braces , brackets , parens , quotes , doubleQuotes , empty -- * Functions for concatenating documents , (<+>) , ($$) , ($+$) , hcat , hsep , vcat , vsep -- * Functions for querying documents , isEmpty , offset , minOffset , updateColumn , height , charWidth , realLength -- * Types , Doc(..) , HasChars(..) ) where import Prelude import Data.List (foldl') import Data.Maybe (fromMaybe) import Safe (lastMay, initSafe) import Control.Monad import Control.Monad.State.Strict import GHC.Generics import Data.Char (isSpace) import Data.List (intersperse) import Data.Data (Data, Typeable) import Data.String import qualified Data.Text as T import qualified Data.Text.Lazy as TL import Data.Text (Text) #if MIN_VERSION_base(4,11,0) #else import Data.Semigroup #endif -- | Class abstracting over various string types that -- can fold over characters. Minimal definition is 'foldrChar' -- and 'foldlChar', but defining the other methods can give better -- performance. class (IsString a, Semigroup a, Monoid a, Show a) => HasChars a where foldrChar :: (Char -> b -> b) -> b -> a -> b foldlChar :: (b -> Char -> b) -> b -> a -> b replicateChar :: Int -> Char -> a replicateChar n c = fromString (replicate n c) isNull :: a -> Bool isNull = foldrChar (\_ _ -> False) True splitLines :: a -> [a] splitLines s = (fromString firstline : otherlines) where (firstline, otherlines) = foldrChar go ([],[]) s go '\n' (cur,lns) = ([], fromString cur : lns) go c (cur,lns) = (c:cur, lns) instance HasChars Text where foldrChar = T.foldr foldlChar = T.foldl' splitLines = T.splitOn "\n" replicateChar n c = T.replicate n (T.singleton c) isNull = T.null instance HasChars String where foldrChar = foldr foldlChar = foldl' splitLines = lines . (++"\n") replicateChar = replicate isNull = null instance HasChars TL.Text where foldrChar = TL.foldr foldlChar = TL.foldl' splitLines = TL.splitOn "\n" replicateChar n c = TL.replicate (fromIntegral n) (TL.singleton c) isNull = TL.null -- | Document, including structure relevant for layout. data Doc a = Text Int a -- ^ Text with specified width. | Block Int [a] -- ^ A block with a width and lines. | VFill Int a -- ^ A vertically expandable block; -- when concatenated with a block, expands to height -- of block, with each line containing the specified text. | Prefixed Text (Doc a) -- ^ Doc with each line prefixed with text. -- Note that trailing blanks are omitted from the prefix -- when the line after it is empty. | BeforeNonBlank (Doc a) -- ^ Doc that renders only before nonblank. | Flush (Doc a) -- ^ Doc laid out flush to left margin. | BreakingSpace -- ^ A space or line break, in context. | AfterBreak Text -- ^ Text printed only at start of line. | CarriageReturn -- ^ Newline unless we're at start of line. | NewLine -- ^ newline. | BlankLines Int -- ^ Ensure a number of blank lines. | Concat (Doc a) (Doc a) -- ^ Two documents concatenated. | Empty deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable, Data, Typeable, Generic) instance Semigroup (Doc a) where x <> Empty = x Empty <> x = x x <> y = Concat x y instance Monoid (Doc a) where mappend = (<>) mempty = Empty instance HasChars a => IsString (Doc a) where fromString = text -- | Unfold a 'Doc' into a flat list. unfoldD :: Doc a -> [Doc a] unfoldD Empty = [] unfoldD (Concat x@Concat{} y) = unfoldD x <> unfoldD y unfoldD (Concat x y) = x : unfoldD y unfoldD x = [x] -- | True if the document is empty. isEmpty :: Doc a -> Bool isEmpty Empty = True isEmpty _ = False -- | The empty document. empty :: Doc a empty = mempty -- | Concatenate documents horizontally. hcat :: [Doc a] -> Doc a hcat = mconcat -- | Concatenate a list of 'Doc's, putting breakable spaces -- between them. infixr 6 <+> (<+>) :: Doc a -> Doc a -> Doc a (<+>) x y | isEmpty x = y | isEmpty y = x | otherwise = x <> space <> y -- | Same as 'hcat', but putting breakable spaces between the -- 'Doc's. hsep :: [Doc a] -> Doc a hsep = foldr (<+>) empty infixr 5 $$ -- | @a $$ b@ puts @a@ above @b@. ($$) :: Doc a -> Doc a -> Doc a ($$) 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 a -> Doc a -> Doc a ($+$) x y | isEmpty x = y | isEmpty y = x | otherwise = x <> blankline <> y -- | List version of '$$'. vcat :: [Doc a] -> Doc a vcat = foldr ($$) empty -- | List version of '$+$'. vsep :: [Doc a] -> Doc a vsep = foldr ($+$) empty -- | Removes leading blank lines from a 'Doc'. nestle :: Doc a -> Doc a nestle d = case d of BlankLines _ -> Empty NewLine -> Empty Concat (Concat x y) z -> nestle (Concat x (Concat y z)) Concat BlankLines{} x -> nestle x Concat NewLine x -> nestle x _ -> d -- | Chomps trailing blank space off of a 'Doc'. chomp :: Doc a -> Doc a chomp d = case d of BlankLines _ -> Empty NewLine -> Empty CarriageReturn -> Empty BreakingSpace -> Empty Prefixed s d' -> Prefixed s (chomp d') Concat (Concat x y) z -> chomp (Concat x (Concat y z)) Concat x y -> case chomp y of Empty -> chomp x z -> x <> z _ -> d type DocState a = State (RenderState a) () data RenderState a = RenderState{ output :: [a] -- ^ In reverse order , prefix :: Text , usePrefix :: Bool , lineLength :: Maybe Int -- ^ 'Nothing' means no wrapping , column :: Int , newlines :: Int -- ^ Number of preceding newlines } newline :: HasChars a => DocState a newline = do st' <- get let rawpref = prefix st' when (column st' == 0 && usePrefix st' && not (T.null rawpref)) $ do let pref = fromString $ T.unpack $ T.dropWhileEnd isSpace rawpref modify $ \st -> st{ output = pref : output st , column = column st + realLength pref } modify $ \st -> st { output = "\n" : output st , column = 0 , newlines = newlines st + 1 } outp :: HasChars a => Int -> a -> DocState a outp off s = do -- offset >= 0 (0 might be combining char) st' <- get let pref = fromString $ T.unpack $ prefix st' when (column st' == 0 && usePrefix st' && not (isNull pref)) $ modify $ \st -> st{ output = pref : output st , column = column st + realLength pref } modify $ \st -> st{ output = s : output st , column = column st + off , newlines = 0 } -- | Render a 'Doc'. @render (Just n)@ will use -- a line length of @n@ to reflow text on breakable spaces. -- @render Nothing@ will not reflow text. render :: HasChars a => Maybe Int -> Doc a -> a render linelen doc = mconcat . reverse . output $ execState (renderDoc doc) startingState where startingState = RenderState{ output = mempty , prefix = mempty , usePrefix = True , lineLength = linelen , column = 0 , newlines = 2 } renderDoc :: HasChars a => Doc a -> DocState a renderDoc = renderList . normalize . unfoldD normalize :: HasChars a => [Doc a] -> [Doc a] normalize [] = [] normalize (Concat{} : xs) = normalize xs -- should not happen after unfoldD normalize (Empty : xs) = normalize xs -- should not happen after unfoldD normalize [NewLine] = normalize [CarriageReturn] normalize [BlankLines _] = normalize [CarriageReturn] normalize [BreakingSpace] = [] normalize (BlankLines m : BlankLines n : xs) = normalize (BlankLines (max m n) : xs) normalize (BlankLines num : BreakingSpace : xs) = normalize (BlankLines num : xs) normalize (BlankLines m : CarriageReturn : xs) = normalize (BlankLines m : xs) normalize (BlankLines m : NewLine : xs) = normalize (BlankLines m : xs) normalize (NewLine : BlankLines m : xs) = normalize (BlankLines m : xs) normalize (NewLine : BreakingSpace : xs) = normalize (NewLine : xs) normalize (NewLine : CarriageReturn : xs) = normalize (NewLine : xs) normalize (CarriageReturn : CarriageReturn : xs) = normalize (CarriageReturn : xs) normalize (CarriageReturn : NewLine : xs) = normalize (NewLine : xs) normalize (CarriageReturn : BlankLines m : xs) = normalize (BlankLines m : xs) normalize (CarriageReturn : BreakingSpace : xs) = normalize (CarriageReturn : xs) normalize (BreakingSpace : CarriageReturn : xs) = normalize (CarriageReturn:xs) normalize (BreakingSpace : NewLine : xs) = normalize (NewLine:xs) normalize (BreakingSpace : BlankLines n : xs) = normalize (BlankLines n:xs) normalize (BreakingSpace : BreakingSpace : xs) = normalize (BreakingSpace:xs) normalize (x:xs) = x : normalize xs mergeBlocks :: HasChars a => Int -> (Int, [a]) -> (Int, [a]) -> (Int, [a]) mergeBlocks h (w1,lns1) (w2,lns2) = (w, zipWith (\l1 l2 -> pad w1 l1 <> l2) lns1' lns2') where w = w1 + w2 len1 = length $ take h lns1 -- note lns1 might be infinite len2 = length $ take h lns2 lns1' = if len1 < h then lns1 ++ replicate (h - len1) mempty else take h lns1 lns2' = if len2 < h then lns2 ++ replicate (h - len2) mempty else take h lns2 pad n s = s <> replicateChar (n - realLength s) ' ' renderList :: HasChars a => [Doc a] -> 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 } -- renderDoc CarriageReturn 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 (BeforeNonBlank d : xs) = case xs of (x:_) | startsBlank x -> renderList xs | otherwise -> renderDoc d >> renderList xs [] -> renderList xs renderList (BlankLines num : xs) = do st <- get case output st of _ | newlines st > num -> return () | otherwise -> replicateM_ (1 + num - newlines st) newline renderList xs renderList (CarriageReturn : xs) = do st <- get if newlines st > 0 then renderList xs else do newline renderList xs renderList (NewLine : xs) = do newline renderList xs renderList (BreakingSpace : xs) = do let isBreakingSpace BreakingSpace = True isBreakingSpace _ = False let xs' = dropWhile isBreakingSpace xs let next = takeWhile (not . isBreakable) xs' st <- get let off = foldl' (\tot t -> tot + offsetOf t) 0 next case lineLength st of Just l | column st + 1 + off > l -> newline _ -> when (column st > 0) $ outp 1 " " renderList xs' renderList (AfterBreak t : xs) = do st <- get if newlines st > 0 then renderList (fromString (T.unpack t) : xs) else renderList xs renderList (b : xs) | isBlock b = do let (bs, rest) = span isBlock xs -- ensure we have right padding unless end of line let heightOf (Block _ ls) = length ls heightOf _ = 1 let maxheight = maximum $ map heightOf (b:bs) let toBlockSpec (Block w ls) = (w, ls) toBlockSpec (VFill w t) = (w, take maxheight $ repeat t) toBlockSpec _ = (0, []) let (_, lns') = foldl (mergeBlocks maxheight) (toBlockSpec b) (map toBlockSpec bs) st <- get let oldPref = prefix st case column st - realLength oldPref of n | n > 0 -> modify $ \s -> s{ prefix = oldPref <> T.replicate n " " } _ -> return () renderList $ intersperse CarriageReturn (map literal lns') modify $ \s -> s{ prefix = oldPref } renderList rest renderList (x:_) = error $ "renderList encountered " ++ show x isBreakable :: HasChars a => Doc a -> Bool isBreakable BreakingSpace = True isBreakable CarriageReturn = True isBreakable NewLine = True isBreakable (BlankLines _) = True isBreakable (Concat Empty y) = isBreakable y isBreakable (Concat x _) = isBreakable x isBreakable _ = False startsBlank' :: HasChars a => a -> Bool startsBlank' t = fromMaybe False $ foldlChar go Nothing t where go Nothing c = Just (isSpace c) go (Just b) _ = Just b startsBlank :: HasChars a => Doc a -> Bool startsBlank (Text _ t) = startsBlank' t startsBlank (Block n ls) = n > 0 && all startsBlank' ls startsBlank (VFill n t) = n > 0 && startsBlank' t startsBlank (BeforeNonBlank x) = startsBlank x startsBlank (Prefixed _ x) = startsBlank x startsBlank (Flush x) = startsBlank x startsBlank BreakingSpace = True startsBlank (AfterBreak t) = startsBlank (Text 0 t) startsBlank CarriageReturn = True startsBlank NewLine = True startsBlank (BlankLines _) = True startsBlank (Concat Empty y) = startsBlank y startsBlank (Concat x _) = startsBlank x startsBlank Empty = True isBlock :: Doc a -> Bool isBlock Block{} = True isBlock VFill{} = True isBlock _ = False offsetOf :: Doc a -> Int offsetOf (Text o _) = o offsetOf (Block w _) = w offsetOf (VFill w _) = w offsetOf BreakingSpace = 1 offsetOf _ = 0 -- | Create a 'Doc' from a stringlike value. literal :: HasChars a => a -> Doc a literal x = mconcat $ intersperse NewLine $ map (\s -> if isNull s then Empty else Text (realLength s) s) $ splitLines x -- | A literal string. (Like 'literal', but restricted to String.) text :: HasChars a => String -> Doc a text = literal . fromString -- | A character. char :: HasChars a => Char -> Doc a char c = text $ fromString [c] -- | A breaking (reflowable) space. space :: Doc a space = BreakingSpace -- | A carriage return. Does nothing if we're at the beginning of -- a line; otherwise inserts a newline. cr :: Doc a cr = CarriageReturn -- | Inserts a blank line unless one exists already. -- (@blankline <> blankline@ has the same effect as @blankline@. blankline :: Doc a blankline = BlankLines 1 -- | Inserts blank lines unless they exist already. -- (@blanklines m <> blanklines n@ has the same effect as @blanklines (max m n)@. blanklines :: Int -> Doc a blanklines = BlankLines -- | Uses the specified string as a prefix for every line of -- the inside document (except the first, if not at the beginning -- of the line). prefixed :: IsString a => String -> Doc a -> Doc a prefixed pref doc | isEmpty doc = Empty | otherwise = Prefixed (fromString pref) doc -- | Makes a 'Doc' flush against the left margin. flush :: Doc a -> Doc a flush doc | isEmpty doc = Empty | otherwise = Flush doc -- | Indents a 'Doc' by the specified number of spaces. nest :: IsString a => Int -> Doc a -> Doc a nest ind = prefixed (replicate ind ' ') -- | A hanging indent. @hang ind start doc@ prints @start@, -- then @doc@, leaving an indent of @ind@ spaces on every -- line but the first. hang :: IsString a => Int -> Doc a -> Doc a -> Doc a hang ind start doc = start <> nest ind doc -- | @beforeNonBlank d@ conditionally includes @d@ unless it is -- followed by blank space. beforeNonBlank :: Doc a -> Doc a beforeNonBlank = BeforeNonBlank -- | Makes a 'Doc' non-reflowable. nowrap :: IsString a => Doc a -> Doc a nowrap = mconcat . map replaceSpace . unfoldD where replaceSpace BreakingSpace = Text 1 $ fromString " " 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 roff man. afterBreak :: Text -> Doc a afterBreak = AfterBreak -- | Returns the width of a 'Doc'. offset :: (IsString a, HasChars a) => Doc a -> Int offset (Text n _) = n offset (Block n _) = n offset (VFill n _) = n offset Empty = 0 offset CarriageReturn = 0 offset NewLine = 0 offset (BlankLines _) = 0 offset d = maximum (0 : map realLength (splitLines (render Nothing d))) -- | Returns the minimal width of a 'Doc' when reflowed at breakable spaces. minOffset :: HasChars a => Doc a -> Int minOffset (Text n _) = n minOffset (Block n _) = n minOffset (VFill n _) = n minOffset Empty = 0 minOffset CarriageReturn = 0 minOffset NewLine = 0 minOffset (BlankLines _) = 0 minOffset d = maximum (0 : map realLength (splitLines (render (Just 0) d))) -- | Returns the column that would be occupied by the last -- laid out character (assuming no wrapping). updateColumn :: HasChars a => Doc a -> Int -> Int updateColumn (Text !n _) !k = k + n updateColumn (Block !n _) !k = k + n updateColumn (VFill !n _) !k = k + n updateColumn Empty _ = 0 updateColumn CarriageReturn _ = 0 updateColumn NewLine _ = 0 updateColumn (BlankLines _) _ = 0 updateColumn d !k = case splitLines (render Nothing d) of [] -> k [t] -> k + realLength t ts -> realLength $ last ts -- | @lblock n d@ is a block of width @n@ characters, with -- text derived from @d@ and aligned to the left. lblock :: HasChars a => Int -> Doc a -> Doc a lblock = block id -- | Like 'lblock' but aligned to the right. rblock :: HasChars a => Int -> Doc a -> Doc a rblock w = block (\s -> replicateChar (w - realLength s) ' ' <> s) w -- | Like 'lblock' but aligned centered. cblock :: HasChars a => Int -> Doc a -> Doc a cblock w = block (\s -> replicateChar ((w - realLength s) `div` 2) ' ' <> s) w -- | Returns the height of a block or other 'Doc'. height :: HasChars a => Doc a -> Int height = length . splitLines . render Nothing block :: HasChars a => (a -> a) -> Int -> Doc a -> Doc a block filler width d | width < 1 && not (isEmpty d) = block filler 1 d | otherwise = Block width ls where ls = map filler $ chop width $ render (Just width) d -- | An expandable border that, when placed next to a box, -- expands to the height of the box. Strings cycle through the -- list provided. vfill :: HasChars a => a -> Doc a vfill t = VFill (realLength t) t chop :: HasChars a => Int -> a -> [a] chop n = concatMap chopLine . removeFinalEmpty . map addRealLength . splitLines where removeFinalEmpty xs = case lastMay xs of Just (0, _) -> initSafe xs _ -> xs addRealLength l = (realLength l, l) chopLine (len, l) | len <= n = [l] | otherwise = map snd $ foldrChar (\c ls -> let clen = charWidth c cs = replicateChar 1 c in case ls of (len', l'):rest | len' + clen > n -> (clen, cs):(len', l'):rest | otherwise -> (len' + clen, cs <> l'):rest [] -> [(clen, cs)]) [] l -- | Encloses a 'Doc' inside a start and end 'Doc'. inside :: Doc a -> Doc a -> Doc a -> Doc a inside start end contents = start <> contents <> end -- | Puts a 'Doc' in curly braces. braces :: HasChars a => Doc a -> Doc a braces = inside (char '{') (char '}') -- | Puts a 'Doc' in square brackets. brackets :: HasChars a => Doc a -> Doc a brackets = inside (char '[') (char ']') -- | Puts a 'Doc' in parentheses. parens :: HasChars a => Doc a -> Doc a parens = inside (char '(') (char ')') -- | Wraps a 'Doc' in single quotes. quotes :: HasChars a => Doc a -> Doc a quotes = inside (char '\'') (char '\'') -- | Wraps a 'Doc' in double quotes. doubleQuotes :: HasChars a => Doc a -> Doc a doubleQuotes = inside (char '"') (char '"') -- | Returns width of a character in a monospace font: 0 for a combining -- character, 1 for a regular character, 2 for an East Asian wide character. charWidth :: Char -> Int charWidth c = case c of _ | c < '\x0300' -> 1 | c >= '\x0300' && c <= '\x036F' -> 0 -- combining | c >= '\x0370' && c <= '\x10FC' -> 1 | c >= '\x1100' && c <= '\x115F' -> 2 | c >= '\x1160' && c <= '\x11A2' -> 1 | c >= '\x11A3' && c <= '\x11A7' -> 2 | c >= '\x11A8' && c <= '\x11F9' -> 1 | c >= '\x11FA' && c <= '\x11FF' -> 2 | c >= '\x1200' && c <= '\x2328' -> 1 | c >= '\x2329' && c <= '\x232A' -> 2 | c >= '\x232B' && c <= '\x2E31' -> 1 | c >= '\x2E80' && c <= '\x303E' -> 2 | c == '\x303F' -> 1 | c >= '\x3041' && c <= '\x3247' -> 2 | c >= '\x3248' && c <= '\x324F' -> 1 -- ambiguous | c >= '\x3250' && c <= '\x4DBF' -> 2 | c >= '\x4DC0' && c <= '\x4DFF' -> 1 | c >= '\x4E00' && c <= '\xA4C6' -> 2 | c >= '\xA4D0' && c <= '\xA95F' -> 1 | c >= '\xA960' && c <= '\xA97C' -> 2 | c >= '\xA980' && c <= '\xABF9' -> 1 | c >= '\xAC00' && c <= '\xD7FB' -> 2 | c >= '\xD800' && c <= '\xDFFF' -> 1 | c >= '\xE000' && c <= '\xF8FF' -> 1 -- ambiguous | c >= '\xF900' && c <= '\xFAFF' -> 2 | c >= '\xFB00' && c <= '\xFDFD' -> 1 | c >= '\xFE00' && c <= '\xFE0F' -> 1 -- ambiguous | c >= '\xFE10' && c <= '\xFE19' -> 2 | c >= '\xFE20' && c <= '\xFE26' -> 1 | c >= '\xFE30' && c <= '\xFE6B' -> 2 | c >= '\xFE70' && c <= '\xFEFF' -> 1 | c >= '\xFF01' && c <= '\xFF60' -> 2 | c >= '\xFF61' && c <= '\x16A38' -> 1 | c >= '\x1B000' && c <= '\x1B001' -> 2 | c >= '\x1D000' && c <= '\x1F1FF' -> 1 | c >= '\x1F200' && c <= '\x1F251' -> 2 | c >= '\x1F300' && c <= '\x1F773' -> 1 | c >= '\x20000' && c <= '\x3FFFD' -> 2 | otherwise -> 1 -- | Get real length of string, taking into account combining and double-wide -- characters. realLength :: HasChars a => a -> Int realLength s = fromMaybe 0 $ foldlChar go Nothing s where -- Using a Maybe allows us to handle the case where the string -- starts with a combining character. Since there is no preceding -- character, we count 0 width as 1 in this one case: go Nothing !c = case charWidth c of 0 -> Just 1 !n -> Just n go (Just !tot) !c = Just (tot + charWidth c) doclayout-0.3/test/test.hs0000644000000000000000000001516113556441036014052 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} import Text.DocLayout import Test.Tasty import Test.Tasty.HUnit import Data.Text (Text) #if MIN_VERSION_base(4,11,0) #else import Data.Semigroup #endif main :: IO () main = defaultMain $ testGroup "Tests" tests renderTest :: String -> Maybe Int -> Doc Text -> Text -> TestTree renderTest title mblen doc expected = testCase title $ render mblen doc @?= expected tests :: [TestTree] tests = [ testCase "offset prefixed" $ (offset (nest 3 (text "**" <> text "thisIsGoingToBeTooLongAnyway" <> text "**") <> blankline :: Doc Text) @?= 35) , renderTest "lblock with chop" Nothing (lblock 4 (text "hi there" :: Doc Text)) "hi t\nhere" , renderTest "nesting should not wrap" (Just 10) (nest 3 (text "abcdefghi" :: Doc Text)) " abcdefghi" , renderTest "simple vcat" (Just 10) (vcat $ map chomp ["aaa", "bbb", "ccc"]) "aaa\nbbb\nccc" , renderTest "vcat with chomp" (Just 10) (chomp "aaa" $$ chomp "bbb" $$ chomp "ccc") "aaa\nbbb\nccc" , renderTest "simple text above line length" (Just 4) ("hello" <+> "there") "hello\nthere" , renderTest "cr" (Just 60) ("hello" <> cr <> "there") "hello\nthere" , renderTest "x $$ cr" Nothing ("x" $$ cr) "x\n" , renderTest "wrapping" (Just 10) (hsep ["hello", "there", "this", "is", "a", "test"]) "hello\nthere this\nis a test" , renderTest "simple box wrapping" (Just 50) (lblock 3 "aa" <> lblock 3 "bb" <> lblock 3 ("aa" <+> "bbbb")) "aa bb aa\n b\n bbb" , renderTest "prefixed with multi paragraphs" (Just 80) (prefixed "> " ("foo" <+> "bar" <> cr <> "baz" <> blankline <> "bim" <+> "bam")) "> foo bar\n> baz\n>\n> bim bam" , renderTest "prefixed with hsep" Nothing (prefixed "> " $ hsep ["a","b","c"]) "> a b c" , renderTest "nest" Nothing (nest 4 "aa\n\nbb\ncc") " aa\n\n bb\n cc" , renderTest "hang" Nothing (hang 4 " - " (chomp "aa\n\nbb\ncc" <> cr) <> hang 4 " - " (chomp "dd\n" <> cr)) " - aa\n\n bb\n cc\n - dd\n" , renderTest "align with box" Nothing ("aa" <> lblock 2 ("bb" $$ "cc") <> "dd") "aabb\n ccdd" , renderTest "centered box" Nothing ("aa" <> cblock 4 ("bb" $$ "cc")) "aa bb\n cc" , renderTest "blanks at beginning" Nothing (blanklines 2 <> "aa") "\naa" -- only one because we treat top of doc as implicit blank , renderTest "blanks at end" Nothing ("aa" <> blanklines 2) "aa\n" , renderTest "blanks at end with multiple" Nothing ("aa" <> cr <> blanklines 2 <> blanklines 0) "aa\n" , renderTest "blanks at end with nesting" Nothing (nest 2 (nest 3 ("aa" <> blankline) <> cr <> blanklines 2) <> blanklines 2) " aa\n" , renderTest "blanks around cr" Nothing ("aa" <> blankline <> cr <> blankline <> "bb") "aa\n\nbb" , renderTest "strange wrap case" (Just 8) (vcat [hang 2 "- " (chomp $ text "aaaaa" <> space <> "bbb"), hang 2 "- " (text "aoeu")]) "- aaaaa\n bbb\n- aoeu" , renderTest "strange wrap case" (Just 8) (text "aaaaa" <> space <> text "bbbbb" <> blankline <> text "ccccc") "aaaaa\nbbbbb\n\nccccc" , renderTest "chomp 1" Nothing (chomp (("aa" <> space) <> blankline) <> "bb") "aabb" , renderTest "chomp 2" Nothing (chomp ("aa" <> space) <> "bb") "aabb" , renderTest "chomp 3" Nothing (chomp "aa") "aa" , renderTest "chomp with nesting" Nothing (chomp (nest 3 ("aa" <> blankline))) " aa" , renderTest "chomp with box at end" Nothing ("aa" <> cr <> chomp (lblock 2 ("aa" <> blankline) <> blankline)) "aa\naa" , renderTest "empty and $$" Nothing ("aa" $$ empty $$ "bb") "aa\nbb" , renderTest "table" Nothing ((rblock 4 "aa" <> lblock 3 " | " <> cblock 4 "bb" <> lblock 3 " | " <> lblock 4 "cc") $$ (rblock 4 "----" <> lblock 3 " | " <> cblock 4 "----" <> lblock 3 " | " <> lblock 4 "----") $$ (rblock 4 "dd" <> lblock 3 " | " <> cblock 4 "ee" <> lblock 3 " | " <> lblock 4 "ff")) " aa | bb | cc\n---- | ---- | ----\n dd | ee | ff" , renderTest "proper wrapping with multiple components" (Just 10) ("aa" <> space <> "bbbbb" <> "ccccc") "aa\nbbbbbccccc" , renderTest "nested wrapped text" (Just 10) (nest 5 (hsep ["hi", "there", "my", "friend"]) <> cr) " hi\n there\n my\n friend\n" , renderTest "aligned wrapped text" Nothing (cblock 7 ("hi" <+> "there")) " hi\n there" , renderTest "afterBreak" (Just 2) ("hi" <+> afterBreak "!" <> afterBreak "?" <> "x" <> afterBreak "?") "hi\n!x" , renderTest "breaks and nest" (Just 5) ("[" <> nest 1 ("aaaaaaaaa" $$ "bbbbbbb") <> "]") "[aaaaaaaaa\n bbbbbbb]" , renderTest "empty nest" Nothing ("aa" $$ nest 3 mempty $$ "bb") "aa\nbb" , renderTest "hsep with empty" Nothing (hsep ["a",mempty,"b"]) "a b" , renderTest "(<+>) with empty" Nothing ("a" <+> mempty <+> "b") "a b" , renderTest "vcat doesn't create newline at end" Nothing (vcat ["aa","bb"] <> "cc") "aa\nbbcc" , renderTest "vcat []" Nothing (vcat []) "" , renderTest "nestle" Nothing (nestle $ blanklines 2 $$ "aa" $$ blanklines 2 <> cr) "aa\n" , renderTest "prefix with box" Nothing (prefixed "> " $ cblock 4 ("aa" $$ "bb")) "> aa\n> bb" , renderTest "breaking space after empty" Nothing (empty <> space <> "x") "x" , renderTest "hang with empty content" Nothing (hang 5 (nowrap "xxx") mempty) "xxx" , renderTest "beforeNonBlank" Nothing (beforeNonBlank "!!" <> " ab" $$ beforeNonBlank "!!" <> "a b") " ab\n!!a b" , renderTest "vfill" Nothing (vfill "|" <> cblock 5 ("a" $$ "bbb" $$ "ccccc") <> lblock 3 "dd" <> vfill "+") "| a dd +\n| bbb +\n|ccccc +" , renderTest "vfill 2" Nothing (vfill "| " <> cblock 5 ("a" $$ "bbb") <> vfill " | " <> lblock 2 ("dd" $$ "ee" $$ "ff") <> vfill " |") "| a | dd |\n| bbb | ee |\n| | ff |" , renderTest "combining character at start" Nothing (text "\870" <> space <> text "a") "\870 a" ] doclayout-0.3/bench/bench.hs0000644000000000000000000000231113527702245014243 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} import Text.DocLayout import Data.Text (Text) import Criterion.Main import Criterion.Types (Config (..)) #if MIN_VERSION_base(4,11,0) #else import Data.Semigroup #endif main :: IO () main = defaultMainWith defaultConfig{ timeLimit = 10.0 } $ cases bigtext :: String bigtext = "Hello there. This is a big text." flowedDoc :: Doc Text flowedDoc = hsep $ map text $ words . unwords $ replicate 500 bigtext cases :: [Benchmark] cases = [ bench "sample document 2" $ nf (render Nothing :: Doc Text -> Text) (nest 3 $ cblock 20 $ vcat $ replicate 15 $ hsep $ map text $ words bigtext) , bench "reflow" $ nf (render (Just 20) :: Doc Text -> Text) flowedDoc , bench "tabular" $ nf (render (Just 80) :: Doc Text -> Text) (let blah = hsep $ map text $ words . unwords $ replicate 50 bigtext in cblock 20 blah <> lblock 30 blah <> rblock 10 blah $$ cblock 50 (nest 5 blah) <> rblock 10 blah) , bench "soft spaces at end of line" $ nf (render Nothing :: Doc Text -> Text) ("a" <> mconcat (replicate 50 (space <> lblock 1 mempty))) ] doclayout-0.3/README.md0000644000000000000000000000155113556442113013032 0ustar0000000000000000# doclayout [![CI tests](https://github.com/jgm/doclayout/workflows/CI%20tests/badge.svg)](https://github.com/jgm/doclayout/actions) This is a prettyprinting library designed for laying out plain-text documents. It originated in the pandoc module Text.Pandoc.Pretty, and its development has been guided by pandoc's needs in rendering wrapped textual documents. In supports wrapping of text on breaking spaces, indentation and other line prefixes, blank lines, and tabular content. Example: ``` haskell Text.DocLayout> mydoc = hang 2 "- " (text "foo" <+> text "bar") Text.DocLayout> putStrLn $ render (Just 20) mydoc - foo bar Text.DocLayout> putStrLn $ render (Just 10) (prefixed "> " (mydoc $+$ mydoc)) > - foo > bar > > - foo > bar ``` The `Doc` type may be parameterized to either `String` or (strict or lazy) `Text`, depending on the desired render target. doclayout-0.3/changelog.md0000644000000000000000000000303013607014436014016 0ustar0000000000000000# doclayout ## 0.3 * Add foldlChar to signature of HasChars [API change]. * Use foldlChar in realLength. This avoids a stack overflow we were getting with long strings in the previous version (with foldrChar). See jgm/pandoc#6031. * Replace isBlank with isBreakable and improved startsWithBlank. Previously isBlank was used in the layout algorithm where what we really wanted was isBreakable. * Avoid unnecessary calculation in updateColumns. * Replace a right fold with a strict left fold. * Add strictness annotations in realLength and updateColumn. ## 0.2.0.1 * Made `realLength` smarter about combining characters. If a string starts with a combining character, that character takes up a width of 1; if the combining character occurs after another character, it takes 0. See jgm/pandoc#5863. * Improve `isBlank`, re-use in rendering code `for BreakingSpace`. * Fixed incorrect `Text` width in renderig blocks. ## 0.2 * Add instances for `Doc`: `Data`, `Typeable`, `Ord`, `Read`, `Generic`. * Add `literal` (like `text`, but polymorphic). * Change some `IsString` constraints to `HasChars`. * Add some default definitions for methods in `HasChars`. * Change `offset` and `minOffset` to be more efficient (in simple cases they no longer render and count line lengths). * Add `updateColumn`. * Fix problem with `lblock`/`cblock`/`rblock` when `chop` is invoked. This caused very strange behavior in which text got reversed in certain circumstances. ## 0.1 * Initial release. doclayout-0.3/LICENSE0000644000000000000000000000277513546153121012566 0ustar0000000000000000Copyright John MacFarlane (c) 2016-2019 All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of Author name here nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. doclayout-0.3/Setup.hs0000644000000000000000000000005613527526133013211 0ustar0000000000000000import Distribution.Simple main = defaultMain doclayout-0.3/doclayout.cabal0000644000000000000000000000401313607012413014527 0ustar0000000000000000name: doclayout version: 0.3 synopsis: A prettyprinting library for laying out text documents. description: doclayout is a prettyprinting library for laying out text documents, with several features not present in prettyprinting libraries designed for code. It was designed for use in pandoc. homepage: https://github.com/jgm/doclayout license: BSD3 license-file: LICENSE author: John MacFarlane maintainer: jgm@berkeley.edu copyright: 2016-19 John MacFarlane category: Text build-type: Simple -- extra-source-files: data-files: README.md changelog.md cabal-version: >=1.10 library hs-source-dirs: src exposed-modules: Text.DocLayout build-depends: base >= 4.9 && < 5, text, mtl, safe if !impl(ghc >= 8.0) build-depends: semigroups == 0.18.* default-language: Haskell2010 ghc-options: -Wall -fno-warn-unused-do-bind test-suite doclayout-test type: exitcode-stdio-1.0 hs-source-dirs: test main-is: test.hs build-depends: base, doclayout, mtl, tasty, tasty-golden, tasty-hunit, text ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 benchmark doclayout-bench Type: exitcode-stdio-1.0 Main-Is: bench.hs Hs-Source-Dirs: bench Build-Depends: doclayout, base >= 4.8 && < 5, criterion >= 1.0 && < 1.6, text, mtl Ghc-Options: -rtsopts -Wall -fno-warn-unused-do-bind Default-Language: Haskell2010 source-repository head type: git location: https://github.com/jgm/doclayout