~alcinnz/fontconfig-pure

ref: 9aee49dd6084ce6deef6099a3b7c27fa0f6c8b1e fontconfig-pure/lib/Graphics/Text/Font/Choose/FontSet.hs -rw-r--r-- 4.9 KiB
9aee49dd — Adrian Cochrane Finish initial redraft 8 months 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
{-# LANGUAGE CApiFFI #-}
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.CharSet
import Graphics.Text.Font.Choose.Internal.FFI

import Foreign.C.String (CString)
import Foreign.Ptr (Ptr)
import Data.MessagePack (MessagePack)

type FontSet = [Pattern]

fontSetList :: Config -> [FontSet] -> Pattern -> ObjectSet -> FontSet
fontSetList a b c d =
    fromMessage0 $ arg d $ arg c $ arg b $ withForeignPtr' fcFontSetList a

foreign import capi "fontconfig-wrap.h" fcFontSetList ::
        Ptr Config' -> CString -> Int -> CString -> Int -> CString -> Int ->
        Ptr Int -> CString

fontSetMatch :: Config -> [FontSet] -> Pattern -> Maybe FontSet
fontSetMatch a b c = fromMessage $ arg c $ arg b $ withForeignPtr' fcFontSetMatch a

foreign import capi "fontconfig-wrap.h" fcFontSetMatch ::
        Ptr Config' -> CString -> Int -> CString -> Int -> Ptr Int -> CString

fontSetSort :: Config -> [FontSet] -> Pattern -> Bool -> (Maybe FontSet, CharSet')
fontSetSort a b c d = fromMessage0 $ flip withForeignPtr' a $ \a' ->
        arg b $ \b' x -> arg c $ \c' y -> fcFontSetSort a' b' x c' y d

foreign import capi "fontconfig-wrap.h" fcFontSetSort ::
        Ptr Config' -> CString -> Int -> CString -> Int -> Bool -> Ptr Int -> CString

------
--- Utilities
------
arg :: MessagePack a => a -> (CString -> Int -> b) -> b
arg = flip withMessage

------
--- CSS Bindings
------

-- | `StyleSheet` wrapper to parse @font-face rules.
data FontFaceParser a = FontFaceParser { cssFonts :: FontSet, cssInner :: a}

{- parseFontFaceSrc (Function "local":Ident name:RightParen:Comma:rest) =
    ("local:" ++ unpack name):parseFontFaceSrc rest
parseFontFaceSrc (Function "local":String name:RightParen:Comma:rest) =
    ("local:" ++ unpack name):parseFontFaceSrc rest
parseFontFaceSrc (Function "local":Ident name:RightParen:[]) = ["local:" ++ unpack name]
parseFontFaceSrc (Function "local":String name:RightParen:[]) = ["local:" ++ unpack name]

parseFontFaceSrc (Url link:toks)
    | Comma:rest <- skipMeta toks = unpack link:parseFontFaceSrc rest
    | [] <- skipMeta toks = [unpack link]
    | otherwise = [""] -- Error indicator!
  where
    skipMeta (Function "format":Ident _:RightParen:rest) = skipMeta rest
    skipMeta (Function "format":String _:RightParen:rest) = skipMeta rest
    skipMeta (Function "tech":Ident _:RightParen:rest) = skipMeta rest
    skipMeta (Function "tech":String _:RightParen:rest) = skipMeta rest
    skipMeta toks = toks

parseFontFaceSrc _ = [""]

properties2font :: [(Text, [Token])] -> Pattern
properties2font (("font-family", [String font]):props) =
    setValue "family" Strong (unpack font) $ properties2font props
properties2font (("font-family", [Ident font]):props) =
    setValue "family" Strong (unpack font) $ properties2font props

properties2font (("font-stretch", [tok]):props) | Just x <- parseFontStretch tok =
    setValue "width" Strong x $ properties2font props
properties2font (("font-stretch", [start, end]):props)
    | Just x <- parseFontStretch start, Just y <- parseFontStretch end =
        setValue "width" Strong (x `iRange` y) $ properties2font props

properties2font (("font-weight", [tok]):props) | Just x <- parseFontWeight tok =
    setValue "width" Strong x $ properties2font props
properties2font (("font-weight", [start, end]):props)
    | Just x <- parseFontStretch start, Just y <- parseFontStretch end =
        setValue "weight" Strong (x `iRange` y) $ properties2font props

properties2font (("font-feature-settings", toks):props)
    | (features, True, []) <- parseFontFeatures toks =
        setValue "fontfeatures" Strong (intercalate "," $ map fst features) $
            properties2font props

properties2font (("font-variation-settings", toks):props)
    | (_, True, []) <- parseFontVars toks =
        setValue "variable" Strong True $ properties2font props

properties2font (("unicode-range", toks):props)
    | Just chars <- parseCharSet $ unpack $ serialize toks =
        setValue "charset" Strong chars $ properties2font props

-- Ignoring metadata & trusting in FreeType's broad support for fonts.
properties2font (("src", toks):props)
    | fonts@(_:_) <- parseFontFaceSrc toks, "" `notElem` fonts =
        setValue "web-src" Strong (intercalate "\t" fonts) $ properties2font props

properties2font (_:props) = properties2font props
properties2font [] = []

instance StyleSheet a => StyleSheet (FontFaceParser a) where
    setPriorities v (FontFaceParser x self) = FontFaceParser x $ setPriorities v self
    addRule (FontFaceParser x self) rule = FontFaceParser x $ addRule self rule

    addAtRule (FontFaceParser fonts self) "font-face" toks =
        let ((props, _), toks') = parseProperties toks
        in (FontFaceParser (properties2font props:fonts) self, toks')
    addAtRule (FontFaceParser x self) key toks =
        let (a, b) = addAtRule self key toks in (FontFaceParser x a, b) -}