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
{-# LANGUAGE OverloadedStrings #-}
module Graphics.Text.Font.Choose.FontSet where
import Graphics.Text.Font.Choose.Pattern
import Graphics.Text.Font.Choose.Result (throwFalse, throwNull)
import Foreign.Ptr (Ptr, castPtr, nullPtr)
import Foreign.Storable (pokeElemOff, sizeOf)
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Marshal.Array (peekArray)
import Control.Monad (forM)
import Control.Exception (bracket)
-- For CSS bindings
import Stylist.Parse (StyleSheet(..), parseProperties)
type FontSet = [Pattern]
------
--- Low-level
------
data FontSet'
type FontSet_ = Ptr FontSet'
withNewFontSet :: (FontSet_ -> IO a) -> IO a
withNewFontSet = bracket fcFontSetCreate fcFontSetDestroy
foreign import ccall "FcFontSetCreate" fcFontSetCreate :: IO FontSet_
foreign import ccall "FcFontSetDestroy" fcFontSetDestroy :: FontSet_ -> IO ()
withFontSet :: FontSet -> (FontSet_ -> IO a) -> IO a
withFontSet fonts cb = withNewFontSet $ \fonts' -> do
forM fonts $ \font -> do
font' <- patternAsPointer font
throwFalse <$> fcFontSetAdd fonts' font'
cb fonts'
foreign import ccall "FcFontSetAdd" fcFontSetAdd :: FontSet_ -> Pattern_ -> IO Bool
withFontSets :: [FontSet] -> (Ptr FontSet_ -> Int -> IO a) -> IO a
withFontSets fontss cb = let n = length fontss in
allocaBytes (sizeOf (undefined :: FontSet_) * n) $ \fontss' ->
withFontSets' fontss 0 fontss' $ cb fontss' n
withFontSets' :: [FontSet] -> Int -> Ptr FontSet_ -> IO a -> IO a
withFontSets' [] _ _ cb = cb
withFontSets' (fonts:fontss) i fontss' cb = withFontSet fonts $ \fonts' -> do
pokeElemOff fontss' i fonts'
withFontSets' fontss (succ i) fontss' cb
thawFontSet :: FontSet_ -> IO FontSet
thawFontSet fonts' = do
n <- get_fontSet_nfont fonts'
array <- get_fontSet_fonts fonts'
if n == 0 || array == nullPtr
then return []
else do
list <- peekArray n array
forM list (thawPattern . throwNull)
foreign import ccall "get_fontSet_nfont" get_fontSet_nfont :: FontSet_ -> IO Int
foreign import ccall "get_fontSet_fonts" get_fontSet_fonts :: FontSet_ -> IO (Ptr Pattern_)
thawFontSet_ :: IO FontSet_ -> IO FontSet
thawFontSet_ cb = bracket (throwNull <$> cb) fcFontSetDestroy thawFontSet
------
--- CSS Bindings
------
data FontFaceParser a = FontFaceParser { cssFonts :: FontSet, cssInner :: a}
instance StyleSheet a => StyleSheet (FontFaceParser a) where
setPriorities v (FontFaceParser x self) = FontFaceParser x $ setPriorities v self
addRule (FontFaceParser x self) rule = FontFaceParser x $ addRule self rule
addAtRule self "font-face" toks =
let (props, toks') = parseProperties toks in (self, toks')
addAtRule (FontFaceParser x self) key toks =
let (a, b) = addAtRule self key toks in (FontFaceParser x a, b)