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
module Graphics.Text.Font.Choose.CharSet where
import Data.Set (Set)
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)
type CharSet = Set Char
------
--- 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' = 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