doclayout 0.5.0.1 → 0.5.0.2
raw patch · 5 files changed
+206/−67 lines, 5 filesdep −semigroupsPVP ok
version bump matches the API change (PVP)
Dependencies removed: semigroups
API changes (from Hackage documentation)
Files
- changelog.md +41/−0
- doclayout.cabal +1/−3
- src/Text/DocLayout.hs +160/−60
- src/Text/DocLayout/HasChars.hs +2/−2
- test/test.hs +2/−2
changelog.md view
@@ -1,5 +1,46 @@ # doclayout +## 0.5.0.2++ * Performance optimizations:++ + Fuse double modify calls in outp, newline, and FCookedText handler.++ + Cache polymorphic prefix in RenderState. Add prefixA, prefixTrimmedA,+ and prefixLen fields to RenderState that cache the polymorphic+ conversions of the Text prefix. This eliminates+ the per-line fromString/T.unpack/realLength conversions in outp,+ newline, and the FCookedText handler. Add a setPrefix helper that+ updates all cached fields atomically. The block handler computes the+ space-appended prefix incrementally to avoid expensive recomputation+ on deeply nested blocks.++ + Avoid redundant realLength calls in mergeBlocks padding.+ Thread precomputed line widths through the merge process by changing+ the internal representation from (Int, [a]) to (Int, [(Int, a)]) where+ the inner Int is each line's rendered width. This avoids calling+ realLength on every line during every merge pass; widths are computed+ once in toBlockSpec and carried through.++ + Remove redundant normalize in flatten for Prefixed. renderList+ already normalizes when processing FPrefixed. This removes the+ double traversal.++ + Use strict foldl' in Attributed foldlChar instance.++ + Add shortcuts for Thai, emoji modifiers, CJK, and fullwidth chars.+ Add new shortcuts to updateMatchStateNarrow and updateMatchStateWide:++ - Thai script (U+0E00-U+0E7F) with combining marks for vowels/tones+ - Zero-width joiner (U+200D) with inline emoji-joining logic+ - Emoji presentation variation selector (U+FE0F)+ - Emoji skin tone modifiers (U+1F3FB-U+1F3FF)+ - CJK Compatibility Ideographs (U+F900-U+FAFF)+ - Fullwidth forms (U+FF01-U+FF60, U+FFE0-U+FFE6)+ - Supplementary CJK Extension B+ (U+20000-U+3FFFF)++ * Use withNumTests instead of deprecated withMaxSuccess in test suite.+ ## 0.5.0.1 * Have `nestle` remove leading CarriageReturn.
doclayout.cabal view
@@ -1,5 +1,5 @@ name: doclayout-version: 0.5.0.1+version: 0.5.0.2 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@@ -33,8 +33,6 @@ emojis >=0.1.2, mtl, safe- if !impl(ghc >= 8.0)- build-depends: semigroups == 0.18.* default-language: Haskell2010 ghc-options: -Wall -fno-warn-unused-do-bind
src/Text/DocLayout.hs view
@@ -298,7 +298,7 @@ flatten (CookedText n a) = [FCookedText n a] flatten (Prefixed p d) | null f = [] | otherwise = [FPrefixed p (N.fromList f)]- where f = (normalize . flatten) d+ where f = flatten d flatten (BeforeNonBlank d) | null f = [] | otherwise = [FBeforeNonBlank (N.fromList f)] where f = flatten d@@ -320,16 +320,28 @@ type DocState a = State (RenderState a) () data RenderState a = RenderState{- output :: [Attr a] -- ^ In reverse order- , prefix :: Text- , usePrefix :: Bool- , lineLength :: Maybe Int -- ^ 'Nothing' means no wrapping- , column :: Int- , newlines :: Int -- ^ Number of preceding newlines- , fontStack :: [Font]- , linkTarget :: Maybe Text -- ^ Current link target+ output :: [Attr a] -- ^ In reverse order+ , prefix :: Text+ , prefixA :: a -- cached: fromString (T.unpack prefix)+ , prefixTrimmedA :: a -- cached: fromString (T.unpack (T.dropWhileEnd isSpace prefix))+ , prefixLen :: !Int -- cached: realLength prefix+ , usePrefix :: Bool+ , lineLength :: Maybe Int -- ^ 'Nothing' means no wrapping+ , column :: Int+ , newlines :: Int -- ^ Number of preceding newlines+ , fontStack :: [Font]+ , linkTarget :: Maybe Text -- ^ Current link target } +setPrefix :: HasChars a => Text -> RenderState a -> RenderState a+setPrefix p st =+ let pa = fromString $ T.unpack p+ in st{ prefix = p+ , prefixA = pa+ , prefixTrimmedA = fromString $ T.unpack $ T.dropWhileEnd isSpace p+ , prefixLen = realLength pa+ }+ peekFont :: RenderState a -> Font peekFont st = case fontStack st of [] -> baseFont@@ -338,27 +350,30 @@ 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 = Attr Nothing baseFont pref : output st- , column = column st + realLength pref }- modify $ \st -> st { output = Attr Nothing baseFont "\n" : output st- , column = 0- , newlines = newlines st + 1- }+ let nl = Attr Nothing baseFont "\n"+ put $! if column st' == 0 && usePrefix st' && not (T.null (prefix st'))+ then let pref = prefixTrimmedA st'+ in st'{ output = nl : Attr Nothing baseFont pref : output st'+ , column = 0+ , newlines = newlines st' + 1 }+ else st'{ output = nl : 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 = if usePrefix st' then fromString $ T.unpack $ prefix st' else mempty- let font = peekFont st'- when (column st' == 0 && not (isNull pref && font == baseFont)) $- modify $ \st -> st{ output = Attr Nothing baseFont pref : output st- , column = column st + realLength pref }- modify $ \st -> st{ output = Attr (linkTarget st) font s : output st- , column = column st + off- , newlines = 0 }+ let pref = if usePrefix st' then prefixA st' else mempty+ font = peekFont st'+ put $! if column st' == 0 && not (isNull pref && font == baseFont)+ then st'{ output = Attr (linkTarget st') font s+ : Attr Nothing baseFont pref+ : output st'+ , column = prefixLen st' + off+ , newlines = 0 }+ else st'{ output = Attr (linkTarget st') font s : output st'+ , column = column st' + off+ , newlines = 0 } -- | Synonym for 'renderPlain'. render :: HasChars a => Maybe Int -> Doc a -> a@@ -397,6 +412,9 @@ where startingState = RenderState{ output = mempty , prefix = mempty+ , prefixA = mempty+ , prefixTrimmedA = mempty+ , prefixLen = 0 , usePrefix = True , lineLength = linelen , column = 0@@ -434,20 +452,21 @@ normalize (FBreakingSpace : FBreakingSpace : xs) = normalize (FBreakingSpace:xs) normalize (x:xs) = x : normalize xs -mergeBlocks :: HasChars a => Int -> (Int, [a]) -> (Int, [a]) -> (Int, [a])+mergeBlocks :: HasChars a => Int -> (Int, [(Int, a)]) -> (Int, [(Int, a)]) -> (Int, [(Int, a)]) mergeBlocks h (w1,lns1) (w2,lns2) =- (w, zipWith (\l1 l2 -> pad w1 l1 <> l2) lns1' lns2')+ (w, zipWith merge 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+ then lns1 ++ replicate (h - len1) (0, mempty) else take h lns1 lns2' = if len2 < h- then lns2 ++ replicate (h - len2) mempty+ then lns2 ++ replicate (h - len2) (0, mempty) else take h lns2- pad n s = s <> replicateChar (n - realLength s) ' '+ merge (len1a, l1) (len2a, l2) = (w1 + len2a, pad w1 len1a l1 <> l2)+ pad n len s = s <> replicateChar (n - len) ' ' renderList :: HasChars a => [FlatDoc a] -> DocState a renderList [] = return ()@@ -458,14 +477,15 @@ renderList (FCookedText off s : xs) = do st' <- get- let pref = if usePrefix st' then fromString $ T.unpack $ prefix st' else mempty- let elems (Attributed x) = reverse $ toList x- when (column st' == 0 && not (isNull pref)) $- modify $ \st -> st{ output = Attr Nothing baseFont pref : output st- , column = column st + realLength pref }- modify $ \st -> st{ output = elems s ++ output st- , column = column st + off- , newlines = 0 }+ let pref = if usePrefix st' then prefixA st' else mempty+ elems (Attributed x) = reverse $ toList x+ put $! if column st' == 0 && not (isNull pref)+ then st'{ output = elems s ++ (Attr Nothing baseFont pref : output st')+ , column = prefixLen st' + off+ , newlines = 0 }+ else st'{ output = elems s ++ output st'+ , column = column st' + off+ , newlines = 0 } renderList xs -- FStyleOpen and FStyleClose are balanced by construction when we create@@ -507,10 +527,15 @@ renderList (FPrefixed pref d : xs) = do st <- get let oldPref = prefix st- put st{ prefix = prefix st <> pref }+ oldPrefixA = prefixA st+ oldPrefixTrimmedA = prefixTrimmedA st+ oldPrefixLen = prefixLen st+ put $! setPrefix (prefix st <> pref) st renderList $ normalize $ N.toList d- modify $ \s -> s{ prefix = oldPref }- -- renderDoc CarriageReturn+ modify $ \s -> s{ prefix = oldPref+ , prefixA = oldPrefixA+ , prefixTrimmedA = oldPrefixTrimmedA+ , prefixLen = oldPrefixLen } renderList xs renderList (FFlush d : xs) = do@@ -574,17 +599,28 @@ let heightOf (FBlock _ ls) = length ls heightOf _ = 1 let maxheight = maximum $ map heightOf (b:bs)- let toBlockSpec (FBlock w ls) = (w, ls)- toBlockSpec (FVFill w t) = (w, map (singleton . (Attr (linkTarget st) font)) (take maxheight $ repeat t))+ let toBlockSpec (FBlock w ls) = (w, map (\l -> (realLength l, l)) ls)+ toBlockSpec (FVFill w t) = (w, map (\l -> (realLength l, l)) $+ map (singleton . (Attr (linkTarget st) font)) (take maxheight $ repeat t)) toBlockSpec _ = (0, []) let (_, lns') = foldl (mergeBlocks maxheight) (toBlockSpec b) (map toBlockSpec bs) let oldPref = prefix st- case column st - realLength oldPref of- n | n > 0 -> modify $ \s -> s{ prefix = oldPref <> T.replicate n " " }+ oldPrefixA = prefixA st+ oldPrefixTrimmedA = prefixTrimmedA st+ oldPrefixLen = prefixLen st+ case column st - oldPrefixLen of+ n | n > 0 -> modify $ \s ->+ s{ prefix = oldPref <> T.replicate n " "+ , prefixA = prefixA s <> replicateChar n ' '+ , prefixLen = prefixLen s + n+ } -- prefixTrimmedA unchanged: trailing spaces are trimmed _ -> return ()- renderList $ intersperse FCarriageReturn (mapMaybe cook lns')- modify $ \s -> s{ prefix = oldPref }+ renderList $ intersperse FCarriageReturn (mapMaybe (cook . snd) lns')+ modify $ \s -> s{ prefix = oldPref+ , prefixA = oldPrefixA+ , prefixTrimmedA = oldPrefixTrimmedA+ , prefixLen = oldPrefixLen } renderList rest isBreakable :: HasChars a => FlatDoc a -> Bool@@ -961,7 +997,7 @@ -- multilingual plane that do not have emoji in them. -- This works in a narrow context. updateMatchStateNarrow :: MatchState -> Char -> MatchState-updateMatchStateNarrow (MatchState firstChar tot _ tentative) !c+updateMatchStateNarrow (MatchState firstChar tot lastChar tentative) !c -- Control characters have width 0: friends don't let friends use tabs | c <= '\x001F' = controlState -- ASCII@@ -1062,12 +1098,44 @@ | c == '\x0BCD' -> combiningState -- Vowel markers | c <= '\x0BCC' -> narrowState -- Main Tamil abugida | otherwise -> narrowState -- Tamil digits and others+ -- Thai+ | c >= '\x0E00' && c <= '\x0E7F' =+ if | c == '\x0E31' -> combiningState -- Mai han akat+ | c >= '\x0E34' && c <= '\x0E3A' -> combiningState -- Vowels and tone marks+ | c >= '\x0E47' && c <= '\x0E4E' -> combiningState -- Mai tai ku and other marks+ | otherwise -> narrowState -- Thai consonants, vowels, digits, symbols+ -- Zero-width joiner: joins two emoji together+ | c == '\x200D' =+ let isLastCharEmojiLike = isJust (IM.lookup (ord lastChar) emojiMap)+ || lastChar == '\xFE0F'+ || isSkinToneModifier lastChar+ in if isLastCharEmojiLike+ then MatchState False (tot - 2) c 2+ else controlState+ -- Emoji presentation variation selector+ | c == '\xFE0F' =+ case IM.lookup (ord lastChar) emojiMap of+ Just (EmojiInfo True _) -> MatchState False tot c 2+ _ -> controlState+ -- CJK Compatibility Ideographs+ | c >= '\xF900' && c <= '\xFAFF' = wideState+ -- Fullwidth forms+ | c >= '\xFF01' && c <= '\xFF60' = wideState+ | c >= '\xFFE0' && c <= '\xFFE6' = wideState+ -- Supplementary CJK: Extension B and beyond+ | c >= '\x20000' && c <= '\x3FFFF' = wideState+ -- Emoji skin tone modifiers+ | c >= '\x1F3FB' && c <= '\x1F3FF' =+ case IM.lookup (ord lastChar) emojiMap of+ Just (EmojiInfo _ True) -> MatchState False tot c 2+ _ -> wideState where- narrowState = MatchState False (tot + tentative) c 1- wideState = MatchState False (tot + tentative) c 2- combiningState = let w = if firstChar then 1 else 0 in MatchState False (tot + tentative) c w- controlState = MatchState False (tot + tentative) c 0- ambiguousState = MatchState False (tot + tentative) c 1+ tot' = tot + tentative+ narrowState = MatchState False tot' c 1+ wideState = MatchState False tot' c 2+ combiningState = let w = if firstChar then 1 else 0 in MatchState False tot' c w+ controlState = MatchState False tot' c 0+ ambiguousState = MatchState False tot' c 1 updateMatchStateNarrow s c = updateMatchStateNoShortcut s c -- | Update a 'MatchState' by processing a character.@@ -1075,7 +1143,7 @@ -- multilingual plane that do not have emoji in them. -- This works in a wide context. updateMatchStateWide :: MatchState -> Char -> MatchState-updateMatchStateWide (MatchState firstChar tot _ tentative) !c+updateMatchStateWide (MatchState firstChar tot lastChar tentative) !c -- Control characters have width 0: friends don't let friends use tabs | c <= '\x001F' = controlState -- ASCII@@ -1163,12 +1231,44 @@ | c == '\x0BCD' -> combiningState -- Vowel markers | c <= '\x0BCC' -> narrowState -- Main Tamil abugida | otherwise -> narrowState -- Tamil digits and others+ -- Thai+ | c >= '\x0E00' && c <= '\x0E7F' =+ if | c == '\x0E31' -> combiningState -- Mai han akat+ | c >= '\x0E34' && c <= '\x0E3A' -> combiningState -- Vowels and tone marks+ | c >= '\x0E47' && c <= '\x0E4E' -> combiningState -- Mai tai ku and other marks+ | otherwise -> narrowState -- Thai consonants, vowels, digits, symbols+ -- Zero-width joiner: joins two emoji together+ | c == '\x200D' =+ let isLastCharEmojiLike = isJust (IM.lookup (ord lastChar) emojiMap)+ || lastChar == '\xFE0F'+ || isSkinToneModifier lastChar+ in if isLastCharEmojiLike+ then MatchState False (tot - 2) c 2+ else controlState+ -- Emoji presentation variation selector+ | c == '\xFE0F' =+ case IM.lookup (ord lastChar) emojiMap of+ Just (EmojiInfo True _) -> MatchState False tot c 2+ _ -> controlState+ -- CJK Compatibility Ideographs+ | c >= '\xF900' && c <= '\xFAFF' = wideState+ -- Fullwidth forms+ | c >= '\xFF01' && c <= '\xFF60' = wideState+ | c >= '\xFFE0' && c <= '\xFFE6' = wideState+ -- Supplementary CJK: Extension B and beyond+ | c >= '\x20000' && c <= '\x3FFFF' = wideState+ -- Emoji skin tone modifiers+ | c >= '\x1F3FB' && c <= '\x1F3FF' =+ case IM.lookup (ord lastChar) emojiMap of+ Just (EmojiInfo _ True) -> MatchState False tot c 2+ _ -> wideState where- narrowState = MatchState False (tot + tentative) c 1- wideState = MatchState False (tot + tentative) c 2- combiningState = let w = if firstChar then 1 else 0 in MatchState False (tot + tentative) c w- controlState = MatchState False (tot + tentative) c 0- ambiguousState = MatchState False (tot + tentative) c 2+ tot' = tot + tentative+ narrowState = MatchState False tot' c 1+ wideState = MatchState False tot' c 2+ combiningState = let w = if firstChar then 1 else 0 in MatchState False tot' c w+ controlState = MatchState False tot' c 0+ ambiguousState = MatchState False tot' c 2 updateMatchStateWide s c = updateMatchStateNoShortcutWide s c -- | Update a 'MatchState' by processing a character, without taking any
src/Text/DocLayout/HasChars.hs view
@@ -9,6 +9,7 @@ import qualified Data.Text.Lazy as TL import Data.Text (Text) import qualified Data.Text.Lazy.Builder as B+import qualified Data.Foldable as F import Data.List (foldl', uncons) import Data.Maybe (fromMaybe) import Text.DocLayout.Attributed@@ -74,8 +75,7 @@ foldlChar _ acc (Attributed S.Empty) = acc foldlChar f acc (Attributed ((Attr _ _ x) :<| xs)) = let l = foldlChar f acc x- innerFold e a = foldlChar f a e- in foldr innerFold l xs+ in F.foldl' (\a (Attr _ _ e) -> foldlChar f a e) l xs splitLines (Attributed s) = fmap Attributed $ reverse $ go ([], S.empty) s where go (lns, cur) S.Empty = cur : lns
test/test.hs view
@@ -331,10 +331,10 @@ , testGroup "all zero-width joiner emoji sequences have width 2" $ zwjEmojis <&> \emoji -> testCase (T.unpack emoji) $ realLength emoji @?= 2 - , testProperty "shortcut provides same answer for string length in a narrow context" . withMaxSuccess 10000 $+ , testProperty "shortcut provides same answer for string length in a narrow context" . withNumTests 10000 $ \(x :: String) -> realLengthNarrowContext x === realLengthNarrowContextNoShortcut x - , testProperty "shortcut provides same answer for string length in a wide context" . withMaxSuccess 10000 $+ , testProperty "shortcut provides same answer for string length in a wide context" . withNumTests 10000 $ \(x :: String) -> realLengthWideContext x === realLengthWideContextNoShortcut x ]