module Main (main) where
import Data.Foldable (for_)
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 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.Segmentation qualified as Segmentation
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}]
, 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
]
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 :: [MeasuredSegment]
prepared = [word 50 "hello", space, word 50 "world"]
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, graphemeWidths = graphemes}
where
n = Text.length t
graphemes = replicate n (1, w / fromIntegral n)
styledSpace :: Int -> MeasuredSegment
styledSpace sk = MeasuredSegment{text = " ", kind = Space, width = 10, style = sk, graphemeWidths = [(1, 10)]}
seg :: BreakKind -> Float -> Text -> MeasuredSegment
seg kind w t = MeasuredSegment{text = t, kind, width = w, style = 0, graphemeWidths = [(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)]}
space :: MeasuredSegment
space = seg Space 10 " "
fromSegments :: [MeasuredSegment] -> PreparedText
fromSegments xs = PreparedText{segments = Vector.fromList xs}