~alcinnz/fontconfig-pure

ref: f8fdd180c8ce9f95507dc16873186743e5bc6d03 fontconfig-pure/Graphics/Text/Font/Choose/CharSet.hs -rw-r--r-- 3.3 KiB
f8fdd180 — Adrian Cochrane Attempted segfault fix. 1 year, 2 months ago
                                                                                
e21707cb Adrian Cochrane
67bb6d07 Adrian Cochrane
e21707cb Adrian Cochrane
58befc6c Adrian Cochrane
e21707cb Adrian Cochrane
f8fdd180 Adrian Cochrane
e21707cb Adrian Cochrane
67bb6d07 Adrian Cochrane
e21707cb Adrian Cochrane
f32f82d2 Adrian Cochrane
e21707cb Adrian Cochrane
67bb6d07 Adrian Cochrane
f32f82d2 Adrian Cochrane
67bb6d07 Adrian Cochrane
e21707cb Adrian Cochrane
58198ed8 Adrian Cochrane
e21707cb Adrian Cochrane
58befc6c Adrian Cochrane
e21707cb Adrian Cochrane
8abf2980 Adrian Cochrane
f8fdd180 Adrian Cochrane
8abf2980 Adrian Cochrane
f8fdd180 Adrian Cochrane
8abf2980 Adrian Cochrane
f8fdd180 Adrian Cochrane
e21707cb Adrian Cochrane
f8fdd180 Adrian Cochrane
e21707cb Adrian Cochrane
58198ed8 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
module Graphics.Text.Font.Choose.CharSet where

import Data.Set (Set, union)
import qualified Data.Set as Set
import Graphics.Text.Font.Choose.Result (throwNull, throwFalse)

import Data.Word (Word32)
import Foreign.Ptr
import Control.Exception (bracket)
import Control.Monad (forM)
import Foreign.Marshal.Alloc (alloca)
import Foreign.Marshal.Array (allocaArray)
import GHC.Base (unsafeChr)
import Data.Char (ord, isHexDigit)
import Numeric (readHex)

-- | An FcCharSet is a set of Unicode chars.
type CharSet = Set Char

parseChar :: String -> Char
parseChar str | ((x, _):_) <- readHex str = toEnum x
replaceWild ch ('?':rest) = ch:replaceWild ch rest
replaceWild ch (c:cs) = c:replaceWild ch cs
replaceWild _ "" = ""
parseWild ch str = parseChar $ replaceWild ch str
-- | Utility for parsing "unicode-range" @font-face property.
parseCharSet ('U':rest) = parseCharSet ('u':rest) -- lowercase initial "u"
parseCharSet ('u':'+':cs)
    | (start@(_:_), '-':ends) <- span isHexDigit cs,
        (end@(_:_), rest) <- span isHexDigit ends, Just set <- parseCharSet' rest =
            Just $ Set.union set $ Set.fromList [parseChar start..parseChar end]
    | (codepoint@(_:_), rest) <- span isHexDigit cs, Just set <- parseCharSet' rest =
        Just $ flip Set.insert set $ parseChar codepoint
    | (codepoint@(_:_), rest) <- span (\c -> isHexDigit c || c == '?') cs,
        Just set <- parseCharSet' rest =
            Just $ Set.union set $ Set.fromList [
                parseWild '0' codepoint..parseWild 'f' codepoint]
parseCharSet _ = Nothing
parseCharSet' (',':rest) = parseCharSet rest
parseCharSet' "" = Just Set.empty
parseCharSet' _ = Nothing

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

data CharSet'
type CharSet_ = Ptr CharSet'

withNewCharSet :: (CharSet_ -> IO a) -> IO a
withNewCharSet cb = bracket (throwNull <$> fcCharSetCreate) fcCharSetDestroy cb
foreign import ccall "FcCharSetCreate" fcCharSetCreate :: IO CharSet_
foreign import ccall "FcCharSetDestroy" fcCharSetDestroy :: CharSet_ -> IO ()

withCharSet :: CharSet -> (CharSet_ -> IO a) -> IO a
withCharSet chars cb = withNewCharSet $ \chars' -> do
    forM (Set.elems chars) $ \ch' ->
        throwFalse <$> (fcCharSetAddChar chars' $ fromIntegral $ ord ch')
    cb chars'
foreign import ccall "FcCharSetAddChar" fcCharSetAddChar :: CharSet_ -> Word32 -> IO Bool

thawCharSet :: CharSet_ -> IO CharSet
thawCharSet chars'
    | chars' == nullPtr = return Set.empty
    | otherwise = allocaArray fcCHARSET_MAP_SIZE $ \iter' -> alloca $ \next' -> do
        first <- fcCharSetFirstPage chars' iter' next'
        let go = do
                ch <- fcCharSetNextPage chars' iter' next'
                if ch == maxBound then return []
                else do
                    chs <- go
                    return (ch:chs)
        if first == maxBound then return Set.empty else do
            rest <- go
            return $ Set.fromList $ map (unsafeChr . fromIntegral) (first:rest)
foreign import ccall "my_FcCharSetFirstPage" fcCharSetFirstPage ::
    CharSet_ -> Ptr Word32 -> Ptr Word32 -> IO Word32
foreign import ccall "my_FcCharSetNextPage" fcCharSetNextPage ::
    CharSet_ -> Ptr Word32 -> Ptr Word32 -> IO Word32
foreign import ccall "my_FcCHARSET_MAP_SIZE" fcCHARSET_MAP_SIZE :: Int

thawCharSet_ :: IO CharSet_ -> IO CharSet
thawCharSet_ cb = bracket (throwNull <$> cb) fcCharSetDestroy thawCharSet