kb-text-layout 0.1.0.2 → 0.1.2.0

raw patch · 6 files changed

+412/−235 lines, 6 filesdep ~kb-text-shapePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: kb-text-shape

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• kb-text-layout.cabal +2/−1
• src/KB/Text/Layout/Analysis.hs +2/−2
• src/KB/Text/Layout/Break.hs +18/−18
• src/KB/Text/Layout/Measure.hs +97/−45
• test/Spec.hs +285/−169

@@ -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.

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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<b", styledSpace 1, styledWord 1 30 "cd"]-            opts = Html.Options{width = 40, lineHeight = 20, unit = 1, baseCap = 1, justify = False, baseCss = "font:16px serif", styleCss = const "font:16px serif"}-            html = Html.render opts prep (Break.layoutGreedy prep 40)-          Text.isInfixOf "a&lt;b" html @?= True-          Text.isInfixOf "top:0.00px" html @?= True-          Text.isInfixOf "top:20.00px" html @?= True-          Text.isInfixOf "height:21.00px" html @?= True-          Text.isInfixOf "text-box-trim:trim-both" html @?= True-      , testCase "html renderer scales layout units" do-          let-            prep = fromSegments [styledWord 1 30 "ab", styledSpace 1, styledWord 1 30 "cd"]-            opts = Html.Options{width = 40, lineHeight = 20, unit = 2, baseCap = 1, justify = False, baseCss = "", styleCss = const ""}-            html = Html.render opts prep (Break.layoutGreedy prep 40)-          Text.isInfixOf "width:80.00px" html @?= True-          Text.isInfixOf "top:40.00px" html @?= True-          Text.isInfixOf "height:42.00px" html @?= True-      , testCase "html renderer justifies wrapped lines only" do-          let-            prep = fromSegments rhythm-            opts = Html.Options{width = 80, lineHeight = 20, unit = 1, baseCap = 1, justify = True, baseCss = "", styleCss = const ""}-            html = Html.render opts prep (Break.layoutGreedy prep 80)-          Text.count "word-spacing" html @?= 1-          Text.isInfixOf "word-spacing:10.00px" html @?= True-      ]+  TextShape.withContext \shape -> 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<b", styledSpace 1, styledWord 1 30 "cd"]+          opts = Html.Options{width = 40, lineHeight = 20, unit = 1, baseCap = 1, justify = False, baseCss = "font:16px serif", styleCss = const "font:16px serif"}+          html = Html.render opts prep (Break.layoutGreedy prep 40)+        Text.isInfixOf "a&lt;b" html @?= True+        Text.isInfixOf "top:0.00px" html @?= True+        Text.isInfixOf "top:20.00px" html @?= True+        Text.isInfixOf "height:21.00px" html @?= True+        Text.isInfixOf "text-box-trim:trim-both" html @?= True+    , testCase "html renderer scales layout units" do+        let+          prep = fromSegments [styledWord 1 30 "ab", styledSpace 1, styledWord 1 30 "cd"]+          opts = Html.Options{width = 40, lineHeight = 20, unit = 2, baseCap = 1, justify = False, baseCss = "", styleCss = const ""}+          html = Html.render opts prep (Break.layoutGreedy prep 40)+        Text.isInfixOf "width:80.00px" html @?= True+        Text.isInfixOf "top:40.00px" html @?= True+        Text.isInfixOf "height:42.00px" html @?= True+    , testCase "html renderer justifies wrapped lines only" do+        let+          prep = fromSegments rhythm+          opts = Html.Options{width = 80, lineHeight = 20, unit = 1, baseCap = 1, justify = True, baseCss = "", styleCss = const ""}+          html = Html.render opts prep (Break.layoutGreedy prep 80)+        Text.count "word-spacing" html @?= 1+        Text.isInfixOf "word-spacing:10.00px" html @?= True+    ]++prepareTests :: LayoutContext -> 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 " "