~alcinnz/CatTrap

ref: 62b95550c3cdc502352f83565cc53ffd1381f1fc CatTrap/Graphics/Layout/Inline.hs -rw-r--r-- 3.7 KiB
62b95550 — Adrian Cochrane Add missing field into testsuite. 1 year, 7 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
{-# 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,
    fragmentSize, fragmentSize', fragmentPos) where

import Data.Text.ParagraphLayout (Paragraph(..), ParagraphOptions(..),
                                    SpanLayout(..), Fragment(..),
                                    ParagraphLayout(..), layoutPlain, Span(..))
import Data.Text.ParagraphLayout.Rect (Rect(..), width, height, x_min, y_min)
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', hbScale)

-- | Convert from Harfbuzz units to device pixels as a Double
hbScale' font = (/hbScale font) . fromIntegral
-- | Convert from Harfbuzz units to device pixels as a Double or Length.
c font = fromDouble . hbScale' font

-- | Compute minimum width for some richtext.
inlineMinWidth :: Font' -> Paragraph -> Double
inlineMinWidth font self = hbScale' font $ width $ layoutPlain' self 0
-- | Compute minimum width & height for some richtext.
inlineMin :: (CastDouble x, CastDouble y) => Font' -> Paragraph -> Size x y
inlineMin font self = Size (c font $ width rect) (c font $ height rect)
    where rect = layoutPlain' self 0
-- | Compute natural (single-line) width for some richtext.
inlineNatWidth :: Font' -> Paragraph -> Double
inlineNatWidth font self = hbScale' font $ width $ layoutPlain' self maxBound
-- | Compute height for rich text at given width.
inlineHeight :: Font' -> Double -> Paragraph -> Double
inlineHeight font width self =
    hbScale' font $ height $ layoutPlain' self $ round (hbScale font * width)

-- | Compute width & height of some richtext at configured width.
inlineSize :: (CastDouble x, CastDouble y) => Font' -> Paragraph -> Size x y
inlineSize font self = layoutSize font $ layoutPlain self
-- | Retrieve children out of some richtext,
-- associating given userdata with them.
inlineChildren :: [x] -> Paragraph -> [(x, Fragment)]
inlineChildren vals self = layoutChildren vals $ layoutPlain self

-- | Retrieve a laid-out paragraph's rect & convert to CatTrap types.
layoutSize :: (CastDouble x, CastDouble y) => Font' -> ParagraphLayout -> Size x y
layoutSize font self = Size (c font $ width r) (c font $ height r)
  where r = paragraphRect self
-- | Retrieve a laid-out paragraph's children & associate with given userdata.
layoutChildren :: [x] -> ParagraphLayout -> [(x, Fragment)]
layoutChildren vals self = zip vals $ concat $ map inner $ spanLayouts self
  where inner (SpanLayout y) = y

-- | Layout a paragraph at given width & retrieve resulting rect.
layoutPlain' :: Paragraph -> Int32 -> Rect Int32
layoutPlain' (Paragraph a b c d) width =
    paragraphRect $ layoutPlain $ Paragraph a b c d { paragraphMaxWidth = width }

-- | Retrieve the rect for a fragment & convert to CatTrap types.
fragmentSize :: (CastDouble x, CastDouble y) => Font' -> Fragment -> Size x y
fragmentSize font self = Size (c font $ width r) (c font $ height r)
    where r = fragmentRect self
-- | Variant of `fragmentSize` asserting to the typesystem that both fields
-- of the resulting `Size` are of the same type.
fragmentSize' :: CastDouble x => Font' -> Fragment -> Size x x
fragmentSize' = fragmentSize -- Work around for typesystem.
-- | Retrieve the position of a fragment.
fragmentPos :: Font' -> (Double, Double) -> Fragment -> (Double, Double)
fragmentPos font (x, y) self =
        (x + hbScale' font (x_min r), y + hbScale' font (y_min r))
    where r = fragmentRect self