blob: 07eb1cf2bbdb25cb4b2b88504103ab62db5ae404 (
plain)
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
118
119
120
121
122
123
124
125
126
|
module Phi.X11.Util ( getReply'
, changeProperty8
, changeProperty16
, changeProperty32
, getProperty8
, getProperty16
, getProperty32
, findVisualtype
, serializeClientMessage
) where
import Control.Exception (assert)
import Control.Monad
import Data.Int
import Data.List
import Data.Maybe
import Data.Word
import Foreign.C.Types
import Foreign.Marshal.Array
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.Storable
import Graphics.XHB
import Graphics.XHB.Gen.Xproto
import System.IO.Unsafe
getReply' :: String -> Receipt a -> IO a
getReply' m = getReply >=> return . fromRight
where
fromRight (Left _) = error m
fromRight (Right a) = a
castWord16to8 :: [Word16] -> [Word8]
castWord16to8 input = unsafePerformIO $
withArray input $ \ptr ->
peekArray (2 * length input) (castPtr ptr)
castWord32to8 :: [Word32] -> [Word8]
castWord32to8 input = unsafePerformIO $
withArray input $ \ptr ->
peekArray (4 * length input) (castPtr ptr)
castWord8to16 :: [Word8] -> [Word16]
castWord8to16 input = unsafePerformIO $
withArray input $ \ptr ->
peekArray (length input `div` 2) (castPtr ptr)
castWord8to32 :: [Word8] -> [Word32]
castWord8to32 input = unsafePerformIO $
withArray input $ \ptr ->
peekArray (length input `div` 4) (castPtr ptr)
castToCChar :: Storable s => s -> [CChar]
castToCChar input = unsafePerformIO $
with input $ \ptr ->
peekArray (sizeOf input) (castPtr ptr)
changeProperty8 :: ConnectionClass c => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word8] -> IO ()
changeProperty8 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 8 (genericLength propdata) propdata
changeProperty16 :: ConnectionClass c => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word16] -> IO ()
changeProperty16 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 16 (genericLength propdata) (castWord16to8 propdata)
changeProperty32 :: ConnectionClass c => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word32] -> IO ()
changeProperty32 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 32 (genericLength propdata) (castWord32to8 propdata)
getProperty' :: ConnectionClass c => Word8 -> c -> WINDOW -> ATOM -> IO (Maybe [Word8])
getProperty' format conn win prop = do
reply <- getProperty conn (MkGetProperty False win prop (fromXid xidNone) 0 4) >>= getReply
case reply of
Left _ -> return Nothing
Right (MkGetPropertyReply {format_GetPropertyReply = format'}) | format' /= format -> return Nothing
Right (MkGetPropertyReply {bytes_after_GetPropertyReply = 0, value_GetPropertyReply = value}) -> return $ Just value
Right (MkGetPropertyReply {bytes_after_GetPropertyReply = bytes_after}) -> do
reply' <- getProperty conn (MkGetProperty False win prop (fromXid xidNone) 0 (4+bytes_after)) >>= getReply
case reply' of
Left _ -> return Nothing
Right (MkGetPropertyReply {format_GetPropertyReply = format'}) | format' /= format -> return Nothing
Right (MkGetPropertyReply {value_GetPropertyReply = value}) -> return $ Just value
getProperty8 :: ConnectionClass c => c -> WINDOW -> ATOM -> IO (Maybe [Word8])
getProperty8 = getProperty' 8
getProperty16 :: ConnectionClass c => c -> WINDOW -> ATOM -> IO (Maybe [Word16])
getProperty16 conn win prop = getProperty' 16 conn win prop >>= return . fmap castWord8to16
getProperty32 :: ConnectionClass c => c -> WINDOW -> ATOM -> IO (Maybe [Word32])
getProperty32 conn win prop = getProperty' 32 conn win prop >>= return . fmap castWord8to32
findVisualtype :: SCREEN -> VISUALID -> Maybe VISUALTYPE
findVisualtype screen id = listToMaybe . filter ((== id) . visual_id_VISUALTYPE) . join . map visuals_DEPTH . allowed_depths_SCREEN $ screen
instance Storable ClientMessageData where
sizeOf _ = 20
alignment _ = 1
peek _ = error "ClientMessageData: peek not implemented"
poke ptr (ClientData8 d) = assert (length d == 20) $ pokeArray (castPtr ptr) d
poke ptr (ClientData16 d) = assert (length d == 10) $ pokeArray (castPtr ptr) d
poke ptr (ClientData32 d) = assert (length d == 5) $ pokeArray (castPtr ptr) d
instance Storable ClientMessageEvent where
sizeOf _ = 32
alignment _ = 1
peek _ = error "ClientMessageEvent: peek not implemented"
poke ptr ev = do
poke' 0 (33 :: Word8) -- ClientMessage == 33 -- response_type
poke' 1 (format_ClientMessageEvent ev) -- format
poke' 2 (0 :: Word16) -- sequence
poke' 4 (fromXid . toXid . window_ClientMessageEvent $ ev :: Word32) -- window
poke' 8 (fromXid . toXid . type_ClientMessageEvent $ ev :: Word32) -- type
poke' 12 (data_ClientMessageEvent ev) -- data
where
poke' :: Storable s => Int -> s -> IO ()
poke' = poke . plusPtr ptr
serializeClientMessage :: ClientMessageEvent -> [CChar]
serializeClientMessage = castToCChar
|
