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