~alcinnz/fontconfig-pure

ref: 1d62f0618dc5890364fdfce8a0277a1f0062337c fontconfig-pure/Graphics/Text/Font/Choose/Pattern.hs -rw-r--r-- 8.4 KiB
1d62f061 — Adrian Cochrane Bind FontConfig 'size' to CSS 'font-size', ensure old values get overriden. 2 years ago
                                                                                
5b204783 Adrian Cochrane
24a77a5f Adrian Cochrane
c10cdcf2 Adrian Cochrane
58198ed8 Adrian Cochrane
e21707cb Adrian Cochrane
24a77a5f Adrian Cochrane
e21707cb Adrian Cochrane
5b204783 Adrian Cochrane
e21707cb Adrian Cochrane
24a77a5f Adrian Cochrane
160a3581 Adrian Cochrane
e21707cb Adrian Cochrane
160a3581 Adrian Cochrane
24a77a5f Adrian Cochrane
e21707cb Adrian Cochrane
24a77a5f Adrian Cochrane
e21707cb Adrian Cochrane
160a3581 Adrian Cochrane
1d62f061 Adrian Cochrane
24a77a5f Adrian Cochrane
5b204783 Adrian Cochrane
1d62f061 Adrian Cochrane
5b204783 Adrian Cochrane
1d62f061 Adrian Cochrane
5b204783 Adrian Cochrane
24a77a5f Adrian Cochrane
e21707cb Adrian Cochrane
1d62f061 Adrian Cochrane
5b204783 Adrian Cochrane
24a77a5f Adrian Cochrane
e21707cb Adrian Cochrane
24a77a5f Adrian Cochrane
e21707cb Adrian Cochrane
160a3581 Adrian Cochrane
e21707cb Adrian Cochrane
c10cdcf2 Adrian Cochrane
e21707cb Adrian Cochrane
24a77a5f Adrian Cochrane
e21707cb Adrian Cochrane
160a3581 Adrian Cochrane
e21707cb Adrian Cochrane
160a3581 Adrian Cochrane
e21707cb Adrian Cochrane
160a3581 Adrian Cochrane
24a77a5f Adrian Cochrane
e21707cb Adrian Cochrane
160a3581 Adrian Cochrane
e21707cb Adrian Cochrane
160a3581 Adrian Cochrane
e21707cb Adrian Cochrane
a327c852 Adrian Cochrane
e21707cb Adrian Cochrane
160a3581 Adrian Cochrane
e21707cb Adrian Cochrane
24a77a5f Adrian Cochrane
e21707cb Adrian Cochrane
24a77a5f Adrian Cochrane
e21707cb Adrian Cochrane
24a77a5f Adrian Cochrane
e21707cb Adrian Cochrane
160a3581 Adrian Cochrane
e21707cb Adrian Cochrane
160a3581 Adrian Cochrane
e21707cb Adrian Cochrane
160a3581 Adrian Cochrane
e21707cb Adrian Cochrane
160a3581 Adrian Cochrane
e21707cb Adrian Cochrane
24a77a5f Adrian Cochrane
160a3581 Adrian Cochrane
24a77a5f Adrian Cochrane
c10cdcf2 Adrian Cochrane
24a77a5f Adrian Cochrane
160a3581 Adrian Cochrane
24a77a5f Adrian Cochrane
e21707cb Adrian Cochrane
160a3581 Adrian Cochrane
e21707cb Adrian Cochrane
5b204783 Adrian Cochrane
1d62f061 Adrian Cochrane
5b204783 Adrian Cochrane
1d62f061 Adrian Cochrane
5b204783 Adrian Cochrane
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
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
{-# LANGUAGE DeriveGeneric, OverloadedStrings, TypeSynonymInstances, FlexibleInstances #-}
module Graphics.Text.Font.Choose.Pattern (Pattern(..), Binding(..), equalSubset,
    normalizePattern, filter, defaultSubstitute, nameParse, nameUnparse, format,
    Pattern_, withPattern, thawPattern, thawPattern_, patternAsPointer) where

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

import Graphics.Text.Font.Choose.Value
import Graphics.Text.Font.Choose.ObjectSet (ObjectSet, ObjectSet_, withObjectSet)
import Data.Hashable (Hashable(..))
import GHC.Generics (Generic)
import Graphics.Text.Font.Choose.Result (throwFalse, throwNull, throwInt)

import Foreign.Ptr (Ptr)
import Foreign.Marshal.Alloc (alloca, allocaBytes, free)
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, join)
import Data.Maybe (catMaybes, fromMaybe)
import Control.Exception (bracket)

-- Imported for CSS bindings
import Data.CSS.Syntax.Tokens (Token(..), NumericValue(..))
import Data.Text (unpack, Text)
import Stylist (PropertyParser(..))
import Data.Scientific (toRealFloat)

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

setValue :: ToValue x => String -> Binding -> x -> Pattern -> Pattern
setValue key b value pat = (key, [(b, toValue value)]):unset key pat
setValues :: ToValue x => String -> Binding -> [x] -> Pattern -> Pattern
setValues key b values pat = (key, [(b, toValue v) | v <- values]):unset key pat
getValue :: String -> Pattern -> Maybe Value
getValue key pat | Just ((_, ret):_) <- lookup key pat = Just ret
    | otherwise = Nothing

unset key mapping = [(key', val') | (key', val') <- mapping, key' /= key]

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' ->
        thawPattern_ $ fcPatternFilter pat' objs'
foreign import ccall "FcPatternFilter" fcPatternFilter ::
    Pattern_ -> ObjectSet_ -> IO Pattern_

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

-- Is this correct memory management?
nameParse :: String -> Pattern
nameParse name = unsafePerformIO $ withCString name $ \name' ->
    thawPattern_ $ fcNameParse name'
foreign import ccall "FcNameParse" fcNameParse :: CString -> IO Pattern_

nameUnparse :: Pattern -> String
nameUnparse pat = unsafePerformIO $ withPattern pat $ \pat' ->
    bracket (throwNull <$> fcNameUnparse pat') free peekCString
foreign import ccall "FcNameUnparse" fcNameUnparse :: Pattern_ -> IO CString

format :: Pattern -> String -> String
format pat fmt =
    unsafePerformIO $ withPattern pat $ \pat' -> withCString fmt $ \fmt' -> do
        bracket (throwNull <$> fcPatternFormat pat' fmt') free peekCString
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) -> throwFalse <$> 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 $ \ret -> do
    fcPatternReference ret
    return ret
foreign import ccall "FcPatternReference" fcPatternReference :: Pattern_ -> IO ()

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 <- fcPatternIterIsValid pat' iter'
        if ok then do
            x <- thawPattern' pat' iter'
            ok' <- fcPatternIterNext pat' iter'
            xs <- if ok' then go iter' else return []
            return (x : xs)
        else return []
foreign import ccall "FcPatternIterStart" fcPatternIterStart ::
    Pattern_ -> PatternIter_ -> IO ()
foreign import ccall "FcPatternIterIsValid" fcPatternIterIsValid ::
    Pattern_ -> PatternIter_ -> IO Bool
foreign import ccall "FcPatternIterNext" fcPatternIterNext ::
    Pattern_ -> PatternIter_ -> IO Bool

thawPattern' :: Pattern_ -> PatternIter_ -> IO (String, [(Binding, Value)])
thawPattern' pat' iter' = do
    obj <- peekCString =<< throwNull <$> 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'
            throwInt res $ do
                binding <- peek binding'
                val' <- thawValue val'
                return $ case val' of
                    Just val | binding >= 0 && binding <= 2 -> Just (toEnum binding, val)
                    Just val -> Just (Same, val)
                    Nothing -> Nothing
    return (obj, catMaybes $ map join 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

thawPattern_ cb = bracket (throwNull <$> cb) fcPatternDestroy thawPattern

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

------
--- Pattern
------

parseFontFamily :: [Token] -> ([String], Bool, [Token])
parseFontFamily (String font:Comma:tail) = let (fonts, b, tail') = parseFontFamily tail
    in (unpack font:fonts, b, tail')
parseFontFamily (Ident font:Comma:tail) = let (fonts, b, tail') = parseFontFamily tail
    in (unpack font:fonts, b, tail')
parseFontFamily (String font:tail) = ([unpack font], True, tail)
parseFontFamily (Ident font:tail) = ([unpack font], True, tail)
parseFontFamily toks = ([], False, toks) -- Invalid syntax!

parseLength :: Double -> NumericValue -> Text -> Double
parseLength super length unit = convert (nv2double length) unit
  where
    convert = c
    c x "pt" = x -- Unit FontConfig expects!
    c x "pc" = x/6 `c` "in"
    c x "in" = x/72 `c` "pt"
    c x "Q" = x/40 `c` "cm"
    c x "mm" = x/10 `c` "cm"
    c x "cm" = x/2.54 `c` "in"
    c x "px" = x/96 `c` "in" -- Conversion factor during early days of CSS, got entrenched.
    c x "em" = x * super
    c x "%" = x/100 `c` "em"
    c _ _ = 0/0 -- NaN

    nv2double (NVInteger x) = fromInteger x
    nx2double (NVNumber x) = toRealFloat x

sets a b c d = Just $ setValues a b c d
set a b c d = Just $ setValue a b c d

getSize pat | Just (ValueDouble x) <- getValue "size" pat = x
    | otherwise = 10

instance PropertyParser Pattern where
    temp = []

    longhand _ self "font-family" toks
        | (fonts, True, []) <- parseFontFamily toks = sets "family" Strong fonts self
    longhand super self "font-size" [Dimension _ x unit]
        | let y = parseLength (getSize super) x unit, not $ isNaN y =
            set "size" Strong y self
    longhand _ _ _ _ = Nothing