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
{-# LANGUAGE TupleSections #-}
-- | Sizes inline text & extracts positioned children,
-- wraps Balkón for the actual logic.
module Graphics.Layout.Inline(inlineMinWidth, inlineMin, inlineNatWidth, inlineHeight,
inlineSize, inlineChildren, layoutSize, layoutChildren, positionChildren,
fragmentSize, fragmentSize', fragmentPos, FragmentTree(..),
positionSubtree, subtreeInner) where
import Data.Text.ParagraphLayout.Rich (Paragraph(..), ParagraphOptions(..),
Fragment(..), ParagraphLayout(..), AncestorBox(..),
layoutRich)
import Data.Text.ParagraphLayout.Rect (Rect(..),
width, height, x_max, x_min, y_min, y_max)
import Data.Text.Internal (Text(..))
import qualified Data.Text as Txt
import Data.Char (isSpace)
import Data.Int (Int32)
import Graphics.Layout.Box (Size(..), CastDouble(..), fromDouble)
import Graphics.Layout.CSS.Font (Font', hbUnit)
-- | Convert from Harfbuzz units to device pixels as a Double
hbScale = (/hbUnit) . fromIntegral
-- | Convert from Harfbuzz units to device pixels as a Double or Length.
c :: CastDouble a => Int32 -> a
c = fromDouble . hbScale
-- | Compute minimum width for some richtext.
inlineMinWidth :: Paragraph a -> Double
inlineMinWidth self = hbScale $ width $ layoutRich' self 0
-- | Compute minimum width & height for some richtext.
inlineMin :: (CastDouble x, CastDouble y) => Paragraph a -> Size x y
inlineMin self = Size (c $ width rect) (c $ height rect)
where rect = layoutRich' self 0
-- | Compute natural (single-line) width for some richtext.
inlineNatWidth :: Paragraph a -> Double
inlineNatWidth self = hbScale $ width $ layoutRich' self maxBound
-- | Compute height for rich text at given width.
inlineHeight :: Double -> Paragraph a -> Double
inlineHeight width self =
hbScale $ height $ layoutRich' self $ round (hbUnit * width)
-- | Compute width & height of some richtext at configured width.
inlineSize :: (CastDouble x, CastDouble y) => Paragraph a -> Size x y
inlineSize self = layoutSize $ layoutRich self
-- | Retrieve children out of some richtext,
-- associating given userdata with them.
inlineChildren :: Eq a => Paragraph a -> [FragmentTree a]
inlineChildren self = layoutChildren $ layoutRich self
-- | Retrieve a laid-out paragraph's rect & convert to CatTrap types.
layoutSize :: (CastDouble x, CastDouble y) => ParagraphLayout a -> Size x y
layoutSize self = Size (c $ width r) (c $ height r)
where r = paragraphRect self
-- | Retrieve a laid-out paragraph's children & associate with given userdata.
layoutChildren :: Eq a => ParagraphLayout a -> [FragmentTree a]
layoutChildren self = reconstructTree self
-- | Layout a paragraph at given width & retrieve resulting rect.
layoutRich' :: Paragraph a -> Int32 -> Rect Int32
layoutRich' (Paragraph a b c d) width =
paragraphRect $ layoutRich $ Paragraph a b c d { paragraphMaxWidth = width }
-- | Retrieve the rect for a fragment & convert to CatTrap types.
fragmentSize :: (CastDouble x, CastDouble y) => FragmentTree a -> Size x y
fragmentSize self = Size (c $ width r) (c $ height r)
where r = treeRect self
-- | Compute the unioned rect for a subtree.
treeRect :: FragmentTree a -> Rect Int32
treeRect (Branch _ childs) = foldr unionRect (Rect 0 0 0 0) $ map treeRect childs
where unionRect a b = Rect (x_min a `min` x_min b) (y_min a `min` y_min b)
((x_max a `max` x_max b) - (x_min a `min` x_min b))
((y_max a `max` y_max b) - (y_min a `min` x_min b))
treeRect (Leaf self) = fragmentRect self
-- | Variant of `fragmentSize` asserting to the typesystem that both fields
-- of the resulting `Size` are of the same type.
fragmentSize' :: CastDouble x => FragmentTree a -> Size x x
fragmentSize' = fragmentSize -- Work around for typesystem.
-- | Retrieve the position of a fragment.
fragmentPos :: (Double, Double) -> Fragment a -> (Double, Double)
fragmentPos (x, y) self = (x + hbScale (x_min r), y + hbScale (y_min r))
where r = fragmentRect self
-- | Alter userdata to hold positions.
positionChildren :: (Double, Double) -> ParagraphLayout (a, b, c) ->
ParagraphLayout (a, b, ((Double, Double), c))
positionChildren pos self = self {
paragraphFragments = [
Fragment (a, b, (pos', c)) d (positionParents pos' e) f g h
| frag@(Fragment (a, b, c) d e f g h) <- paragraphFragments self,
let pos' = fragmentPos pos frag]
}
positionParents :: (Double, Double) -> [AncestorBox (a, b, c)] ->
[AncestorBox (a, b, ((Double, Double), c))]
positionParents pos (parent@AncestorBox { boxUserData = (a, b, c) }:parents) =
parent { boxUserData = (a, b, (pos', c)) }:positionParents pos' parents
where pos' = pos -- FIXME: Take into account borders.
positionParents _ [] = []
data FragmentTree x = Branch (AncestorBox x) [FragmentTree x]
| Leaf (Fragment x)
reconstructTree :: Eq x => ParagraphLayout x -> [FragmentTree x]
reconstructTree ParagraphLayout { paragraphFragments = frags } =
reconstructTree' [frag {
fragmentAncestorBoxes = reverse $ fragmentAncestorBoxes frag
} | frag <- frags]
reconstructTree' :: Eq x => [Fragment x] -> [FragmentTree x]
reconstructTree' (self@Fragment { fragmentAncestorBoxes = [] }:frags) =
Leaf self:reconstructTree' frags
reconstructTree' frags@(Fragment {
fragmentAncestorBoxes = branch:_, fragmentLine = line
}:_) =
Branch branch (reconstructTree' [ child { fragmentAncestorBoxes = ancestors }
| child@Fragment { fragmentAncestorBoxes = _:ancestors } <- childs])
:reconstructTree' sibs
where
(childs, sibs) = span sameBranch frags
-- Cluster ancestor branches, breaking them per-line.
sameBranch Fragment {fragmentAncestorBoxes=branch':_, fragmentLine=line'} =
branch == branch' && line == line'
-- Leaves are always in their own branch.
sameBranch Fragment { fragmentAncestorBoxes = [] } = False
reconstructTree' [] = []
positionSubtree :: (Double, Double) -> FragmentTree (a, b, c) ->
FragmentTree (a, b, ((Double, Double), c))
positionSubtree pos (Branch (AncestorBox (a, b, c) d e f g) childs) =
Branch (AncestorBox (a, b, (pos, c)) d e f g) $
map (positionSubtree pos) childs
positionSubtree pos (Leaf (Fragment (a, b, c) d _ f g h)) =
Leaf (Fragment (a, b, (pos, c)) d [] f g h)
subtreeInner :: FragmentTree (a, b, c) -> c
subtreeInner (Branch AncestorBox { boxUserData = (_, _, ret) } _) = ret
subtreeInner (Leaf Fragment { fragmentUserData = (_, _, ret) }) = ret