doclayout (empty) → 0.1
raw patch · 8 files changed
+1070/−0 lines, 8 filesdep +basedep +criteriondep +doclayoutsetup-changed
Dependencies added: base, criterion, doclayout, mtl, safe, semigroups, tasty, tasty-golden, tasty-hunit, text
Files
- LICENSE +30/−0
- README.md +27/−0
- Setup.hs +2/−0
- bench/bench.hs +42/−0
- changelog.md +3/−0
- doclayout.cabal +61/−0
- src/Text/DocLayout.hs +652/−0
- test/test.hs +253/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright 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.
+ README.md view
@@ -0,0 +1,27 @@+# doclayout++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.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bench/bench.hs view
@@ -0,0 +1,42 @@+{-# 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)))+ ]
+ changelog.md view
@@ -0,0 +1,3 @@+# doclayout++## 0.1
+ doclayout.cabal view
@@ -0,0 +1,61 @@+name: doclayout+version: 0.1+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
+ src/Text/DocLayout.hs view
@@ -0,0 +1,652 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveTraversable #-}+{- |+ Module : Text.DocLayout+ Copyright : Copyright (C) 2010-2019 John MacFarlane+ License : BSD 3++ Maintainer : John MacFarlane <jgm@berkeley.edu>+ 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+ , 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+ , height+ , charWidth+ , realLength+ -- * Types+ , Doc(..)+ , HasChars(..)+ )++where+import Prelude+import Safe (lastMay, initSafe)+import Control.Monad+import Control.Monad.State.Strict+import Data.Char (isSpace)+import Data.List (intersperse, foldl')+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.+class (IsString a, Semigroup a, Monoid a, Show a) => HasChars a where+ foldrChar :: (Char -> b -> b) -> b -> a -> b+ splitLines :: a -> [a]+ replicateChar :: Int -> Char -> a+ isNull :: a -> Bool++instance HasChars Text where+ foldrChar = T.foldr+ splitLines = T.splitOn "\n"+ replicateChar n c = T.replicate n (T.singleton c)+ isNull = T.null++instance HasChars String where+ foldrChar = foldr+ splitLines = lines . (++"\n")+ replicateChar = replicate+ isNull = null++instance HasChars TL.Text where+ foldrChar = TL.foldr+ 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, Eq, Functor, Foldable, Traversable)++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 IsString 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:_) | isBlank x -> renderList xs+ | otherwise -> renderDoc d >> renderList xs+ [] -> renderList xs+ where+ isBlank :: HasChars a => Doc a -> Bool+ isBlank BreakingSpace = True+ isBlank CarriageReturn = True+ isBlank NewLine = True+ isBlank (BlankLines _) = True+ isBlank (Text _ t) = foldrChar+ (\c _ -> if isSpace c then True else False)+ False t+ isBlank _ = False+++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 isText (Text _ _) = True+ isText (Block _ _) = True+ isText (AfterBreak _) = True+ isText _ = False+ let isBreakingSpace BreakingSpace = True+ isBreakingSpace _ = False+ let xs' = dropWhile isBreakingSpace xs+ let next = takeWhile isText xs'+ st <- get+ let off = foldl' (+) 0 $ map offsetOf 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 (Text 0) lns')+ modify $ \s -> s{ prefix = oldPref }+ renderList rest++renderList (x:_) = error $ "renderList encountered " ++ show x++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++-- | A literal string.+text :: IsString a => String -> Doc a+text "" = mempty+text s = case break (=='\n') s of+ ("", "") -> Empty+ (xs, "") -> Text (realLength xs) (fromString xs)+ ("", _:ys) -> NewLine <> text ys+ (xs, _:ys) -> Text (realLength xs) (fromString xs) <>+ NewLine <> text ys++-- | A character.+char :: IsString 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 :: HasChars a => Doc a -> Int+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 d = maximum (0: map realLength (splitLines $ render (Just 0) d))++-- | @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, l' <> cs):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 :: IsString a => Doc a -> Doc a+braces = inside (char '{') (char '}')++-- | Puts a 'Doc' in square brackets.+brackets :: IsString a => Doc a -> Doc a+brackets = inside (char '[') (char ']')++-- | Puts a 'Doc' in parentheses.+parens :: IsString a => Doc a -> Doc a+parens = inside (char '(') (char ')')++-- | Wraps a 'Doc' in single quotes.+quotes :: IsString a => Doc a -> Doc a+quotes = inside (char '\'') (char '\'')++-- | Wraps a 'Doc' in double quotes.+doubleQuotes :: IsString 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 = foldrChar (\c tot -> tot + charWidth c) 0+
+ test/test.hs view
@@ -0,0 +1,253 @@+{-# 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 =+ [+ 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 |"+ ]