~alcinnz/fontconfig-pure

ref: 24a77a5f8850201dfdc3661776cc0e69bc9bc6a0 fontconfig-pure/Graphics/Text/Font/Choose/Pattern.hs -rw-r--r-- 5.6 KiB
24a77a5f — Adrian Cochrane Get Value & Pattern types compiling correctly. 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
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
{-# LANGUAGE DeriveGeneric #-}
module Graphics.Text.Font.Choose.Pattern (Pattern(..), Binding(..), equalSubset,
    Pattern_, withPattern) where

import Prelude hiding (filter)
import Data.List (nub)

import Graphics.Text.Font.Choose.Value (Value, withValue, thawValue, Value_, value'Size)
import Graphics.Text.Font.Choose.ObjectSet (ObjectSet, ObjectSet_, withObjectSet)
import Data.Hashable (Hashable(..))
import GHC.Generics (Generic)

import Foreign.Ptr (Ptr)
import Foreign.Marshal.Alloc (alloca, allocaBytes)
import Foreign.Storable (Storable(..))
import Foreign.C.String (CString, withCString, peekCString)
import Debug.Trace (trace) -- For reporting internal errors!
import System.IO.Unsafe (unsafePerformIO)

import Control.Monad (forM)
import Data.Maybe (catMaybes)
import Control.Exception (bracket)

type Pattern = [(String, [(Binding, Value)])]
data Binding = Strong | Weak | Same deriving (Eq, Ord, Enum, Show, Generic)

instance Hashable Binding where
    hash Strong = 0
    hash Weak = 1
    hash Same = 2

normalizePattern :: Pattern -> Pattern
normalizePattern pat =
    [(key, [val | (key', vals) <- pat, key' == key, val <- vals]) | key <- nub $ map fst pat]

equalSubset :: Pattern -> Pattern -> ObjectSet -> Bool
equalSubset a b objs = unsafePerformIO $ withPattern a $ \a' -> withPattern b $ \b' ->
    withObjectSet objs $ fcPatternEqualSubset a' b'
foreign import ccall "FcPatternEqualSubset" fcPatternEqualSubset ::
    Pattern_ -> Pattern_ -> ObjectSet_ -> IO Bool

filter :: Pattern -> ObjectSet -> Pattern
filter pat objs =
    unsafePerformIO $ withPattern pat $ \pat' -> withObjectSet objs $ \objs' -> do
        ret <- fcPatternFilter pat' objs'
        thawPattern ret
foreign import ccall "FcPatternFilter" fcPatternFilter ::
    Pattern_ -> ObjectSet_ -> IO Pattern_

substitute :: Pattern -> Pattern
substitute pat = unsafePerformIO $ withPattern pat $ \pat' -> do
    ret <- fcDefaultSubstitute pat'
    thawPattern pat'
foreign import ccall "FcDefaultSubstitute" fcDefaultSubstitute :: Pattern_ -> IO ()

nameParse :: String -> Pattern
nameParse name = unsafePerformIO $ withCString name $ \name' -> do
    ret <- fcNameParse name'
    thawPattern ret
foreign import ccall "FcNameParse" fcNameParse :: CString -> IO Pattern_

nameUnparse :: Pattern -> String
nameUnparse pat = unsafePerformIO $ withPattern pat $ \pat' -> do
    ret <- fcNameUnparse pat'
    peekCString ret
foreign import ccall "FcNameUnparse" fcNameUnparse :: Pattern_ -> IO CString

format :: Pattern -> String -> String
format pat fmt =
    unsafePerformIO $ withPattern pat $ \pat' -> withCString fmt $ \fmt' -> do
        ret <- fcPatternFormat pat' fmt'
        peekCString ret
foreign import ccall "FcPatternFormat" fcPatternFormat ::
    Pattern_ -> CString -> IO CString

------
--- Low-level
------

data Pattern'
type Pattern_ = Ptr Pattern'

withPattern :: Pattern -> (Pattern_ -> IO a) -> IO a
withPattern pat cb = withNewPattern $ \pat' -> do
    forM pat $ \(obj, vals) -> withCString obj $ \obj' -> do
        forM vals $ \(strength, val) -> withValue val $
            fcPatternAdd_ pat' obj' (strength == Strong) True
    cb pat'
-- Does Haskell FFI support unboxed structs? Do I really need to write a C wrapper?
foreign import ccall "my_FCPatternAdd" fcPatternAdd_ ::
    Pattern_ -> CString -> Bool -> Bool -> Value_ -> IO Bool

patternAsPointer :: Pattern -> IO Pattern_
patternAsPointer = flip withPattern fcPatternCopy
foreign import ccall "FcPatternCopy" fcPatternCopy :: Pattern_ -> IO Pattern_

data PatternIter'
type PatternIter_ = Ptr PatternIter'
foreign import ccall "size_PatternIter" patIter'Size :: Int
thawPattern :: Pattern_ -> IO Pattern
thawPattern pat' = allocaBytes patIter'Size $ \iter' -> do
    fcPatternIterStart pat' iter'
    ret <- go iter'
    return $ normalizePattern ret
  where
    go :: PatternIter_ -> IO Pattern
    go iter' = do
        ok <- fcPatternIterNext pat' iter'
        if ok then do
            x <- thawPattern' pat' iter'
            xs <- go iter'
            return (x : xs)
        else return []
foreign import ccall "FcPatternIterStart" fcPatternIterStart ::
    Pattern_ -> PatternIter_ -> IO ()
foreign import ccall "FcPatternIterNext" fcPatternIterNext ::
    Pattern_ -> PatternIter_ -> IO Bool

thawPattern' :: Pattern_ -> PatternIter_ -> IO (String, [(Binding, Value)])
thawPattern' pat' iter' = do
    obj <- peekCString =<< fcPatternIterGetObject pat' iter'
    count <- fcPatternIterValueCount pat' iter'
    values <- forM [0..pred count] $ \i ->
        allocaBytes value'Size $ \val' -> alloca $ \binding' -> do
            res <- fcPatternIterGetValue pat' iter' i val' binding'
            if res == 0 then do
                binding <- peek binding'
                val' <- thawValue val'
                return $ case val' of
                    Just val -> Just (toEnum binding, val)
                    Nothing -> Nothing
            else trace
                    ("FontConfig: Error retrieving value for " ++ obj ++
                        " code: " ++ show res) $
                return Nothing
    return (obj, catMaybes values)
foreign import ccall "FcPatternIterGetObject" fcPatternIterGetObject ::
    Pattern_ -> PatternIter_ -> IO CString
foreign import ccall "FcPatternIterValueCount" fcPatternIterValueCount ::
    Pattern_ -> PatternIter_ -> IO Int
foreign import ccall "FcPatternIterGetValue" fcPatternIterGetValue ::
    Pattern_ -> PatternIter_ -> Int -> Value_ -> Ptr Int -> IO Int

withNewPattern cb = bracket fcPatternCreate fcPatternDestroy cb
foreign import ccall "FcPatternCreate" fcPatternCreate :: IO Pattern_
foreign import ccall "FcPatternDestroy" fcPatternDestroy :: Pattern_ -> IO ()