~jaro/balkon

ref: 21f976aa18e99769db1e2b63313bd26ede47ca4f balkon/src/Data/Text/ParagraphLayout/Internal/Plain.hs -rw-r--r-- 13.1 KiB
21f976aaJaro Support hard line breaks. 1 year, 8 months ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
module Data.Text.ParagraphLayout.Internal.Plain
    (Paragraph(..)
    ,ParagraphLayout(..)
    ,ParagraphOptions(..)
    ,SpanLayout(..)
    ,layoutPlain
    )
where

import Control.Applicative (ZipList(ZipList), getZipList)
import Data.Int (Int32)
import Data.List (mapAccumL)
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Text.Foreign (lengthWord8)
import Data.Text.Glyphize
    (Buffer(..)
    ,ContentType(ContentTypeUnicode)
    ,Direction(..)
    ,FontExtents(..)
    ,GlyphInfo
    ,GlyphPos
    ,defaultBuffer
    ,fontExtentsForDir
    ,shape
    )
import Data.Text.ICU (Breaker, LocaleName, breakCharacter, breakLine)
import qualified Data.Text.ICU as BreakStatus (Line(Hard))
import Data.Text.Internal (Text(Text))
import qualified Data.Text.Lazy as Lazy

import Data.Text.ParagraphLayout.Internal.Break
import Data.Text.ParagraphLayout.Internal.Fragment
import Data.Text.ParagraphLayout.Internal.LineHeight
import Data.Text.ParagraphLayout.Internal.Paragraph
import qualified Data.Text.ParagraphLayout.Internal.ProtoFragment as PF
import Data.Text.ParagraphLayout.Internal.Rect
import Data.Text.ParagraphLayout.Internal.ResolvedSpan (WithSpan(WithSpan))
import qualified Data.Text.ParagraphLayout.Internal.ResolvedSpan as RS
import Data.Text.ParagraphLayout.Internal.Run
import Data.Text.ParagraphLayout.Internal.Span
import Data.Text.ParagraphLayout.Internal.TextContainer

-- | Lay out a paragraph of plain, unidirectional text using a single font.
layoutPlain :: Paragraph -> ParagraphLayout
layoutPlain p@(Paragraph _ _ _ opts) = paragraphLayout sls
    where
        sls = map SpanLayout fragsBySpan
        fragsBySpan = take (length spans) $ RS.splitBySpanIndex frags
        frags = layoutAndAlignLines maxWidth $ spansToRunsWrapped spans
        maxWidth = paragraphMaxWidth opts
        spans = resolveSpans p

-- | Split a number of spans into a flat array of runs and add a wrapper
-- so that each run can be traced back to its originating span.
spansToRunsWrapped :: [RS.ResolvedSpan] -> [WithSpan Run]
spansToRunsWrapped ss = concat $ map spanToRunsWrapped ss

-- | Split a span into runs and add a wrapper
-- so that each run can be traced back to its originating span.
spanToRunsWrapped :: RS.ResolvedSpan -> [WithSpan Run]
spanToRunsWrapped s = map (WithSpan s) (spanToRuns s)

-- | Create a multi-line layout from the given runs, splitting them as
-- necessary to fit within the requested line width.
--
-- The output is a flat list of fragments positioned in both dimensions.
layoutAndAlignLines :: Int32 -> [WithSpan Run] -> [WithSpan Fragment]
layoutAndAlignLines maxWidth runs = frags
    where
        frags = concat fragsInLines
        (_, fragsInLines) = mapAccumL positionLineH originY canonicalLines
        canonicalLines = map canonicalOrder logicalLines
        logicalLines = layoutLines maxWidth runs
        originY = paragraphOriginY

-- | Reorder the given fragments from logical order to whatever order HarfBuzz
-- uses (LTR for horizontal text, TTB for vertical text), so that cluster order
-- is preserved even across runs.
canonicalOrder :: [WithSpan PF.ProtoFragment] -> [WithSpan PF.ProtoFragment]
canonicalOrder [] = []
canonicalOrder pfs@((WithSpan _ headPF):_) = case PF.direction headPF of
    -- TODO: Update for bidi.
    Just DirLTR -> pfs
    Just DirRTL -> reverse pfs
    Just DirTTB -> pfs
    Just DirBTT -> reverse pfs
    -- If no guess can be made, use LTR.
    -- TODO: Add explicit direction to input interface.
    Nothing -> pfs

-- | Create a multi-line layout from the given runs, splitting them as
-- necessary to fit within the requested line width.
--
-- The output is a two-dimensional list of fragments positioned along the
-- horizontal axis.
layoutLines :: Int32 -> [WithSpan Run] -> [[WithSpan PF.ProtoFragment]]
layoutLines maxWidth runs
    | null rest
        -- Everything fits. We are done.
        = fitting : []
    | otherwise
        -- Something fits, the rest goes on the next line.
        = fitting : layoutLines maxWidth rest
    where
        (fitting, rest) = layoutAndWrapRunsH maxWidth runs

-- TODO: Allow a run across multiple spans (e.g. if they only differ by colour).

-- | Position all the given horizontal fragments on the same line,
-- using `originY` as its top edge, and return the bottom edge for continuation.
--
-- Glyphs will be aligned by their ascent line, similar to the behaviour of
-- @vertical-align: top@ in CSS.
--
-- TODO: For rich text, allow other types of vertical alignment.
positionLineH :: Int32 -> [WithSpan PF.ProtoFragment] ->
    (Int32, [WithSpan Fragment])
positionLineH originY pfs = (nextY, frags)
    where
        -- A line with no glyphs will be considered to have zero height.
        -- This can happen when line breaking produces a line that contains
        -- onls spaces.
        nextY = if null rects then originY else maximum $ map y_min rects
        rects = map (\(WithSpan _ r) -> fragmentRect r) frags
        frags = snd $ mapAccumL (positionFragmentH originY) originX pfs
        originX = paragraphOriginX

-- | Position the given horizontal fragment on a line,
-- using `originY` as its top edge and `originX` as its left edge,
-- returning the X coordinate of its right edge for continuation.
positionFragmentH ::
    Int32 -> Int32 -> WithSpan PF.ProtoFragment -> (Int32, WithSpan Fragment)
positionFragmentH originY originX (WithSpan rs pf) = (nextX, WithSpan rs frag)
    where
        nextX = originX + PF.advance pf
        frag = Fragment rect (penX, penY) (PF.glyphs pf)
        rect = Rect originX originY (PF.advance pf) (-lineHeight)
        penX = 0
        penY = descent + leading `div` 2 - lineHeight
        lineHeight = case RS.spanLineHeight rs of
            Normal -> normalLineHeight
            Absolute h -> h
        leading = lineHeight - normalLineHeight
        normalLineHeight = ascent + descent
        ascent = ascender extents
        descent = - descender extents
        extents = fontExtentsForDir font (PF.direction pf)
        font = RS.spanFont rs

-- | Calculate layout for multiple horizontal runs, breaking them as necessary
-- to fit as much content as possible without exceeding the maximum line width,
-- and return the remaining runs to be placed on other lines.
layoutAndWrapRunsH :: Int32 -> [WithSpan Run] ->
    ([WithSpan PF.ProtoFragment], [WithSpan Run])
layoutAndWrapRunsH maxWidth runs = NonEmpty.head $ validLayouts
    where
        validLayouts = dropWhile1 tooLong layouts
        tooLong (pfs, _) = totalAdvances pfs > maxWidth
        layouts = NonEmpty.map layoutFst splits
        layoutFst (runs1, runs2) = (layout runs1, runs2)
        layout runs1 = layoutRunsH $ trimTextsEnd isEndSpace runs1
        -- TODO: Consider optimising.
        --       We do not need to look for soft breaks further than the
        --       shortest hard break.
        -- TODO: Add a "strut" for empty lines.
        splits = hardSplit runs :| softSplits runs

-- | Treat a list of runs as a contiguous sequence, and split them into two
-- lists so that the first list contains as much of the input text as possible
-- without crossing a hard line break (typically after a newline character).
--
-- If there is no hard line break in the input, the first output list will
-- contain the whole input, and the second output list will be empty.
hardSplit :: [WithSpan Run] -> ([WithSpan Run], [WithSpan Run])
hardSplit runs = NonEmpty.last $ splits
    where
        -- TODO: Consider optimising.
        --       We do not need to look for any line breaks further than the
        --       shortest hard break.
        splits = noSplit :| map trimFst hSplits
        trimFst (runs1, runs2) = (trimTextsEnd isNewline runs1, runs2)
        noSplit = (runs, [])
        hSplits = -- from longest to shortest
            splitTextsBy (map fst . filter isHard . runLineBreaks) runs
        isHard (_, status) = status == BreakStatus.Hard

-- | Treat a list of runs as a contiguous sequence,
-- and find all possible ways to split them into two non-empty lists,
-- using soft line break opportunities (typically after words) and then
-- using character boundaries.
--
-- The results in the form (prefix, suffix) will be ordered so that items
-- closer to the start of the list are preferred for line breaking, but without
-- considering overflows.
softSplits :: [WithSpan Run] -> [([WithSpan Run], [WithSpan Run])]
softSplits runs = splits
    where
        splits = lSplits ++ cSplits
        lSplits = splitTextsBy (map fst . runLineBreaks) runs
        -- TODO: Consider optimising.
        --       We do not need to look for character breaks further than the
        --       shortest line break.
        cSplits = splitTextsBy (map fst . runCharacterBreaks) runs

-- | The suffix remaining after removing the longest prefix of the list for
-- which the predicate holds, except always including at least the last element
-- of the original list.
dropWhile1 :: (a -> Bool) -> NonEmpty a -> NonEmpty a
dropWhile1 p list = case NonEmpty.uncons list of
    (_, Nothing) -> list
    (x, Just xs) -> if p x
        then dropWhile1 p xs
        else list

-- | Calculate layout for multiple horizontal runs on the same line, without
-- any breaking.
layoutRunsH :: [WithSpan Run] -> [WithSpan PF.ProtoFragment]
layoutRunsH runs = map layoutRunH runs

-- | Sum of all advances within the given fragments.
totalAdvances :: [WithSpan PF.ProtoFragment] -> Int32
totalAdvances pfs = sum $ map (\(WithSpan _ pf) -> PF.advance pf) pfs

-- | Calculate layout for the given horizontal run and attach extra information.
layoutRunH :: WithSpan Run -> WithSpan PF.ProtoFragment
layoutRunH (WithSpan rs run) = WithSpan rs pf
    where
        pf = PF.protoFragmentH dir glyphs
        glyphs = shapeRun (WithSpan rs run)
        dir = runDirection run

-- | Calculate layout for the given run independently of its position.
shapeRun :: WithSpan Run -> [(GlyphInfo, GlyphPos)]
shapeRun (WithSpan rs run) = shape font buffer features
    where
        font = RS.spanFont rs
        buffer = defaultBuffer
            { text = Lazy.fromStrict $ runText run
            , contentType = Just ContentTypeUnicode
            , direction = runDirection run
            , script = runScript run
            , language = Just $ RS.spanLanguage rs
            -- Perhaps counter-intuitively, the `beginsText` and `endsText`
            -- flags refer to everything that "Data.Text.Glyphize" can see,
            -- not just the current run.
            --
            -- Since all runs are cut from a single continuous `Text` that
            -- represents the entire paragraph, and "Data.Text.Glyphize" peeks
            -- at the whole underlying byte array, HarfBuzz will be able to see
            -- both the beginning and the end of the paragraph at all times,
            -- so these flags can always be set.
            , beginsText = True
            , endsText = True
            }
        features = []

resolveSpans :: Paragraph -> [RS.ResolvedSpan]
resolveSpans p@(Paragraph arr pStart spans pOpts) = do
    let sBounds = paragraphSpanBounds p
    let pEnd = NonEmpty.last sBounds
    let sStarts = NonEmpty.init sBounds
    let sLengths = map spanLength spans

    (i, s, sStart, sLen) <- getZipList $ (,,,)
        <$> ZipList [0..]
        <*> ZipList spans
        <*> ZipList sStarts
        <*> ZipList sLengths
    let lang = spanLanguage $ spanOptions s
    let lBreaks = paragraphBreaks breakLine p pEnd lang
    let cBreaks = paragraphBreaks breakCharacter p pEnd lang
    return RS.ResolvedSpan
        { RS.spanIndex = i
        , RS.spanOffsetInParagraph = sStart - pStart
        -- TODO: Consider adding checks for array bounds.
        , RS.spanText = Text arr sStart sLen
        , RS.spanFont = paragraphFont pOpts
        , RS.spanLineHeight = paragraphLineHeight pOpts
        , RS.spanLanguage = lang
        , RS.spanLineBreaks = subOffsetsDesc (sStart - pStart) lBreaks
        , RS.spanCharacterBreaks = subOffsetsDesc (sStart - pStart) cBreaks
        }

paragraphBreaks :: (LocaleName -> Breaker a) -> Paragraph -> Int -> String ->
    [(Int, a)]
paragraphBreaks breakFunc (Paragraph arr off _ _) end lang =
    breaksDesc (breakFunc (locale lang LBAuto)) paragraphText
    where
        paragraphText = Text arr off (end - off)

runLineBreaks :: WithSpan Run -> [(Int, BreakStatus.Line)]
runLineBreaks (WithSpan rs run) =
    runBreaksFromSpan run $ RS.spanLineBreaks rs

runCharacterBreaks :: WithSpan Run -> [(Int, ())]
runCharacterBreaks (WithSpan rs run) =
    runBreaksFromSpan run $ RS.spanCharacterBreaks rs

-- | Constrain span breaks to a selected run and adjust offsets.
runBreaksFromSpan :: Run -> [(Int, a)] -> [(Int, a)]
runBreaksFromSpan run spanBreaks =
    dropWhile (not . valid) $ subOffsetsDesc (runOffsetInSpan run) spanBreaks
    where
        valid (off, _) = off < runLength
        runLength = lengthWord8 $ getText run

-- | Predicate for characters that can be potentially removed from the end of
-- a line according to the CSS Text Module.
isEndSpace :: Char -> Bool
isEndSpace c = c `elem` [' ', '\t', '\x1680']

-- | Predicate for characters that should be removed from the end of a line in
-- the case of a hard line break.
isNewline :: Char -> Bool
isNewline c = c == '\n'