89 lines
3.5 KiB
Haskell
89 lines
3.5 KiB
Haskell
|
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
|