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
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, allocaBytes)
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 = allocaBytes 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 "FcCharSetFirstPage" fcCharSetFirstPage ::
CharSet_ -> Ptr Word32 -> Ptr Word32 -> IO Word32
foreign import ccall "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