~alcinnz/fontconfig-pure

ref: 1d62f0618dc5890364fdfce8a0277a1f0062337c fontconfig-pure/Graphics/Text/Font/Choose/FontSet.hs -rw-r--r-- 2.1 KiB
1d62f061 — Adrian Cochrane Bind FontConfig 'size' to CSS 'font-size', ensure old values get overriden. 2 years 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
-- NOTE: Untested!
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)

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