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
|
{-# OPTIONS -fglasgow-exts -ffi #-}
module XProto(internAtom, Atom, InternAtomReply(..), listFontsWithInfo, ListFontsWithInfoReply(..)) where
import XCB
import XCBExt
import CForeign
import Foreign
import Control.Monad.State
type Atom = Word32
data CharInfo = CharInfo Int16 Int16 Int16 Int16 Int16 Word16
deriving Show
instance Readable CharInfo where
replyRead = do
left_side_bearing <- replyRead
right_side_bearing <- replyRead
character_width <- replyRead
ascent <- replyRead
descent <- replyRead
attributes <- replyRead
return $ CharInfo left_side_bearing right_side_bearing character_width ascent descent attributes
data FontProp = FontProp Atom Word32
deriving Show
instance Readable FontProp where
replyRead = do
name <- replyRead
value <- replyRead
return $ FontProp name value
foreign import ccall "XProto.glue.h" _internAtom :: Ptr XCBConnection -> Word8 -> Word16 -> CString -> IO Word32
data InternAtomReply = InternAtomReply { internAtomResponseType :: Word8, internAtomSequence :: Word16, internAtomLength :: Word32, internAtomAtom :: Atom }
internAtom :: Ptr XCBConnection -> Bool -> String -> IO InternAtomReply
internAtom c onlyIfExists name =
(requestWithReply c reader $ withCStringLen name (\(name, name_len)-> _internAtom c (fromBool onlyIfExists) (toEnum name_len) name))
>>= return . head
where reader = do
responseType <- replyRead
sequence <- replyRead
length <- replyRead
atom <- replyRead
return $ InternAtomReply responseType sequence length atom
foreign import ccall "XProto.glue.h" _ListFontsWithInfo :: Ptr XCBConnection -> Word16 -> Word16 -> CString -> IO Word32
data ListFontsWithInfoReply = ListFontsWithInfoReply { min_bounds :: CharInfo, max_bounds :: CharInfo, min_char_or_byte2 :: Word16, max_char_or_byte2 :: Word16, default_char :: Word16, draw_direction :: Word8, min_byte1 :: Word8, max_byte1 :: Word8, all_chars_exist :: Bool, font_ascent :: Int16, font_descent :: Int16, replies_hint :: Word32, properties :: [FontProp], name :: String }
deriving Show
listFontsWithInfo :: Ptr XCBConnection -> Word16 -> String -> IO [ListFontsWithInfoReply]
listFontsWithInfo c max_names pattern =
(requestWithReply c reader $ withCStringLen pattern $ \(pattern, pattern_len)-> _ListFontsWithInfo c max_names (toEnum pattern_len) pattern)
>>= return . takeWhile (\f-> name f /= "")
where
reader = do
modify (+ 1)
name_len <- replyRead :: ReplyReader Word8
modify (+ 6)
min_bounds <- replyRead
modify (+ 4)
max_bounds <- replyRead
modify (+ 4)
min_char_or_byte2 <- replyRead
max_char_or_byte2 <- replyRead
default_char <- replyRead
properties_len <- replyRead :: ReplyReader Word16
draw_direction <- replyRead
min_byte1 <- replyRead
max_byte1 <- replyRead
all_chars_exist <- replyRead
font_ascent <- replyRead
font_descent <- replyRead
replies_hint <- replyRead
properties <- replyReadLen properties_len
modify (\n-> (n + 3) .&. (-4))
name <- readString name_len
return $ ListFontsWithInfoReply min_bounds max_bounds min_char_or_byte2 max_char_or_byte2 default_char draw_direction min_byte1 max_byte1 all_chars_exist font_ascent font_descent replies_hint properties name
|
