diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,14 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## 0.1.2.0 - 2026-09-04 + +- Add `ShapedSpan` for runs with caller-supplied per-codepoint advances. +- Add `prepareWithAdvances`, the single-run shortcut for `ShapedSpan`. +- Export `charAdvances`. +- Replace `MeasuredSegment.graphemeWidths :: [(Int, Float)]` with `graphemes :: [Grapheme]`. +- Fix emergency breaks splitting a shaping cluster or a ligature. + ## 0.1.0.2 - 2026-08-28 - Keep leading spaces after a hard break and at the start of the text; only fold them after a soft wrap. diff --git a/kb-text-layout.cabal b/kb-text-layout.cabal --- a/kb-text-layout.cabal +++ b/kb-text-layout.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: kb-text-layout -version: 0.1.0.2 +version: 0.1.2.0 synopsis: Multiline text measurement & layout. category: Text author: IC Rainbow @@ -277,6 +277,7 @@ base >=4.18 && <5 , demos , kb-text-layout + , kb-text-shape , tasty , tasty-hunit , text diff --git a/src/KB/Text/Layout/Analysis.hs b/src/KB/Text/Layout/Analysis.hs --- a/src/KB/Text/Layout/Analysis.hs +++ b/src/KB/Text/Layout/Analysis.hs @@ -57,8 +57,8 @@ tailorSoftBreaks t soft = merge (filter (not . insideRange) soft) querySplits where n = Text.length t - chars = Vector.fromList (Text.unpack t) - at i = chars Vector.! i + codepoints = Vector.fromList (Text.unpack t) + at i = codepoints Vector.! i insideRange p = p >= 2 && p < n diff --git a/src/KB/Text/Layout/Break.hs b/src/KB/Text/Layout/Break.hs --- a/src/KB/Text/Layout/Break.hs +++ b/src/KB/Text/Layout/Break.hs @@ -22,7 +22,7 @@ , shrinkwrap ) where -import Data.Foldable (foldl') +import Data.Foldable qualified as Foldable import Data.Maybe (mapMaybe) import Data.Text (Text) import Data.Text qualified as Text @@ -30,7 +30,7 @@ import Data.Vector qualified as Vector import KB.Text.Layout.Analysis (BreakKind (..)) -import KB.Text.Layout.Measure (MeasuredSegment (..), PreparedText (..)) +import KB.Text.Layout.Measure (Grapheme (..), MeasuredSegment (..), PreparedText (..)) layoutGreedy :: PreparedText -> Float -> [LineRange] layoutGreedy prepared maxWidth = go (Cursor 0 0) @@ -223,7 +223,7 @@ | otherwise = let seg = segs Vector.! i - segWidth = if g == 0 then seg.width else sum (map snd (dropChars g seg.graphemeWidths)) + segWidth = if g == 0 then seg.width else sum (map (.width) (dropCodepoints g seg.graphemes)) after = Cursor (i + 1) 0 spaceLike = scanSeg @@ -274,14 +274,14 @@ emergency seg i g acc visible = let - ws = dropChars g seg.graphemeWidths + ws = dropCodepoints g seg.graphemes counted = countFits acc ws count | counted == 0 && visible <= epsilon = 1 | otherwise = counted taken = take count ws - g' = g + sum (map fst taken) - takenWidth = sum (map snd taken) + g' = g + sum (map (.codepoints) taken) + takenWidth = sum (map (.width) taken) in if count == 0 then (emit (Cursor i g) acc Overflowed, resume (Cursor i g)) @@ -292,8 +292,8 @@ where fits n w = \case [] -> n - (_, cw) : rest - | w + cw <= maxWidth + epsilon -> fits (n + 1) (w + cw) rest + g : rest + | w + g.width <= maxWidth + epsilon -> fits (n + 1) (w + g.width) rest | otherwise -> n advanceCursor seg i g' @@ -336,9 +336,9 @@ | startG == 0 && endG == Text.length seg.text = seg.width | otherwise = - sum . map snd $ - takeChars (endG - startG) $ - dropChars startG seg.graphemeWidths + sum . map (.width) $ + takeCodepoints (endG - startG) $ + dropCodepoints startG seg.graphemes in case seg.kind of SoftHyphen -> Nothing @@ -402,7 +402,7 @@ _ -> Just (Text.take (endG - startG) (Text.drop startG seg.text)) layoutStats :: [LineRange] -> LayoutStats -layoutStats = foldl' step LayoutStats{lineCount = 0, maxLineWidth = 0} +layoutStats = Foldable.foldl' step LayoutStats{lineCount = 0, maxLineWidth = 0} where step stats line = LayoutStats @@ -447,16 +447,16 @@ where mid = (lo + hi) / 2 -dropChars :: Int -> [(Int, Float)] -> [(Int, Float)] -dropChars n xs +dropCodepoints :: Int -> [Grapheme] -> [Grapheme] +dropCodepoints n xs | n <= 0 = xs | otherwise = case xs of [] -> [] - (len, _) : rest -> dropChars (n - len) rest + Grapheme{codepoints} : rest -> dropCodepoints (n - codepoints) rest -takeChars :: Int -> [(Int, Float)] -> [(Int, Float)] -takeChars n xs +takeCodepoints :: Int -> [Grapheme] -> [Grapheme] +takeCodepoints n xs | n <= 0 = [] | otherwise = case xs of [] -> [] - x@(len, _) : rest -> x : takeChars (n - len) rest + g@Grapheme{codepoints} : rest -> g : takeCodepoints (n - codepoints) rest diff --git a/src/KB/Text/Layout/Measure.hs b/src/KB/Text/Layout/Measure.hs --- a/src/KB/Text/Layout/Measure.hs +++ b/src/KB/Text/Layout/Measure.hs @@ -6,13 +6,17 @@ -- * Preparing text for layout , prepare + , prepareWithAdvances , prepareStyled , PreparedText (..) , MeasuredSegment (..) + , Grapheme (..) , Span (..) + , Advances -- * Measuring , measure + , charAdvances -- * Styles , newStyle @@ -24,9 +28,9 @@ import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as Text -import Data.Traversable (mapAccumL) import Data.Vector (Vector) import Data.Vector qualified as Vector +import Data.Vector.Storable qualified as Storable import KB.Text.Layout.Analysis (BreakKind (..), Segment (..), analyze) import KB.Text.Layout.Segmentation qualified as Segmentation import KB.Text.Shape qualified as TextShape @@ -35,10 +39,13 @@ prepare :: LayoutContext -> Style -> Text -> IO PreparedText prepare ctx style t = prepareStyled ctx [TextSpan style t] +prepareWithAdvances :: LayoutContext -> Style -> Text -> Advances -> IO PreparedText +prepareWithAdvances ctx style t advance = prepareStyled ctx [ShapedSpan style t advance] + prepareStyled :: LayoutContext -> [Span] -> IO PreparedText prepareStyled ctx spans = do segments <- Vector.fromList . concat <$> traverse spanSegments spans - pure PreparedText{segments} + pure $! PreparedText{segments} where spanSegments = \case AtomSpan style label w -> @@ -48,63 +55,95 @@ , kind = Atomic , width = w , style = style.key - , graphemeWidths = [(Text.length label, w)] + , graphemes = [Grapheme{codepoints = Text.length label, width = w}] } ] - TextSpan style t -> do - advance <- charAdvances ctx style t - spaceWidth <- measure ctx style " " - hyphenWidth <- measure ctx style "-" - let - prefix = Vector.scanl' (+) 0 advance - slice off n = prefix Vector.! (off + n) - prefix Vector.! off - clusterWidths off = \case - [] -> [] - c : rest -> - let k = Text.length c - in (k, slice off k) : clusterWidths (off + k) rest - segmentAt off seg = - let - n = Text.length seg.text - width = case seg.kind of - SoftHyphen -> hyphenWidth - ZeroWidthBreak -> 0 - HardBreak -> 0 - Tab -> fromIntegral n * spaceWidth - _ -> slice off n - graphemeWidths = case seg.kind of - Word -> clusterWidths off (Segmentation.clusters seg.text) - Glue -> clusterWidths off (Segmentation.clusters seg.text) - _ -> [(n, width)] - in - ( off + n - , MeasuredSegment{text = seg.text, kind = seg.kind, width, style = style.key, graphemeWidths} - ) - pure (snd (mapAccumL segmentAt 0 (analyze t))) + TextSpan style t -> + textSegments style t <$> charAdvances ctx style t + ShapedSpan style t advance + | Storable.length advance /= Text.length t -> + error $ + "ShapedSpan: expected one advance per codepoint, got " + <> show (Storable.length advance) + <> " advances for " + <> show (Text.length t) + <> " codepoints" + | otherwise -> + pure (textSegments style t advance) +textSegments :: Style -> Text -> Advances -> [MeasuredSegment] +textSegments style t advance = go 0 (analyze t) + where + prefix = Storable.scanl' (+) 0 advance + slice off n = prefix Storable.! (off + n) - prefix Storable.! off + clusterWidths off = \case + [] -> [] + c : rest -> + let (n, rest') = absorbZeroWidth (Text.length c) rest + in Grapheme{codepoints = n, width = slice off n} : clusterWidths (off + n) rest' + where + absorbZeroWidth n = \case + c : rest | slice (off + n) (Text.length c) == 0 -> absorbZeroWidth (n + Text.length c) rest + rest -> (n, rest) + go !off = \case + [] -> [] + seg : rest -> + let !measured = segmentAt off seg + in measured : go (off + Text.length seg.text) rest + segmentAt off seg = + MeasuredSegment + { text = seg.text + , kind = seg.kind + , width + , style = style.key + , graphemes + } + where + n = Text.length seg.text + width = case seg.kind of + SoftHyphen -> style.hyphenWidth + ZeroWidthBreak -> 0 + HardBreak -> 0 + Tab -> fromIntegral n * style.spaceWidth + _ -> slice off n + graphemes + | seg.kind == Word || seg.kind == Glue = clusterWidths off (Segmentation.clusters seg.text) + | otherwise = [Grapheme{codepoints = n, width}] + data PreparedText = PreparedText { segments :: Vector MeasuredSegment } + deriving stock (Eq, Show) data MeasuredSegment = MeasuredSegment { text :: Text , kind :: BreakKind , width :: Float , style :: Int - , graphemeWidths :: [(Int, Float)] + , graphemes :: [Grapheme] } + deriving stock (Eq, Show) +data Grapheme = Grapheme + { codepoints :: Int + , width :: Float + } + deriving stock (Eq, Show) + data Span = TextSpan Style Text + | ShapedSpan Style Text Advances | AtomSpan Style Text Float -charAdvances :: LayoutContext -> Style -> Text -> IO (Vector Float) +type Advances = Storable.Vector Float + +charAdvances :: LayoutContext -> Style -> Text -> IO Advances charAdvances ctx style t - | Text.null t = pure Vector.empty + | Text.null t = pure Storable.empty | otherwise = do runs <- TextShape.run ctx.shape (TextShape.withFont_ style.font (TextShape.text_ t)) contributions <- concat <$> traverse runContributions runs - pure (Vector.map (* style.scale) (Vector.accum (+) (Vector.replicate n 0) contributions)) + pure (Storable.map (* style.scale) (Storable.accum (+) (Storable.replicate n 0) contributions)) where n = Text.length t runContributions (run, glyphs) = do @@ -124,27 +163,38 @@ Map.lookup (style.key, t) <$> readIORef ctx.metrics >>= \case Just w -> pure w Nothing -> do - runs <- TextShape.run ctx.shape (TextShape.withFont_ style.font (TextShape.text_ t)) - let runWidth (run, glyphs) = do - info <- Font.getFontInfo run.font - let toGrid = style.grid / fromIntegral info.unitsPerEm - pure (sum [fromIntegral g.advanceX | g <- glyphs] * toGrid) - w <- (* style.scale) . sum <$> traverse runWidth runs + w <- shapedWidth ctx style.font style.grid style.scale t modifyIORef' ctx.metrics (Map.insert (style.key, t) w) pure w +shapedWidth :: LayoutContext -> Font.Font -> Float -> Float -> Text -> IO Float +shapedWidth ctx font grid scale t = do + runs <- TextShape.run ctx.shape (TextShape.withFont_ font (TextShape.text_ t)) + let runWidth (run, glyphs) = do + info <- Font.getFontInfo run.font + let toGrid = grid / fromIntegral info.unitsPerEm + pure (sum [fromIntegral g.advanceX | g <- glyphs] * toGrid) + (* scale) . sum <$> traverse runWidth runs + newStyle :: LayoutContext -> Font.Font -> Float -> IO Style newStyle ctx font size = do info <- Font.getFontInfo font key <- atomicModifyIORef' ctx.styleKeys \n -> (n + 1, n) + let + scale = size / fromIntegral info.capitalHeight + grid = fromIntegral info.unitsPerEm + spaceWidth <- shapedWidth ctx font grid scale " " + hyphenWidth <- shapedWidth ctx font grid scale "-" pure Style { key , font , size , em = size * Font.emToCaps info - , scale = size / fromIntegral info.capitalHeight - , grid = fromIntegral info.unitsPerEm + , scale + , grid + , spaceWidth + , hyphenWidth } data Style = Style @@ -154,6 +204,8 @@ , em :: Float , scale :: Float , grid :: Float + , spaceWidth :: Float + , hyphenWidth :: Float } createLayoutContext :: TextShape.Context -> IO LayoutContext diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,183 +1,299 @@ module Main (main) where -import Data.Foldable (for_) +import Control.Exception (ErrorCall, try) +import Data.Foldable (for_, toList) import Data.Text (Text) import Data.Text qualified as Text import Data.Vector qualified as Vector -import Test.Tasty (defaultMain, testGroup) -import Test.Tasty.HUnit (testCase, (@?=)) +import Data.Vector.Storable qualified as Storable +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) import KB.Text.Layout.Analysis (BreakKind (..)) import KB.Text.Layout.Analysis qualified as Analysis import KB.Text.Layout.Break (Cursor (..), LineEnd (..), LineStretch (..)) import KB.Text.Layout.Break qualified as Break import KB.Text.Layout.Html qualified as Html -import KB.Text.Layout.Measure (MeasuredSegment (..), PreparedText (..)) +import KB.Text.Layout.Measure (Grapheme (..), LayoutContext, MeasuredSegment (..), PreparedText (..), Span (..), Style) +import KB.Text.Layout.Measure qualified as Measure import KB.Text.Layout.Segmentation qualified as Segmentation +import KB.Text.Shape qualified as TextShape main :: IO () main = - defaultMain $ - testGroup - "kb-text-layout" - [ testCase "single line" do - (Break.layoutStats (Break.layoutGreedy (fromSegments prepared) 200)).lineCount @?= 1 - , testCase "break at space" do - (Break.layoutStats (Break.layoutGreedy (fromSegments prepared) 100)).lineCount @?= 2 - , testCase "emergency graphemes" do - materialized prepared 30 @?= ["hel", "lo", "wor", "ld"] - , testCase "soft hyphen" do - materialized hyphenated 30 @?= ["hy-", "phen"] - , testCase "soft hyphen too wide to use" do - materialized wideHyphen 30 @?= ["hyphen"] - , testCase "hard break" do - materialized broken 1000 @?= ["one", "two"] - , testCase "glue holds" do - materialized glued 60 @?= ["aaa\xA0\&bb", "b"] - , testCase "atomic breaks before" do - materialized [word 50 "word", atom 40 "[pill]"] 60 @?= ["word", "[pill]"] - , testCase "atomic breaks after" do - materialized [atom 40 "[pill]", word 50 "word"] 60 @?= ["[pill]", "word"] - , testCase "atomic never splits" do - materialized [word 30 "abc", space, atom 100 "[wide-pill]"] 60 - @?= ["abc", "[wide-pill]"] - , testCase "stepping matches walk" do - stepped prepared (replicate 10 30) @?= materialized prepared 30 - , testCase "variable widths route lines" do - stepped rhythm [70, 30] @?= ["aaa bbb", "ccc"] - , testCase "narrower route reflows" do - stepped rhythm [40, 40, 40] @?= ["aaa", "bbb", "ccc"] - , testCase "slices merge same-style runs" do - let prep = fromSegments styled - map (\s -> (s.text, s.style)) (concatMap (Break.materializeSlices prep) (Break.layoutGreedy prep 200)) - @?= [("aaa bbb ", 1), ("ccc", 2)] - , testCase "slices mark atoms with widths" do - let prep = fromSegments [styledWord 1 30 "hi", styledSpace 1, atom 40 "[pill]"] - map (\s -> (s.text, s.atom, s.width)) (concatMap (Break.materializeSlices prep) (Break.layoutGreedy prep 200)) - @?= [("hi ", False, 40), ("[pill]", True, 40)] - , testCase "slices absorb the soft hyphen" do - let prep = fromSegments hyphenated - map (\s -> (s.text, s.width)) (concatMap (Break.materializeSlices prep) (take 1 (Break.layoutGreedy prep 30))) - @?= [("hy-", 25)] - , testCase "slices concat to materialized text" do - for_ [prepared, hyphenated, broken, glued, rhythm, styled] \xs -> - for_ [25, 30, 60, 200] \w -> do - let prep = fromSegments xs - for_ (Break.layoutGreedy prep w) \line -> - Text.concat (map (\s -> s.text) (Break.materializeSlices prep line)) - @?= Break.materializeLineRange prep line - , testCase "emergency breaks respect clusters" do - let accented = - [ MeasuredSegment - { text = "a\x301\&bc" - , kind = Word - , width = 30 - , style = 0 - , graphemeWidths = [(2, 10), (1, 10), (1, 10)] - } - ] - materialized accented 10 @?= ["a\x301", "b", "c"] - materialized accented 20 @?= ["a\x301\&b", "c"] - , testCase "kbts clusters marks, zwj sequences, and flags" do - Segmentation.clusters "a\x301\&bc" @?= ["a\x301", "b", "c"] - Segmentation.clusters "\128104\8205\128105\8205\128103 ok" - @?= ["\128104\8205\128105\8205\128103", " ", "o", "k"] - Segmentation.clusters "\127482\127462\127482\127462" @?= ["\127482\127462", "\127482\127462"] - , testCase "kbts break positions arrive as Char offsets" do - Segmentation.boundaries "" @?= [] - Segmentation.boundaries "\128512\&a" @?= [0, 1, 2] - Segmentation.boundaries "a\128104\8205\128105\8205\128103b" @?= [0, 1, 6, 7] - Segmentation.softBreaks "\26085\26412\35486 ok" @?= [1, 2, 4, 6] - Segmentation.softBreaks "go \128105\127997\8205\128640 now" @?= [3, 8, 11] - Segmentation.wordBreaks "one two" @?= [0, 3, 4, 7] - , testCase "kbts soft breaks split words at line break opportunities" do - map (\s -> (s.text, s.kind)) (Analysis.analyze "well-known") - @?= [("well-", Word), ("", ZeroWidthBreak), ("known", Word)] - map (\s -> s.text) (Analysis.analyze "\26085\26412\12290\35486") - @?= ["\26085", "", "\26412\12290", "", "\35486"] - map (\s -> s.text) (Analysis.analyze "ab\128104\8205\128105\8205\128103\&cd") - @?= ["ab\128104\8205\128105\8205\128103", "", "cd"] - map (\s -> (s.text, s.kind)) (Analysis.analyze "plain words") - @?= [("plain", Word), (" ", Space), ("words", Word)] - , testCase "tailored breaks split url queries and hold dash ranges" do - map (\s -> s.text) (Analysis.analyze "see example.com/a?b=1&c#d now") - @?= ["see", " ", "example.com/", "", "a?", "", "b", "", "=1", "", "&c", "", "#d", " ", "now"] - map (\s -> s.text) (Analysis.analyze "pages 3\8211\&5 and 2+2=4 at AT&T") - @?= ["pages", " ", "3\8211\&5", " ", "and", " ", "2+2=4", " ", "at", " ", "AT&T"] - map (\s -> s.text) (Analysis.analyze "10:30-11:00") @?= ["10:30-11:00"] - , testCase "line ends carry their reason" do - let ends xs w = map (\l -> l.ended) (Break.layoutGreedy (fromSegments xs) w) - ends prepared 30 @?= [Overflowed, Wrapped, Overflowed, Finished] - ends hyphenated 30 @?= [Hyphenated, Finished] - ends broken 1000 @?= [HardBroken, Finished] - ends rhythm 70 @?= [Wrapped, Finished] - , testCase "line stretch counts interior spaces only" do - let - prep = fromSegments rhythm - stretches w = map (Break.lineStretch prep) (Break.layoutGreedy prep w) - stretches 200 @?= [LineStretch{spaces = 2, width = 20}] - stretches 70 @?= [LineStretch{spaces = 1, width = 10}, LineStretch{spaces = 0, width = 0}] - map (Break.lineStretch (fromSegments indented)) (Break.layoutGreedy (fromSegments indented) 200) - @?= [LineStretch{spaces = 0, width = 0}, LineStretch{spaces = 0, width = 0}, LineStretch{spaces = 0, width = 0}] - , testCase "leading spaces survive hard breaks" do - let - prep = fromSegments indented - lns = Break.layoutGreedy prep 200 - map (Break.materializeLineRange prep) lns @?= ["main", "do", " putStrLn"] - map (\l -> (l.from, l.width)) lns @?= [(Cursor 0 0, 40), (Cursor 2 0, 20), (Cursor 4 0, 100)] - map (Break.materializeLineRange prep) (Break.layoutOptimal prep 200) @?= ["main", "do", " putStrLn"] - materialized [space, word 40 "word"] 200 @?= [" word"] - materialized [indent, word 80 "putStrLn"] 90 @?= [" putStrL", "n"] - stepped indented [200, 200, 200] @?= ["main", "do", " putStrLn"] - , testCase "leading spaces still fold after a wrap" do - let prep = fromSegments [word 30 "aaa", indent, word 30 "bbb"] - materialized [word 30 "aaa", indent, word 30 "bbb"] 40 @?= ["aaa", "bbb"] - map (Break.materializeLineRange prep) (Break.layoutOptimal prep 40) @?= ["aaa", "bbb"] - , testCase "shrinkwrap tightens without adding lines" do - Break.shrinkwrap (fromSegments rhythm) 80 @?= 70 - Break.shrinkwrap (fromSegments rhythm) 200 @?= 110 - Break.shrinkwrap (fromSegments prepared) 45 @?= 30 - , testCase "optimal layout beats greedy on loose middle lines" do - let - squeeze = [word 60 "aaaaaa", space, word 10 "b", space, word 10 "c", space, word 60 "dddddd"] - prep = fromSegments squeeze - materialized squeeze 77 @?= ["aaaaaa", "b c", "dddddd"] - map (Break.materializeLineRange prep) (Break.layoutOptimal prep 77) @?= ["aaaaaa b", "c dddddd"] - , testCase "optimal layout agrees with greedy where greedy is fine" do - let optimal xs w = map (Break.materializeLineRange (fromSegments xs)) (Break.layoutOptimal (fromSegments xs) w) - optimal rhythm 70 @?= ["aaa bbb", "ccc"] - optimal hyphenated 30 @?= ["hy-", "phen"] - optimal broken 1000 @?= ["one", "two"] - , testCase "optimal layout falls back to greedy when infeasible" do - map (Break.materializeLineRange (fromSegments glued)) (Break.layoutOptimal (fromSegments glued) 60) - @?= materialized glued 60 - , testCase "html renderer escapes and anchors baselines" do - let - prep = fromSegments [styledWord 1 30 "a do + font <- TextShape.pushFontFromFile shape "demos/assets/NotoSans-Regular.ttf" 0 + ctx <- Measure.createLayoutContext shape + body <- Measure.newStyle ctx font 1.0 + accent <- Measure.newStyle ctx font 1.5 + defaultMain $ + testGroup + "kb-text-layout" + [ layoutTests + , prepareTests ctx body accent + ] +layoutTests :: TestTree +layoutTests = + testGroup + "layout" + [ testCase "single line" do + (Break.layoutStats (Break.layoutGreedy (fromSegments prepared) 200)).lineCount @?= 1 + , testCase "break at space" do + (Break.layoutStats (Break.layoutGreedy (fromSegments prepared) 100)).lineCount @?= 2 + , testCase "emergency graphemes" do + materialized prepared 30 @?= ["hel", "lo", "wor", "ld"] + , testCase "soft hyphen" do + materialized hyphenated 30 @?= ["hy-", "phen"] + , testCase "soft hyphen too wide to use" do + materialized wideHyphen 30 @?= ["hyphen"] + , testCase "hard break" do + materialized broken 1000 @?= ["one", "two"] + , testCase "glue holds" do + materialized glued 60 @?= ["aaa\xA0\&bb", "b"] + , testCase "atomic breaks before" do + materialized [word 50 "word", atom 40 "[pill]"] 60 @?= ["word", "[pill]"] + , testCase "atomic breaks after" do + materialized [atom 40 "[pill]", word 50 "word"] 60 @?= ["[pill]", "word"] + , testCase "atomic never splits" do + materialized [word 30 "abc", space, atom 100 "[wide-pill]"] 60 + @?= ["abc", "[wide-pill]"] + , testCase "stepping matches walk" do + stepped prepared (replicate 10 30) @?= materialized prepared 30 + , testCase "variable widths route lines" do + stepped rhythm [70, 30] @?= ["aaa bbb", "ccc"] + , testCase "narrower route reflows" do + stepped rhythm [40, 40, 40] @?= ["aaa", "bbb", "ccc"] + , testCase "slices merge same-style runs" do + let prep = fromSegments styled + map (\s -> (s.text, s.style)) (concatMap (Break.materializeSlices prep) (Break.layoutGreedy prep 200)) + @?= [("aaa bbb ", 1), ("ccc", 2)] + , testCase "slices mark atoms with widths" do + let prep = fromSegments [styledWord 1 30 "hi", styledSpace 1, atom 40 "[pill]"] + map (\s -> (s.text, s.atom, s.width)) (concatMap (Break.materializeSlices prep) (Break.layoutGreedy prep 200)) + @?= [("hi ", False, 40), ("[pill]", True, 40)] + , testCase "slices absorb the soft hyphen" do + let prep = fromSegments hyphenated + map (\s -> (s.text, s.width)) (concatMap (Break.materializeSlices prep) (take 1 (Break.layoutGreedy prep 30))) + @?= [("hy-", 25)] + , testCase "slices concat to materialized text" do + for_ [prepared, hyphenated, broken, glued, rhythm, styled] \xs -> + for_ [25, 30, 60, 200] \w -> do + let prep = fromSegments xs + for_ (Break.layoutGreedy prep w) \line -> + Text.concat (map (\s -> s.text) (Break.materializeSlices prep line)) + @?= Break.materializeLineRange prep line + , testCase "emergency breaks respect clusters" do + let accented = + [ MeasuredSegment + { text = "a\x301\&bc" + , kind = Word + , width = 30 + , style = 0 + , graphemes = [Grapheme 2 10, Grapheme 1 10, Grapheme 1 10] + } + ] + materialized accented 10 @?= ["a\x301", "b", "c"] + materialized accented 20 @?= ["a\x301\&b", "c"] + , testCase "kbts clusters marks, zwj sequences, and flags" do + Segmentation.clusters "a\x301\&bc" @?= ["a\x301", "b", "c"] + Segmentation.clusters "\128104\8205\128105\8205\128103 ok" + @?= ["\128104\8205\128105\8205\128103", " ", "o", "k"] + Segmentation.clusters "\127482\127462\127482\127462" @?= ["\127482\127462", "\127482\127462"] + , testCase "kbts break positions arrive as Char offsets" do + Segmentation.boundaries "" @?= [] + Segmentation.boundaries "\128512\&a" @?= [0, 1, 2] + Segmentation.boundaries "a\128104\8205\128105\8205\128103b" @?= [0, 1, 6, 7] + Segmentation.softBreaks "\26085\26412\35486 ok" @?= [1, 2, 4, 6] + Segmentation.softBreaks "go \128105\127997\8205\128640 now" @?= [3, 8, 11] + Segmentation.wordBreaks "one two" @?= [0, 3, 4, 7] + , testCase "kbts soft breaks split words at line break opportunities" do + map (\s -> (s.text, s.kind)) (Analysis.analyze "well-known") + @?= [("well-", Word), ("", ZeroWidthBreak), ("known", Word)] + map (\s -> s.text) (Analysis.analyze "\26085\26412\12290\35486") + @?= ["\26085", "", "\26412\12290", "", "\35486"] + map (\s -> s.text) (Analysis.analyze "ab\128104\8205\128105\8205\128103\&cd") + @?= ["ab\128104\8205\128105\8205\128103", "", "cd"] + map (\s -> (s.text, s.kind)) (Analysis.analyze "plain words") + @?= [("plain", Word), (" ", Space), ("words", Word)] + , testCase "tailored breaks split url queries and hold dash ranges" do + map (\s -> s.text) (Analysis.analyze "see example.com/a?b=1&c#d now") + @?= ["see", " ", "example.com/", "", "a?", "", "b", "", "=1", "", "&c", "", "#d", " ", "now"] + map (\s -> s.text) (Analysis.analyze "pages 3\8211\&5 and 2+2=4 at AT&T") + @?= ["pages", " ", "3\8211\&5", " ", "and", " ", "2+2=4", " ", "at", " ", "AT&T"] + map (\s -> s.text) (Analysis.analyze "10:30-11:00") @?= ["10:30-11:00"] + , testCase "line ends carry their reason" do + let ends xs w = map (\l -> l.ended) (Break.layoutGreedy (fromSegments xs) w) + ends prepared 30 @?= [Overflowed, Wrapped, Overflowed, Finished] + ends hyphenated 30 @?= [Hyphenated, Finished] + ends broken 1000 @?= [HardBroken, Finished] + ends rhythm 70 @?= [Wrapped, Finished] + , testCase "line stretch counts interior spaces only" do + let + prep = fromSegments rhythm + stretches w = map (Break.lineStretch prep) (Break.layoutGreedy prep w) + stretches 200 @?= [LineStretch{spaces = 2, width = 20}] + stretches 70 @?= [LineStretch{spaces = 1, width = 10}, LineStretch{spaces = 0, width = 0}] + map (Break.lineStretch (fromSegments indented)) (Break.layoutGreedy (fromSegments indented) 200) + @?= [LineStretch{spaces = 0, width = 0}, LineStretch{spaces = 0, width = 0}, LineStretch{spaces = 0, width = 0}] + , testCase "leading spaces survive hard breaks" do + let + prep = fromSegments indented + lns = Break.layoutGreedy prep 200 + map (Break.materializeLineRange prep) lns @?= ["main", "do", " putStrLn"] + map (\l -> (l.from, l.width)) lns @?= [(Cursor 0 0, 40), (Cursor 2 0, 20), (Cursor 4 0, 100)] + map (Break.materializeLineRange prep) (Break.layoutOptimal prep 200) @?= ["main", "do", " putStrLn"] + materialized [space, word 40 "word"] 200 @?= [" word"] + materialized [indent, word 80 "putStrLn"] 90 @?= [" putStrL", "n"] + stepped indented [200, 200, 200] @?= ["main", "do", " putStrLn"] + , testCase "leading spaces still fold after a wrap" do + let prep = fromSegments [word 30 "aaa", indent, word 30 "bbb"] + materialized [word 30 "aaa", indent, word 30 "bbb"] 40 @?= ["aaa", "bbb"] + map (Break.materializeLineRange prep) (Break.layoutOptimal prep 40) @?= ["aaa", "bbb"] + , testCase "shrinkwrap tightens without adding lines" do + Break.shrinkwrap (fromSegments rhythm) 80 @?= 70 + Break.shrinkwrap (fromSegments rhythm) 200 @?= 110 + Break.shrinkwrap (fromSegments prepared) 45 @?= 30 + , testCase "optimal layout beats greedy on loose middle lines" do + let + squeeze = [word 60 "aaaaaa", space, word 10 "b", space, word 10 "c", space, word 60 "dddddd"] + prep = fromSegments squeeze + materialized squeeze 77 @?= ["aaaaaa", "b c", "dddddd"] + map (Break.materializeLineRange prep) (Break.layoutOptimal prep 77) @?= ["aaaaaa b", "c dddddd"] + , testCase "optimal layout agrees with greedy where greedy is fine" do + let optimal xs w = map (Break.materializeLineRange (fromSegments xs)) (Break.layoutOptimal (fromSegments xs) w) + optimal rhythm 70 @?= ["aaa bbb", "ccc"] + optimal hyphenated 30 @?= ["hy-", "phen"] + optimal broken 1000 @?= ["one", "two"] + , testCase "optimal layout falls back to greedy when infeasible" do + map (Break.materializeLineRange (fromSegments glued)) (Break.layoutOptimal (fromSegments glued) 60) + @?= materialized glued 60 + , testCase "html renderer escapes and anchors baselines" do + let + prep = fromSegments [styledWord 1 30 "a Style -> Style -> TestTree +prepareTests ctx body accent = + testGroup + "prepare" + [ testCase "segments follow analysis and carry the style key" do + prep <- Measure.prepare ctx body "hello world" + map (\s -> (s.text, s.kind, s.style)) (toList prep.segments) + @?= [("hello", Word, body.key), (" ", Space, body.key), ("world", Word, body.key)] + , testCase "empty text prepares to nothing" do + prep <- Measure.prepare ctx body "" + prep.segments @?= Vector.empty + advances <- Measure.charAdvances ctx body "" + advances @?= Storable.empty + , testCase "widths add up to the shaped advances" do + let t = "The quick brown fox" + prep <- Measure.prepare ctx body t + advances <- Measure.charAdvances ctx body t + Storable.length advances @?= Text.length t + assertBool "advances are positive" (Storable.all (> 0) advances) + assertClose (Storable.sum advances) (sum (map (\s -> s.width) (toList prep.segments))) + for_ prep.segments \s -> do + sum (map (.codepoints) s.graphemes) @?= Text.length s.text + assertClose s.width (sum (map (.width) s.graphemes)) + , testCase "prepareWithAdvances agrees with prepare" do + let t = "shaped \xAD\&once,\tthen reused" + prep <- Measure.prepare ctx body t + reused <- Measure.prepareWithAdvances ctx body t =<< Measure.charAdvances ctx body t + reused @?= prep + , testCase "prepareWithAdvances rejects a codepoint/advance count mismatch" do + attempt <- try (Measure.prepareWithAdvances ctx body "abc" (Storable.fromList [1, 2])) + case attempt of + Left (_ :: ErrorCall) -> pure () + Right prep -> assertFailure ("accepted " <> show prep) + , testCase "custom advances flow into grapheme widths" do + prep <- Measure.prepareWithAdvances ctx body "a\x301\&b c" (Storable.fromList [1, 0.5, 2, 4, 8]) + map (\s -> (s.text, s.width, s.graphemes)) (toList prep.segments) + @?= [("a\x301\&b", 3.5, [Grapheme 2 1.5, Grapheme 1 2]), (" ", 4, [Grapheme 1 4]), ("c", 8, [Grapheme 1 8])] + , testCase "zero-advance codepoints fold into the preceding cluster" do + prep <- Measure.prepareWithAdvances ctx body "<=>ff \x301\&ab" (Storable.fromList [5, 0, 0, 3, 0, 4, 0, 1, 0]) + map (\s -> (s.text, s.graphemes)) (toList prep.segments) + @?= [("<=>ff", [Grapheme 3 5, Grapheme 2 3]), (" ", [Grapheme 1 4]), ("\x301\&ab", [Grapheme 1 0, Grapheme 2 1])] + , testCase "emergency breaks never split a shaped cluster" do + prep <- Measure.prepareWithAdvances ctx body "<=>xy" (Storable.fromList [5, 0, 0, 2, 2]) + let lines' maxWidth = map (Break.materializeLineRange prep) (Break.layoutGreedy prep maxWidth) + lines' 3 @?= ["<=>", "x", "y"] + lines' 6 @?= ["<=>", "xy"] + for_ (Break.layoutGreedy prep 3) \line -> + for_ [line.from, line.to] \cursor -> + assertBool ("cursor inside a cluster: " <> show cursor) (cursor.grapheme `elem` [0, 3, 4, 5]) + , testCase "font ligatures shape as one cluster and overflow whole" do + advances <- Measure.charAdvances ctx body "ffi" + Storable.toList (Storable.drop 1 advances) @?= [0, 0] + prep <- Measure.prepare ctx body "ffi" + map (.graphemes) (toList prep.segments) @?= [[Grapheme 3 (Storable.head advances)]] + let narrow = Break.layoutGreedy prep (Storable.head advances / 2) + map (Break.materializeLineRange prep) narrow @?= ["ffi"] + map (.ended) narrow @?= [Overflowed] + , testCase "soft hyphens and tabs take their widths from the style" do + spaceWidth <- Measure.measure ctx body " " + hyphenWidth <- Measure.measure ctx body "-" + body.spaceWidth @?= spaceWidth + body.hyphenWidth @?= hyphenWidth + assertBool "space is not empty" (spaceWidth > 0) + prep <- Measure.prepareWithAdvances ctx body "a\xAD\&b\t\tc\n" (Storable.replicate 7 1) + map (\s -> (s.text, s.kind, s.width)) (toList prep.segments) + @?= [ ("a", Word, 1) + , ("\xAD", SoftHyphen, hyphenWidth) + , ("b", Word, 1) + , ("\t\t", Tab, 2 * spaceWidth) + , ("c", Word, 1) + , ("\n", HardBreak, 0) + ] + , testCase "styles scale their metrics" do + assertClose accent.spaceWidth (1.5 * body.spaceWidth) + assertClose accent.hyphenWidth (1.5 * body.hyphenWidth) + assertBool "styles get distinct keys" (accent.key /= body.key) + , testCase "prepareStyled mixes text, shaped, and atom spans" do + prep <- + Measure.prepareStyled + ctx + [ TextSpan body "ab " + , AtomSpan accent "[pill]" 7 + , ShapedSpan accent " cd" (Storable.fromList [1, 2, 3]) + ] + map (\s -> (s.text, s.kind, s.style)) (toList prep.segments) + @?= [ ("ab", Word, body.key) + , (" ", Space, body.key) + , ("[pill]", Atomic, accent.key) + , (" ", Space, accent.key) + , ("cd", Word, accent.key) + ] + map (\s -> (s.width, s.graphemes)) (drop 2 (toList prep.segments)) + @?= [(7, [Grapheme 6 7]), (1, [Grapheme 1 1]), (5, [Grapheme 1 2, Grapheme 1 3])] + ] + +assertClose :: Float -> Float -> IO () +assertClose expected actual = + assertBool (show actual <> " is not close to " <> show expected) (abs (expected - actual) < 1e-3) + materialized :: [MeasuredSegment] -> Float -> [Text] materialized xs maxWidth = map (Break.materializeLineRange prep) (Break.layoutGreedy prep maxWidth) @@ -209,19 +325,19 @@ word = styledWord 0 styledWord :: Int -> Float -> Text -> MeasuredSegment -styledWord sk w t = MeasuredSegment{text = t, kind = Word, width = w, style = sk, graphemeWidths = graphemes} +styledWord sk w t = MeasuredSegment{text = t, kind = Word, width = w, style = sk, graphemes} where n = Text.length t - graphemes = replicate n (1, w / fromIntegral n) + graphemes = replicate n (Grapheme 1 (w / fromIntegral n)) styledSpace :: Int -> MeasuredSegment -styledSpace sk = MeasuredSegment{text = " ", kind = Space, width = 10, style = sk, graphemeWidths = [(1, 10)]} +styledSpace sk = MeasuredSegment{text = " ", kind = Space, width = 10, style = sk, graphemes = [Grapheme 1 10]} seg :: BreakKind -> Float -> Text -> MeasuredSegment -seg kind w t = MeasuredSegment{text = t, kind, width = w, style = 0, graphemeWidths = [(Text.length t, w)]} +seg kind w t = MeasuredSegment{text = t, kind, width = w, style = 0, graphemes = [Grapheme (Text.length t) w]} atom :: Float -> Text -> MeasuredSegment -atom w label = MeasuredSegment{text = label, kind = Atomic, width = w, style = 0, graphemeWidths = [(Text.length label, w)]} +atom w label = MeasuredSegment{text = label, kind = Atomic, width = w, style = 0, graphemes = [Grapheme (Text.length label) w]} space, indent :: MeasuredSegment space = seg Space 10 " "