phi/lib/Phi/X11/Util.hs

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