module Main (main) where
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 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 (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 =
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<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)
where
prep = fromSegments xs
stepped :: [MeasuredSegment] -> [Float] -> [Text]
stepped xs = go (Just (Cursor 0 0))
where
prep = fromSegments xs
go _ [] = []
go Nothing _ = []
go (Just cursor) (w : rest) =
case Break.layoutNextLineRange prep w cursor of
Nothing -> []
Just (line, next) -> Break.materializeLineRange prep line : go next rest
prepared, hyphenated, wideHyphen, broken, glued, rhythm, styled, indented :: [MeasuredSegment]
prepared = [word 50 "hello", space, word 50 "world"]
indented = [word 40 "main", seg HardBreak 0 "\n", word 20 "do", seg HardBreak 0 "\n", indent, word 80 "putStrLn"]
hyphenated = [word 20 "hy", seg SoftHyphen 5 "\xAD", word 30 "phen"]
wideHyphen = [word 20 "hy", seg SoftHyphen 15 "\xAD", word 9 "phen"]
broken = [word 30 "one", seg HardBreak 0 "\n", word 30 "two"]
glued = [word 30 "aaa", seg Glue 10 "\xA0", word 30 "bbb"]
rhythm = [word 30 "aaa", space, word 30 "bbb", space, word 30 "ccc"]
styled = [styledWord 1 30 "aaa", styledSpace 1, styledWord 1 30 "bbb", styledSpace 1, styledWord 2 30 "ccc"]
word :: Float -> Text -> MeasuredSegment
word = styledWord 0
styledWord :: Int -> Float -> Text -> MeasuredSegment
styledWord sk w t = MeasuredSegment{text = t, kind = Word, width = w, style = sk, graphemes}
where
n = Text.length t
graphemes = replicate n (Grapheme 1 (w / fromIntegral n))
styledSpace :: Int -> MeasuredSegment
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, graphemes = [Grapheme (Text.length t) w]}
atom :: Float -> Text -> MeasuredSegment
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 " "
indent = seg Space 20 " "
fromSegments :: [MeasuredSegment] -> PreparedText
fromSegments xs = PreparedText{segments = Vector.fromList xs}