126 lines
5.1 KiB
Haskell
126 lines
5.1 KiB
Haskell
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
|