~alcinnz/fontconfig-pure

ref: fcf1e371e4a7d55b5ae07b90172502bc1d3e8064 fontconfig-pure/Graphics/Text/Font/Choose/FontSet.hs -rw-r--r-- 4.4 KiB
fcf1e371 — Adrian Cochrane Remove file utility & throw memory exceptions for String utilities. 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
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
-- 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 Graphics.Text.Font.Choose.Result (throwFalse, throwNull)

import Foreign.Ptr (Ptr, castPtr, nullPtr)
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 = unsafePerformIO $ withConfig config $ \config' ->
    withFontSets fontss $ \fontss' n -> withPattern $ \pattern' ->
        withObjectSet objs $ \objs' ->
            thawFontSet_ $ fcFontSetList config' fontss' n pattern' objs'
fontSetList' :: [FontSet] -> Pattern -> ObjectSet
fontSetList' fontss pattern objs = unsafePerformIO $ withFontSets fontss $ \fontss' n ->
    withPattern $ \pattern' -> withObjectSet objs $ \objs' ->
        thawFontSet_ $ fcFontSetList nullPtr fontss' n pattern' objs'
foreign import ccall "FcFontSetList" fcFontSetList ::
    Config_ -> Ptr FontSet_ -> Int -> Pattern_ -> ObjectSet_ -> IO FontSet_

fontSetMatch :: Config -> [FontSet] -> Pattern -> Maybe Pattern
fontSetMatch config fontss pattern = unsafePerformIO $ withConfig config $ \config' ->
    withFontSets fontss $ \fontss' -> withPattern $ \pattern' ->  alloca $ \res' -> do
        ret <- fcFontSetMatch config' fontss' n pattern' res'
        throwPtr res' $ thawPattern_ $ pure ret
fontSetMatch' :: [FontSet] -> Pattern -> Maybe Pattern
fontSetMatch' fontss pattern = unsafePerformIO $ withFontSets fontss $ \fontss' ->
    withPattern $ \pattern' -> alloca $ \res' -> do
        ret <- fcFontSetMatch nullPtr fontss' n pattern' res'
        throwPtr res' $ thawPattern_ $ pure ret
foreign import ccall "FcFontSetMatch" fcFontSetMatch ::
    Config_ -> Ptr FontSet_ -> Int -> Pattern_ -> IO Pattern_

fontSetSort :: Config -> [FontSet] -> Pattern -> Bool -> CharSet -> Maybe FontSet
fontSetSort config fontss pattern trim csp = unsafePerformIO $
    withConfig config $ \config' -> withFontSets fontss $ \fontss' n ->
        withPattern $ \pattern' -> withCharSet csp $ \csp' -> alloca $ \res' -> do
            ret' <- fcFontSetSort config' fontss' n pattern' trim csp' res'
            throwPtr res' $ thawFontSet_ $ pure ret'
fontSetSort' :: [FontSet] -> Pattern -> Bool -> CharSet -> Maybe FontSet
fontSetSort' fontss pattern trim csp = unsafePerformIO $ withConfig $ \config' ->
    withFontSets fontss $ \fontss' n -> withPattern $ \pattern' withCharSet csp $ \csp' ->
        alloca $ \res' -> do
            ret' <- fcFontSetSort nullPtr fontss' n pattern' trim csp' res'
            throwPtr res' $ thawFontSet_ $ pure ret'
foreign import ccall "FcFontSetSort" fcFontSetSort :: Config_ -> Ptr FontSet_
    -> Int -> Pattern_ -> Bool -> CharSet_ -> Ptr Int -> IO FontSet_ -}

------
--- 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' -> 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 <- peek fonts'
    array <- peek $ castPtr $ advancePtr fonts' 2
    if n == 0 || array == nullPtr
    then return []
    else forM [0..pred n] $ \i -> thawPattern =<< peek (advancePtr array i)
thawFontSet_ :: IO FontSet_ -> IO FontSet
thawFontSet_ cb = bracket (throwNull <$> cb) fcFontSetDestroy thawFontSet