blob: cadceeb5f5de7ddcbd7cf3d938f382b2ab91976d (
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
|
module Phi.X11.Util ( getReply'
, changeProperty8
, changeProperty16
, changeProperty32
, getProperty8
, getProperty16
, getProperty32
, findVisualtype
) where
import Control.Monad
import Data.Int
import Data.List
import Data.Maybe
import Data.Word
import Foreign.Marshal.Array
import Foreign.Ptr
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)
changeProperty8 :: Connection -> 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 :: Connection -> 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 :: Connection -> 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' :: Word8 -> Connection -> 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 :: Connection -> WINDOW -> ATOM -> IO (Maybe [Word8])
getProperty8 = getProperty' 8
getProperty16 :: Connection -> WINDOW -> ATOM -> IO (Maybe [Word16])
getProperty16 conn win prop = getProperty' 16 conn win prop >>= return . fmap castWord8to16
getProperty32 :: Connection -> 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
|
