diff options
Diffstat (limited to 'lib/Phi/X11/Util.hs')
| -rw-r--r-- | lib/Phi/X11/Util.hs | 89 |
1 files changed, 89 insertions, 0 deletions
diff --git a/lib/Phi/X11/Util.hs b/lib/Phi/X11/Util.hs new file mode 100644 index 0000000..cadceeb --- /dev/null +++ b/lib/Phi/X11/Util.hs @@ -0,0 +1,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
\ No newline at end of file |