~alcinnz/fontconfig-pure

ref: 64bcb432397d1fdfdf9f136ec3c5cdc4990bf920 fontconfig-pure/Graphics/Text/Font/Choose/FontSet.hs -rw-r--r-- 3.1 KiB
64bcb432 — Adrian Cochrane Refine first-draft language bindings! 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
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
-- NOTE: Untested!
module Graphics.Text.Font.Choose.FontSet where

import Graphics.Text.Font.Choose.Pattern
import Graphics.Text.Font.Choose.Config
import Graphics.Text.Font.Choose.ObjectSet

import Foreign.Ptr (Ptr, castPtr)
import Foreign.Storable (pokeElemOff, sizeOf, peek)
import Foreign.Marshal.Alloc (allocaBytes)
import Foreign.Marshal.Array (advancePtr)
import Control.Monad (forM)
import Control.Exception (bracket)

type FontSet = [Pattern]

fontSetList :: Config -> [FontSet] -> Pattern -> ObjectSet
fontSetList config fontss pattern objs = withConfig config $ \config' ->
    withFontSets fontss $ \fontss' -> withPattern $ \pattern' ->
        withObjectSet objs $ \objs' -> do
            ret <- fcFontSetList config' fontss' n pattern' objs'
            thawFontSet ret
foreign import ccall "FcFontSetList" fcFontSetList ::
    Config_ -> Ptr FontSet_ -> Int -> Pattern_ -> ObjectSet_ -> IO FontSet_

fontSetMatch :: Config -> [FontSet] -> Pattern -> Maybe Pattern
fontSetMatch config fontss pattern = withConfig config $ \config' ->
    withFontSets fontss $ \fontss' -> withPattern $ \pattern' ->  alloca $ \res' -> do
        ret <- fcFontSetMatch config' fontss' n pattern' res'
        res <- peek res'
        -- FIXME Is this correct success code?
        if res == 0 then Just <$> thawPattern ret else return Nothing

fontSetSort :: Config -> [FontSet] -> Pattern -> Bool -> CharSet -> Maybe FontSet
fontSetSort config fontss pattern trim csp cb = withConfig config $ \config' ->
        withFontSets fontss $ \fontss' withPattern $ \pattern' ->
            withCharSet csp $ \csp' -> alloca $ \res' -> do
                ret' <- fcFontSetSort config' fontss' n pattern' trim csp' res'
                res <- peek res'
                ret <- if res == 0 then Just <$> thawFontSet ret' else return Nothing
                fcFontSetDestroy ret'
                return ret

------
--- Low-level
------
type FontSet' = Int
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' ->
    forM fonts $ \font -> (fcFontSetAdd fonts' =<< patternAsPointer font)
    cb fonts'

withFontSets :: [FontSet] -> (Ptr FontSet_ -> IO a) -> IO a
withFontSets fontss cb = let n = length fontss in
    allocaBytes (sizeOf (undefined :: FontSet_) * n) $ \fontss' ->
        withFontSets' fontss 0 fontss' -> cb fontss'
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 <- peek fonts'
    array <- peek $ castPtr $ advancePtr fonts' 2
    if n == 0 || array == nullPtr
    then return []
    else forM [0..pred n] $ \i -> thawPattern (advancePtr array i)