summaryrefslogtreecommitdiffstats
path: root/lib/Phi
diff options
context:
space:
mode:
authorMatthias Schiffer <mschiffer@universe-factory.net>2011-09-07 16:38:36 +0200
committerMatthias Schiffer <mschiffer@universe-factory.net>2011-09-07 16:38:36 +0200
commit15d9304e052d2e5d4416e54a6fd24fbd0a252964 (patch)
tree0c9384b5fa0554ac7fd6deb7bc4a077b065e8a7c /lib/Phi
parent42d5f27d32c74b29545ce0922e55407fa5ccc7fc (diff)
downloadphi-15d9304e052d2e5d4416e54a6fd24fbd0a252964.tar
phi-15d9304e052d2e5d4416e54a6fd24fbd0a252964.zip
Converted core to XHB/XCB
Diffstat (limited to 'lib/Phi')
-rw-r--r--lib/Phi/Bindings/SystrayErrorHandler.hsc17
-rw-r--r--lib/Phi/Bindings/Util.hsc90
-rw-r--r--lib/Phi/Bindings/XCB.hsc92
-rw-r--r--lib/Phi/Widget.hs45
-rw-r--r--lib/Phi/X11.hs376
-rw-r--r--lib/Phi/X11/AtomList.hs14
-rw-r--r--lib/Phi/X11/Atoms.hs32
-rw-r--r--lib/Phi/X11/Util.hs89
8 files changed, 423 insertions, 332 deletions
diff --git a/lib/Phi/Bindings/SystrayErrorHandler.hsc b/lib/Phi/Bindings/SystrayErrorHandler.hsc
deleted file mode 100644
index 73fedbb..0000000
--- a/lib/Phi/Bindings/SystrayErrorHandler.hsc
+++ /dev/null
@@ -1,17 +0,0 @@
-{-# LANGUAGE ForeignFunctionInterface #-}
-
-module Phi.Bindings.SystrayErrorHandler ( setSystrayErrorHandler
- , getLastErrorWindow
- ) where
-
-#include <SystrayErrorHandler.h>
-
-
-import Graphics.X11.Xlib
-
-
-foreign import ccall unsafe "SystrayErrorHandler.h setSystrayErrorHandler"
- setSystrayErrorHandler :: IO ()
-
-foreign import ccall unsafe "SystrayErrorHandler.h getLastErrorWindow"
- getLastErrorWindow :: IO Window
diff --git a/lib/Phi/Bindings/Util.hsc b/lib/Phi/Bindings/Util.hsc
deleted file mode 100644
index bae6c71..0000000
--- a/lib/Phi/Bindings/Util.hsc
+++ /dev/null
@@ -1,90 +0,0 @@
-{-# LANGUAGE ForeignFunctionInterface #-}
-
-module Phi.Bindings.Util ( setClassHint
- , visualIDFromVisual
- , putClientMessage
- , Phi.Bindings.Util.getEvent
- , createXlibSurface
- ) where
-
-
-#include <X11/Xlib.h>
-#include <X11/Xutil.h>
-#include <cairo.h>
-#include <cairo-xlib.h>
-
-
-import Foreign.C.String (withCString)
-import Foreign.C.Types
-import Foreign.Ptr
-import Foreign.Marshal.Alloc (alloca, allocaBytes)
-import Foreign.Marshal.Array
-import Foreign.Storable
-
-import Graphics.X11.Xlib
-import Graphics.X11.Xlib.Extras
-
-import Graphics.Rendering.Cairo.Types
-
-
-foreign import ccall unsafe "X11/Xutil.h XSetClassHint"
- xSetClassHint :: Display -> Window -> Ptr ClassHint -> IO ()
-
-setClassHint :: Display -> Window -> ClassHint -> IO ()
-setClassHint disp wnd hint = allocaBytes (#size XClassHint) $ \p ->
- withCString (resName hint) $ \res_name ->
- withCString (resClass hint) $ \res_class -> do
- (#poke XClassHint, res_name) p res_name
- (#poke XClassHint, res_class) p res_class
- xSetClassHint disp wnd p
-
-foreign import ccall unsafe "X11/Xlib.h XVisualIDFromVisual"
- visualIDFromVisual :: Visual -> VisualID
-
-putClientMessage :: XEventPtr -> Window -> Atom -> [CLong] -> IO ()
-putClientMessage event window message_type messageData = do
- setEventType event clientMessage
- (#poke XClientMessageEvent, window) event window
- (#poke XClientMessageEvent, message_type) event message_type
- (#poke XClientMessageEvent, format) event (32 :: CInt)
- pokeArray ((#ptr XClientMessageEvent, data.l) event) $ take 5 messageData
-
-foreign import ccall unsafe "cairo-xlib.h cairo_xlib_surface_create"
- xlibSurfaceCreate :: Display -> Drawable -> Visual -> CInt -> CInt -> IO (Ptr Surface)
-
-getEvent :: Display -> XEventPtr -> IO Event
-getEvent display p = do
- eventType <- get_EventType p
- case True of
- _ | eventType == clientMessage -> do
- serial <- (#peek XClientMessageEvent, serial) p
- send_event <- (#peek XClientMessageEvent, send_event) p
- window <- (#peek XClientMessageEvent, window) p
- message_type <- (#peek XClientMessageEvent, message_type) p
- format <- (#peek XClientMessageEvent, format) p
- let datPtr = (#ptr XClientMessageEvent, data) p
- dat <- case (format::CInt) of
- 8 -> do a <- peekArray 20 datPtr
- return $ map fromIntegral (a::[CUChar])
- 16 -> do a <- peekArray 10 datPtr
- return $ map fromIntegral (a::[CUShort])
- 32 -> do a <- peekArray 5 datPtr
- return $ map fromIntegral (a::[CULong])
- return $ ClientMessageEvent { ev_event_type = eventType
- , ev_serial = serial
- , ev_send_event = send_event
- , ev_event_display = display
- , ev_window = window
- , ev_message_type = message_type
- , ev_data = dat
- }
- | otherwise -> Graphics.X11.Xlib.Extras.getEvent p
-
-
-createXlibSurface :: Display -> Drawable -> Visual -> CInt -> CInt -> IO Surface
-createXlibSurface dpy drawable visual width height = do
- surfacePtr <- xlibSurfaceCreate dpy drawable visual width height
- surface <- mkSurface surfacePtr
- manageSurface surface
- return surface
-
diff --git a/lib/Phi/Bindings/XCB.hsc b/lib/Phi/Bindings/XCB.hsc
new file mode 100644
index 0000000..33aff03
--- /dev/null
+++ b/lib/Phi/Bindings/XCB.hsc
@@ -0,0 +1,92 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+module Phi.Bindings.XCB ( Connection
+ , connect
+ , createXCBSurface
+ , flush
+ , clearArea
+ ) where
+
+import Control.Monad
+
+import Data.Int
+import Data.Word
+
+import Foreign.C.String
+import Foreign.C.Types
+import Foreign.ForeignPtr
+import Foreign.Marshal.Alloc
+import Foreign.Marshal.Utils
+import Foreign.Ptr
+import Foreign.Storable
+
+import Graphics.Rendering.Cairo.Types
+import Graphics.XHB (toValue)
+import Graphics.XHB.Gen.Xproto (DRAWABLE, WINDOW, VISUALTYPE(..))
+
+
+#include <xcb/xcb.h>
+#include <xcb/xproto.h>
+#include <cairo-xcb.h>
+
+
+data Connection = Connection (ForeignPtr Connection)
+
+foreign import ccall "xcb/xcb.h xcb_connect" xcb_connect :: CString -> Ptr CInt -> IO (Ptr Connection)
+foreign import ccall "xcb/xcb.h &xcb_disconnect" p_xcb_disconnect :: FunPtr (Ptr Connection -> IO ())
+
+connect :: IO Connection
+connect = do
+ conn <- xcb_connect nullPtr nullPtr
+ newForeignPtr p_xcb_disconnect conn >>= return . Connection
+
+foreign import ccall "cairo-xlib.h cairo_xcb_surface_create"
+ cairo_xcb_surface_create :: Ptr Connection -> DRAWABLE -> Ptr VISUALTYPE -> CInt -> CInt -> IO (Ptr Surface)
+
+instance Storable VISUALTYPE where
+ sizeOf _ = (#size xcb_visualtype_t)
+ alignment _ = alignment (undefined :: CInt)
+
+ peek _ = error "VISUALTYPE: peek not implemented"
+
+ poke vt (MkVISUALTYPE visual_id _class bits_per_rgb_value colormap_entries red_mask green_mask blue_mask) = do
+ (#poke xcb_visualtype_t, visual_id) vt visual_id
+ (#poke xcb_visualtype_t, _class) vt (toValue _class :: Word8)
+ (#poke xcb_visualtype_t, bits_per_rgb_value) vt bits_per_rgb_value
+ (#poke xcb_visualtype_t, colormap_entries) vt colormap_entries
+ (#poke xcb_visualtype_t, red_mask) vt red_mask
+ (#poke xcb_visualtype_t, green_mask) vt green_mask
+ (#poke xcb_visualtype_t, blue_mask) vt blue_mask
+
+createXCBSurface :: Connection -> DRAWABLE -> VISUALTYPE -> CInt -> CInt -> IO Surface
+createXCBSurface (Connection conn) drawable visual width height =
+ with visual $ \visualptr -> withForeignPtr conn $ \connptr -> do
+ surfacePtr <- cairo_xcb_surface_create connptr drawable visualptr width height
+ surface <- mkSurface surfacePtr
+ manageSurface surface
+ return surface
+
+foreign import ccall "xcb/xcb.h xcb_flush"
+ xcb_flush :: Ptr Connection -> IO ()
+
+flush :: Connection -> IO ()
+flush (Connection conn) = withForeignPtr conn xcb_flush
+
+type VOID_COOKIE = CUInt
+
+foreign import ccall "xcb/xcb.h xcb_request_check"
+ xcb_request_check :: Ptr Connection -> VOID_COOKIE -> IO (Ptr ())
+
+requestCheck :: Ptr Connection -> VOID_COOKIE -> IO ()
+requestCheck conn cookie = do
+ ret <- xcb_request_check conn cookie
+ when (ret /= nullPtr) $
+ free ret
+
+foreign import ccall "xcb/xproto.h xcb_clear_area"
+ xcb_clear_area :: Ptr Connection -> Word8 -> WINDOW -> Int16 -> Int16 -> Word16 -> Word16 -> IO VOID_COOKIE
+
+clearArea :: Connection -> Bool -> WINDOW -> Int16 -> Int16 -> Word16 -> Word16 -> IO ()
+clearArea (Connection conn) exposures window x y width height = withForeignPtr conn $ \connptr -> do
+ cookie <- xcb_clear_area connptr (if exposures then 1 else 0) window x y width height
+ requestCheck connptr cookie
diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs
index e3f8388..788abc2 100644
--- a/lib/Phi/Widget.hs
+++ b/lib/Phi/Widget.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, DeriveDataTypeable, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-}
-module Phi.Widget ( Display(..)
+module Phi.Widget ( XEvent(..)
+ , Display(..)
, withDisplay
, getAtoms
, XMessage(..)
@@ -30,36 +31,38 @@ import Control.Monad.IO.Class
import Data.Maybe
import Data.Typeable
-import qualified Graphics.X11.Xlib as Xlib
+import Graphics.XHB
import Graphics.Rendering.Cairo
import Phi.Phi
import Phi.X11.Atoms
-data Display = Display !(MVar Xlib.Display) !Atoms
+data Display = Display !Connection !Atoms
-withDisplay :: MonadIO m => Display -> (Xlib.Display -> m a) -> m a
-withDisplay (Display dispvar _) f = do
- disp <- liftIO $ takeMVar dispvar
- a <- f disp
- liftIO $ putMVar dispvar disp
- return a
+newtype XEvent = XEvent SomeEvent deriving Typeable
+
+instance Show XEvent where
+ show _ = "XEvent (..)"
+
+
+withDisplay :: MonadIO m => Display -> (Connection -> m a) -> m a
+withDisplay (Display conn _) f = f conn
getAtoms :: Display -> Atoms
getAtoms (Display _ atoms) = atoms
-data XMessage = UpdateScreens [(Xlib.Rectangle, Xlib.Window)] deriving (Show, Typeable)
+data XMessage = UpdateScreens [(RECTANGLE, WINDOW)] deriving (Show, Typeable)
-unionArea :: Xlib.Rectangle -> Xlib.Rectangle -> Int
+unionArea :: RECTANGLE -> RECTANGLE -> Int
unionArea a b = fromIntegral $ uw*uh
where
uw = max 0 $ (min ax2 bx2) - (max ax1 bx1)
uh = max 0 $ (min ay2 by2) - (max ay1 by1)
- Xlib.Rectangle ax1 ay1 aw ah = a
- Xlib.Rectangle bx1 by1 bw bh = b
+ MkRECTANGLE ax1 ay1 aw ah = a
+ MkRECTANGLE bx1 by1 bw bh = b
ax2 = ax1 + fromIntegral aw
ay2 = ay1 + fromIntegral ah
@@ -71,22 +74,24 @@ unionArea a b = fromIntegral $ uw*uh
data SurfaceSlice = SurfaceSlice !Int !Surface
class Eq s => Widget w s c | w -> s, w -> c where
- initWidget :: w -> Phi -> Display -> [(Xlib.Rectangle, Xlib.Window)] -> IO s
+ initWidget :: w -> Phi -> Display -> [(RECTANGLE, WINDOW)] -> IO s
initCache :: w -> c
- minSize :: w -> s -> Int -> Xlib.Rectangle -> Int
+ minSize :: w -> s -> Int -> RECTANGLE -> Int
weight :: w -> Float
weight _ = 0
- render :: w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> StateT c IO [(Bool, SurfaceSlice)]
+ render :: w -> s -> Int -> Int -> Int -> Int -> RECTANGLE -> StateT c IO [(Bool, SurfaceSlice)]
handleMessage :: w -> s -> Message -> s
handleMessage _ priv _ = priv
+deriving instance Eq RECTANGLE
+
type IOCache = CacheArrow (Kleisli IO)
-type RenderCache s = IOCache (s, Int, Int, Int, Int, Xlib.Rectangle) Surface
+type RenderCache s = IOCache (s, Int, Int, Int, Int, RECTANGLE) Surface
createIOCache :: Eq a => (a -> IO b) -> IOCache a b
createIOCache = lift . Kleisli
@@ -98,8 +103,8 @@ runIOCache a = do
put cache'
return b
-createRenderCache :: (s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> Render ())
- -> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, Xlib.Rectangle) Surface
+createRenderCache :: (s -> Int -> Int -> Int -> Int -> RECTANGLE -> Render ())
+ -> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, RECTANGLE) Surface
createRenderCache f = lift . Kleisli $ \(state, x, y, w, h, screen) -> do
surface <- createImageSurface FormatARGB32 w h
renderWith surface $ do
@@ -109,7 +114,7 @@ createRenderCache f = lift . Kleisli $ \(state, x, y, w, h, screen) -> do
f state x y w h screen
return surface
-renderCached :: Eq s => s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> StateT (RenderCache s) IO [(Bool, SurfaceSlice)]
+renderCached :: Eq s => s -> Int -> Int -> Int -> Int -> RECTANGLE -> StateT (RenderCache s) IO [(Bool, SurfaceSlice)]
renderCached state x y w h screen = do
cache <- get
(surf, updated, cache') <- liftIO $ runKleisli (runCache' cache) (state, x, y, w, h, screen)
diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs
index 82809f2..cc53cea 100644
--- a/lib/Phi/X11.hs
+++ b/lib/Phi/X11.hs
@@ -5,16 +5,19 @@ module Phi.X11 ( XConfig(..)
, runPhi
) where
-import Graphics.X11.Xlib
-import Graphics.X11.Xlib.Extras
-import Graphics.X11.Xinerama
+import Graphics.XHB
+import Graphics.XHB.Gen.Xinerama
+import Graphics.XHB.Gen.Xproto
import Graphics.Rendering.Cairo
import Control.Monad
-import Data.Maybe
import Data.Bits
import Data.Char
+import Data.List
+import Data.Maybe
+import Data.Typeable
+import Data.Word
import Control.Arrow ((&&&))
import Control.Concurrent
@@ -27,16 +30,18 @@ import System.Exit
import System.Posix.Signals
import System.Posix.Types
+import qualified Phi.Bindings.XCB as XCB
+
import Phi.Phi
+import Phi.X11.Util
import qualified Phi.Types as Phi
import qualified Phi.Panel as Panel
import qualified Phi.Widget as Widget
import Phi.Widget hiding (Display, handleMessage)
import Phi.X11.Atoms
-import qualified Phi.Bindings.Util as Util
-data XConfig = XConfig { phiXScreenInfo :: !(Display -> IO [Rectangle])
+data XConfig = XConfig { phiXScreenInfo :: !(Connection -> IO [RECTANGLE])
}
data PhiState w s c = (Widget.Widget w s c) => PhiState { phiRootImage :: !Surface
@@ -47,10 +52,10 @@ data PhiState w s c = (Widget.Widget w s c) => PhiState { phiRootImage :: !Su
, phiWidgetState :: !s
}
-data PanelState w s c = (Widget.Widget w s c) => PanelState { panelWindow :: !Window
- , panelPixmap :: !Pixmap
- , panelArea :: !Rectangle
- , panelScreenArea :: !Rectangle
+data PanelState w s c = (Widget.Widget w s c) => PanelState { panelWindow :: !WINDOW
+ , panelPixmap :: !PIXMAP
+ , panelArea :: !RECTANGLE
+ , panelScreenArea :: !RECTANGLE
, panelWidgetCache :: !c
}
@@ -76,27 +81,35 @@ runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st
defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
}
+getScreenInfo :: Connection -> IO [RECTANGLE]
+getScreenInfo conn = do
+ exs <- queryScreens conn >>= getReply
+ case exs of
+ Right xs -> return . map screenInfoToRect $ screen_info_QueryScreensReply xs
+ Left _ -> getGeometry conn (fromXid . toXid $ getRoot conn) >>= getReply' "getScreenInfo: getGeometry failed" >>=
+ return . (\(MkGetGeometryReply _ _ x y w h _) -> [MkRECTANGLE x y w h])
+ where
+ screenInfoToRect (MkScreenInfo x y w h) = MkRECTANGLE x y w h
+
runPhi :: (Widget.Widget w s c) => XConfig -> Panel.PanelConfig -> w -> IO ()
runPhi xconfig config widget = do
- xSetErrorHandler
-
phi <- initPhi
installHandler sigTERM (termHandler phi) Nothing
installHandler sigINT (termHandler phi) Nothing
installHandler sigQUIT (termHandler phi) Nothing
- disp <- openDisplay []
+ conn <- liftM fromJust connect
+ xcb <- XCB.connect
- atoms <- initAtoms disp
- selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask
+ atoms <- initAtoms conn
+ changeWindowAttributes conn (getRoot conn) $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])]
bg <- createImageSurface FormatRGB24 1 1
- dispmvar <- newMVar disp
- screens <- liftIO $ phiXScreenInfo xconfig disp
- panelWindows <- mapM (createPanelWindow disp config) screens
- let dispvar = Widget.Display dispmvar atoms
+ screens <- liftIO $ phiXScreenInfo xconfig conn
+ panelWindows <- mapM (createPanelWindow conn config) screens
+ let dispvar = Widget.Display conn atoms
widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1)
screenPanels = zip screens panelWindows
@@ -116,29 +129,28 @@ runPhi xconfig config widget = do
, phiShutdownHold = 0
, phiWidgetState = initialState
} $ do
- updateRootImage disp
+ updateRootImage conn xcb
+
+ panels <- mapM (\(screen, window) -> createPanel conn window screen) screenPanels
+
+ forM_ panels $ \panel -> do
+ setPanelProperties conn panel
+ liftIO $ mapWindow conn (panelWindow panel)
+
+ modify $ \state -> state { phiPanels = panels }
+
+ liftIO $ forkIO $ receiveEvents phi conn
- Widget.withDisplay dispvar $ \disp -> do
- panels <- mapM (\(screen, window) -> createPanel disp window screen) screenPanels
-
- forM_ panels $ \panel -> do
- setPanelProperties disp panel
- liftIO $ mapWindow disp (panelWindow panel)
-
- modify $ \state -> state { phiPanels = panels }
-
- liftIO $ forkIO $ receiveEvents phi dispvar
-
forever $ do
available <- messageAvailable phi
unless available $ do
repaint <- gets phiRepaint
when repaint $ do
- updatePanels dispvar
+ updatePanels conn xcb
modify $ \state -> state {phiRepaint = False}
message <- receiveMessage phi
- handleMessage dispvar message
+ handleMessage conn xcb message
case (fromMessage message) of
Just Shutdown ->
@@ -163,8 +175,8 @@ termHandler :: Phi -> Handler
termHandler phi = Catch $ sendMessage phi Shutdown
-handleMessage :: (Widget w s c) => Widget.Display -> Message -> PhiX w s c ()
-handleMessage dispvar m = do
+handleMessage :: (Widget w s c) => Connection -> XCB.Connection -> Message -> PhiX w s c ()
+handleMessage conn xcb m = do
w <- asks phiWidget
modify $ \state -> state {phiWidgetState = Widget.handleMessage w (phiWidgetState state) m}
@@ -173,34 +185,43 @@ handleMessage dispvar m = do
modify $ \state -> state {phiRepaint = True}
_ ->
case (fromMessage m) of
- Just event ->
- Widget.withDisplay dispvar $ flip handleEvent event
+ Just (XEvent event) ->
+ handleEvent conn xcb event
_ ->
return ()
-handleEvent :: (Widget w s c) => Display -> Event -> PhiX w s c ()
-handleEvent disp PropertyEvent { ev_atom = atom } = do
+handleEvent :: (Widget w s c) => Connection -> XCB.Connection -> SomeEvent -> PhiX w s c ()
+handleEvent conn xcb event = do
+ case (fromEvent event) of
+ Just e -> handlePropertyNotifyEvent conn xcb e
+ Nothing -> case (fromEvent event) of
+ Just e -> handleConfigureNotifyEvent conn e
+ Nothing -> return ()
+
+handlePropertyNotifyEvent :: (Widget w s c) => Connection -> XCB.Connection -> PropertyNotifyEvent -> PhiX w s c ()
+handlePropertyNotifyEvent conn xcb MkPropertyNotifyEvent { atom_PropertyNotifyEvent = atom } = do
phi <- asks phiPhi
atoms <- asks phiAtoms
panels <- gets phiPanels
when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do
- updateRootImage disp
+ updateRootImage conn xcb
sendMessage phi ResetBackground
sendMessage phi Repaint
-handleEvent disp ConfigureEvent { ev_window = window } | window == defaultRootWindow disp = do
+handleConfigureNotifyEvent :: (Widget w s c) => Connection -> ConfigureNotifyEvent -> PhiX w s c ()
+handleConfigureNotifyEvent conn MkConfigureNotifyEvent { window_ConfigureNotifyEvent = window } | window == getRoot conn = do
phi <- asks phiPhi
xconfig <- asks phiXConfig
config <- asks phiPanelConfig
panels <- gets phiPanels
let screens = map panelScreenArea panels
- screens' <- liftIO $ phiXScreenInfo xconfig disp
+ screens' <- liftIO $ phiXScreenInfo xconfig conn
when (screens /= screens') $ do
liftIO $ do
- mapM (freePixmap disp . panelPixmap) panels
- mapM_ (destroyWindow disp . panelWindow) $ drop (length screens') panels
+ mapM_ (freePixmap conn . panelPixmap) panels
+ mapM_ (destroyWindow conn . panelWindow) $ drop (length screens') panels
let panelsScreens = zip screens' $ map Just panels ++ repeat Nothing
@@ -210,17 +231,21 @@ handleEvent disp ConfigureEvent { ev_window = window } | window == defaultRootWi
let rect = panelBounds config screen
win = panelWindow panel
- liftIO $ withRectangle rect $ moveResizeWindow disp win
+ liftIO $ configureWindow conn win $ toValueParam [ (ConfigWindowX, fromIntegral $ x_RECTANGLE rect)
+ , (ConfigWindowY, fromIntegral $ y_RECTANGLE rect)
+ , (ConfigWindowWidth, fromIntegral $ width_RECTANGLE rect)
+ , (ConfigWindowHeight, fromIntegral $ height_RECTANGLE rect)
+ ]
- panel' <- createPanel disp win screen
- setPanelProperties disp panel'
+ panel' <- createPanel conn win screen
+ setPanelProperties conn panel'
return panel'
Nothing -> do
- win <- liftIO $ createPanelWindow disp config screen
- panel <- createPanel disp win screen
- setPanelProperties disp panel
- liftIO $ mapWindow disp $ panelWindow panel
+ win <- liftIO $ createPanelWindow conn config screen
+ panel <- createPanel conn win screen
+ setPanelProperties conn panel
+ liftIO $ mapWindow conn $ panelWindow panel
return panel
modify $ \state -> state { phiPanels = panels' }
@@ -228,30 +253,13 @@ handleEvent disp ConfigureEvent { ev_window = window } | window == defaultRootWi
sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels'
sendMessage phi Repaint
-handleEvent _ _ = return ()
+receiveEvents :: Phi -> Connection -> IO ()
+receiveEvents phi conn = do
+ forever $ waitForEvent conn >>= sendMessage phi . XEvent
-receiveEvents :: Phi -> Widget.Display -> IO ()
-receiveEvents phi dispvar = do
- connection <- Widget.withDisplay dispvar $ return . Fd . connectionNumber
-
- allocaXEvent $ \xevent -> forever $ do
- handled <- Widget.withDisplay dispvar $ \disp -> do
- pend <- pending disp
- if pend /= 0 then
- do
- liftIO $ nextEvent disp xevent
- event <- liftIO $ Util.getEvent disp xevent
- sendMessage phi event
-
- return True
- else return False
-
- --when (not handled) $ threadWaitRead connection
- when (not handled) $ threadDelay 40000
-
-updatePanels :: (Widget w s c) => Widget.Display -> PhiX w s c ()
-updatePanels dispvar = do
+updatePanels :: (Widget w s c) => Connection -> XCB.Connection -> PhiX w s c ()
+updatePanels conn xcb = do
w <- asks phiWidget
s <- gets phiWidgetState
rootImage <- gets phiRootImage
@@ -264,60 +272,56 @@ updatePanels dispvar = do
(panelSurfaces, cache') <- liftIO $ flip runStateT (panelWidgetCache panel) $
(withDimension area $ Widget.render w s 0 0) (panelScreenArea panel)
- Widget.withDisplay dispvar $ \disp -> do
- let screen = defaultScreen disp
- visual = defaultVisual disp screen
-
- xbuffer <- liftIO $ withDimension area $ Util.createXlibSurface disp pixmap visual
-
- liftIO $ (withDimension area $ withSimilarSurface xbuffer ContentColor) $ \buffer -> do
- renderWith buffer $ do
+ let screen = head . roots_Setup . connectionSetup $ conn
+ visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
+
+ xbuffer <- liftIO $ withDimension area $ XCB.createXCBSurface xcb (fromXid . toXid $ pixmap) visualtype
+
+ liftIO $ (withDimension area $ withSimilarSurface xbuffer ContentColor) $ \buffer -> do
+ renderWith buffer $ do
+ save
+ translate (-(fromIntegral $ x_RECTANGLE area)) (-(fromIntegral $ y_RECTANGLE area))
+ withPatternForSurface rootImage $ \pattern -> do
+ patternSetExtend pattern ExtendRepeat
+ setSource pattern
+ paint
+ restore
+
+ forM_ panelSurfaces $ \(updated, SurfaceSlice x surface) -> do
save
- translate (-(fromIntegral $ rect_x area)) (-(fromIntegral $ rect_y area))
- withPatternForSurface rootImage $ \pattern -> do
- patternSetExtend pattern ExtendRepeat
- setSource pattern
+ translate (fromIntegral x) 0
+ withPatternForSurface surface setSource
paint
restore
-
- forM_ panelSurfaces $ \(updated, SurfaceSlice x surface) -> do
- save
- translate (fromIntegral x) 0
- withPatternForSurface surface setSource
- paint
- restore
-
- renderWith xbuffer $ do
- withPatternForSurface buffer setSource
- paint
-
- surfaceFinish xbuffer
- -- update window
- liftIO $ do
- (withDimension area $ clearArea disp (panelWindow panel) 0 0) True
- sync disp False
+ renderWith xbuffer $ do
+ withPatternForSurface buffer setSource
+ paint
+
+ surfaceFinish xbuffer
+ -- update window
+ liftIO $ withDimension area $ XCB.clearArea xcb True (panelWindow panel) 0 0
+
return $ panel { panelWidgetCache = cache' }
modify $ \state -> state { phiPanels = panels' }
-updateRootImage :: Display -> PhiX w s c ()
-updateRootImage disp = do
+updateRootImage :: Connection -> XCB.Connection -> PhiX w s c ()
+updateRootImage conn xcb = do
atoms <- asks phiAtoms
- let screen = defaultScreen disp
- visual = defaultVisual disp screen
- rootwin = defaultRootWindow disp
- pixmap <- liftM (fromIntegral . fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $
- \atom -> liftIO $ getWindowProperty32 disp atom rootwin
+ let screen = head . roots_Setup . connectionSetup $ conn
+ visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
+ rootwin = root_SCREEN screen
- (pixmapWidth, pixmapHeight) <- case pixmap of
+ pixmap <- liftM (fromXid . toXid . fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $
+ \atom -> liftIO $ getProperty32 conn rootwin atom
+
+ (pixmapWidth, pixmapHeight) <- case (fromXid . toXid $ (pixmap :: PIXMAP) :: Word32) of
0 -> return (1, 1)
- _ -> do
- (_, _, _, pixmapWidth, pixmapHeight, _, _) <- liftIO $ getGeometry disp pixmap
- return (pixmapWidth, pixmapHeight)
+ _ -> liftIO $ getGeometry conn (fromXid . toXid $ pixmap) >>= getReply' "updateRootImage: getGeometry failed" >>= return . (width_GetGeometryReply &&& height_GetGeometryReply)
-- update surface size
oldBg <- gets phiRootImage
@@ -330,31 +334,33 @@ updateRootImage disp = do
bg <- gets phiRootImage
- case pixmap of
+ case (fromXid . toXid $ pixmap :: Word32) of
0 -> do
renderWith bg $ do
setSourceRGB 0 0 0
paint
_ -> do
- rootSurface <- liftIO $ Util.createXlibSurface disp pixmap visual (fromIntegral pixmapWidth) (fromIntegral pixmapHeight)
+ rootSurface <- liftIO $ XCB.createXCBSurface xcb (fromXid . toXid $ pixmap) visualtype (fromIntegral pixmapWidth) (fromIntegral pixmapHeight)
renderWith bg $ withPatternForSurface rootSurface $ \pattern -> do
setSource pattern
paint
surfaceFinish rootSurface
+ return ()
-createPanel :: (Widget w s c) => Display -> Window -> Rectangle -> PhiX w s c (PanelState w s c)
-createPanel disp win screenRect = do
+createPanel :: (Widget w s c) => Connection -> WINDOW -> RECTANGLE -> PhiX w s c (PanelState w s c)
+createPanel conn win screenRect = do
config <- asks phiPanelConfig
w <- asks phiWidget
let rect = panelBounds config screenRect
- screen = defaultScreen disp
- depth = defaultDepth disp screen
+ screen = head . roots_Setup . connectionSetup $ conn
+ depth = root_depth_SCREEN screen
- pixmap <- liftIO $ (withDimension rect $ createPixmap disp win) depth
- liftIO $ setWindowBackgroundPixmap disp win pixmap
+ pixmap <- liftIO $ newResource conn
+ liftIO $ createPixmap conn $ withDimension rect $ MkCreatePixmap depth pixmap (fromXid . toXid $ win)
+ liftIO $ changeWindowAttributes conn win $ toValueParam [(CWBackPixmap, fromXid . toXid $ pixmap)]
return PanelState { panelWindow = win
, panelPixmap = pixmap
@@ -363,96 +369,84 @@ createPanel disp win screenRect = do
, panelWidgetCache = initCache w
}
-createPanelWindow :: Display -> Panel.PanelConfig -> Rectangle -> IO Window
-createPanelWindow disp config screenRect = do
+createPanelWindow :: Connection -> Panel.PanelConfig -> RECTANGLE -> IO WINDOW
+createPanelWindow conn config screenRect = do
let rect = panelBounds config screenRect
- screen = defaultScreen disp
- depth = defaultDepth disp screen
- visual = defaultVisual disp screen
- colormap = defaultColormap disp screen
- rootwin = defaultRootWindow disp
- mask = cWEventMask.|.cWColormap.|.cWBackPixel.|.cWBorderPixel
-
- allocaSetWindowAttributes $ \attr -> do
- set_colormap attr colormap
- set_background_pixel attr 0
- set_border_pixel attr 0
- set_event_mask attr exposureMask
- withRectangle rect (createWindow disp rootwin) 0 depth inputOutput visual mask attr
-
-
-setPanelProperties :: Display -> PanelState w s c -> PhiX w s c ()
-setPanelProperties disp panel = do
+ screen = head . roots_Setup . connectionSetup $ conn
+ depth = root_depth_SCREEN screen
+ rootwin = root_SCREEN screen
+ visual = root_visual_SCREEN screen
+ win <- liftIO $ newResource conn
+ createWindow conn $ (withRectangle rect $ MkCreateWindow depth win rootwin) 0 WindowClassInputOutput visual $
+ toValueParam [(CWEventMask, toMask [EventMaskExposure]), (CWBackPixel, 0), (CWBorderPixel, 0)]
+ return win
+
+
+setPanelProperties :: Connection -> PanelState w s c -> PhiX w s c ()
+setPanelProperties conn panel = do
atoms <- asks phiAtoms
liftIO $ do
- storeName disp (panelWindow panel) "Phi"
- changeProperty8 disp (panelWindow panel) (atom_NET_WM_NAME atoms) (atomUTF8_STRING atoms) propModeReplace $ map (fromIntegral . ord) "Phi"
+ let name = map (fromIntegral . ord) "Phi"
+ changeProperty8 conn PropModeReplace (panelWindow panel) (atomWM_NAME atoms) (atomSTRING atoms) name
+ changeProperty8 conn PropModeReplace (panelWindow panel) (atom_NET_WM_NAME atoms) (atomUTF8_STRING atoms) name
- changeProperty32 disp (panelWindow panel) (atom_NET_WM_WINDOW_TYPE atoms) aTOM propModeReplace [fromIntegral (atom_NET_WM_WINDOW_TYPE_DOCK atoms)]
- changeProperty32 disp (panelWindow panel) (atom_NET_WM_DESKTOP atoms) cARDINAL propModeReplace [0xFFFFFFFF]
- changeProperty32 disp (panelWindow panel) (atom_NET_WM_STATE atoms) aTOM propModeReplace [ fromIntegral (atom_NET_WM_STATE_SKIP_PAGER atoms)
- , fromIntegral (atom_NET_WM_STATE_SKIP_TASKBAR atoms)
- , fromIntegral (atom_NET_WM_STATE_STICKY atoms)
- , fromIntegral (atom_NET_WM_STATE_BELOW atoms)
- ]
- setWMHints disp (panelWindow panel) WMHints { wmh_flags = fromIntegral inputHintBit
- , wmh_input = False
- , wmh_initial_state = 0
- , wmh_icon_pixmap = 0
- , wmh_icon_window = 0
- , wmh_icon_x = 0
- , wmh_icon_y = 0
- , wmh_icon_mask = 0
- , wmh_window_group = 0
- }
- changeProperty32 disp (panelWindow panel) (atom_MOTIF_WM_HINTS atoms) (atom_MOTIF_WM_HINTS atoms) propModeReplace [ 2, 0, 0, 0, 0 ]
+ changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_WINDOW_TYPE atoms) (atomATOM atoms) [fromXid . toXid $ atom_NET_WM_WINDOW_TYPE_DOCK atoms]
+ changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_DESKTOP atoms) (atomCARDINAL atoms) [0xFFFFFFFF]
+ changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_STATE atoms) (atomATOM atoms) $
+ map (fromXid . toXid) [ atom_NET_WM_STATE_SKIP_PAGER atoms
+ , atom_NET_WM_STATE_SKIP_TASKBAR atoms
+ , atom_NET_WM_STATE_STICKY atoms
+ , atom_NET_WM_STATE_BELOW atoms
+ ]
- Util.setClassHint disp (panelWindow panel) ClassHint { resName = "phi", resClass = "Phi" }
+ changeProperty32 conn PropModeReplace (panelWindow panel) (atom_MOTIF_WM_HINTS atoms) (atom_MOTIF_WM_HINTS atoms) [ 2, 0, 0, 0, 0 ]
- setStruts disp panel
+ changeProperty8 conn PropModeReplace (panelWindow panel) (atomWM_CLASS atoms) (atomSTRING atoms) $ map (fromIntegral . ord) "phi\0Phi"
+
+ setStruts conn panel
-setStruts :: Display -> PanelState w s c -> PhiX w s c ()
-setStruts disp panel = do
+setStruts :: Connection -> PanelState w s c -> PhiX w s c ()
+setStruts conn panel = do
atoms <- asks phiAtoms
config <- asks phiPanelConfig
- let rootwin = defaultRootWindow disp
+ let rootwin = getRoot conn
position = Panel.panelPosition config
area = panelArea panel
- (_, _, _, _, rootHeight, _, _) <- liftIO $ getGeometry disp rootwin
+ rootHeight <- liftIO $ getGeometry conn (fromXid . toXid $ rootwin) >>= getReply' "setStruts: getGeometry failed" >>= return . height_GetGeometryReply
let struts = [makeStruts i | i <- [0..11]]
- where
- makeTopStruts 2 = (fromIntegral $ rect_y area) + (fromIntegral $ rect_height area)
- makeTopStruts 8 = (fromIntegral $ rect_x area)
- makeTopStruts 9 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1
- makeTopStruts _ = 0
-
- makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ rect_y area)
- makeBottomStruts 10 = (fromIntegral $ rect_x area)
- makeBottomStruts 11 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1
- makeBottomStruts _ = 0
-
- makeStruts = case position of
- Phi.Top -> makeTopStruts
- Phi.Bottom -> makeBottomStruts
+ where
+ makeTopStruts 2 = (fromIntegral $ y_RECTANGLE area) + (fromIntegral $ height_RECTANGLE area)
+ makeTopStruts 8 = (fromIntegral $ x_RECTANGLE area)
+ makeTopStruts 9 = (fromIntegral $ x_RECTANGLE area) + (fromIntegral $ width_RECTANGLE area) - 1
+ makeTopStruts _ = 0
+
+ makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ y_RECTANGLE area)
+ makeBottomStruts 10 = (fromIntegral $ x_RECTANGLE area)
+ makeBottomStruts 11 = (fromIntegral $ x_RECTANGLE area) + (fromIntegral $ width_RECTANGLE area) - 1
+ makeBottomStruts _ = 0
+
+ makeStruts = case position of
+ Phi.Top -> makeTopStruts
+ Phi.Bottom -> makeBottomStruts
liftIO $ do
- changeProperty32 disp (panelWindow panel) (atom_NET_WM_STRUT atoms) cARDINAL propModeReplace $ take 4 struts
- changeProperty32 disp (panelWindow panel) (atom_NET_WM_STRUT_PARTIAL atoms) cARDINAL propModeReplace struts
+ changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_STRUT atoms) (atomCARDINAL atoms) $ take 4 struts
+ changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_STRUT_PARTIAL atoms) (atomCARDINAL atoms) struts
-panelBounds :: Panel.PanelConfig -> Rectangle -> Rectangle
+panelBounds :: Panel.PanelConfig -> RECTANGLE -> RECTANGLE
panelBounds config screenBounds = case Panel.panelPosition config of
- Phi.Top -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config }
- Phi.Bottom -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config,
- rect_y = (rect_y screenBounds) + (fromIntegral $ rect_height screenBounds) - (fromIntegral $ Panel.panelSize config) }
+ Phi.Top -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config }
+ Phi.Bottom -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config,
+ y_RECTANGLE = (y_RECTANGLE screenBounds) + (fromIntegral $ height_RECTANGLE screenBounds) - (fromIntegral $ Panel.panelSize config) }
-withRectangle :: (Num x, Num y, Num w, Num h) => Rectangle -> (x -> y -> w -> h -> a) -> a
+withRectangle :: (Num x, Num y, Num w, Num h) => RECTANGLE -> (x -> y -> w -> h -> a) -> a
withRectangle r = withDimension r . withPosition r
-withPosition :: (Num x, Num y) => Rectangle -> (x -> y -> a) -> a
-withPosition r f = f (fromIntegral $ rect_x r) (fromIntegral $ rect_y r)
+withPosition :: (Num x, Num y) => RECTANGLE -> (x -> y -> a) -> a
+withPosition r f = f (fromIntegral $ x_RECTANGLE r) (fromIntegral $ y_RECTANGLE r)
-withDimension :: (Num w, Num h) => Rectangle -> (w -> h -> a) -> a
-withDimension r f = f (fromIntegral $ rect_width r) (fromIntegral $ rect_height r)
+withDimension :: (Num w, Num h) => RECTANGLE -> (w -> h -> a) -> a
+withDimension r f = f (fromIntegral $ width_RECTANGLE r) (fromIntegral $ height_RECTANGLE r)
diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs
index dbd6fc5..d05bad2 100644
--- a/lib/Phi/X11/AtomList.hs
+++ b/lib/Phi/X11/AtomList.hs
@@ -6,10 +6,16 @@ module Phi.X11.AtomList ( atoms
import Language.Haskell.TH
-import Graphics.X11.Xlib
+import Graphics.XHB
+import Graphics.XHB.Connection.Open
atoms :: [String]
-atoms = [ "UTF8_STRING"
+atoms = [ "ATOM"
+ , "CARDINAL"
+ , "STRING"
+ , "UTF8_STRING"
+ , "WM_NAME"
+ , "WM_CLASS"
, "MANAGER"
, "_NET_WM_NAME"
, "_NET_WM_WINDOW_TYPE"
@@ -43,7 +49,7 @@ atoms = [ "UTF8_STRING"
, "_XROOTMAP_ID"
]
--- the expression must have the type (Display -> String)
+-- the expression must have the type (Connection -> String)
specialAtoms :: [(String, Q Exp)]
-specialAtoms = [ ("_NET_SYSTEM_TRAY_SCREEN", [|("_NET_SYSTEM_TRAY_S" ++) . show . defaultScreen|])
+specialAtoms = [ ("_NET_SYSTEM_TRAY_SCREEN", [|("_NET_SYSTEM_TRAY_S" ++) . show . screen . displayInfo|])
] \ No newline at end of file
diff --git a/lib/Phi/X11/Atoms.hs b/lib/Phi/X11/Atoms.hs
index acbae64..0a8f66a 100644
--- a/lib/Phi/X11/Atoms.hs
+++ b/lib/Phi/X11/Atoms.hs
@@ -5,36 +5,48 @@ module Phi.X11.Atoms ( Atoms(..)
) where
import Control.Monad
+import Data.Char
+import Data.List
+
import Language.Haskell.TH
-import Graphics.X11
+import Graphics.XHB
+import Graphics.XHB.Gen.Xproto
import Phi.X11.AtomList
$(let atomsName = mkName "Atoms"
atomNames = map (\atom -> (atom, mkName ("atom" ++ atom))) $ atoms ++ (map fst specialAtoms)
- fields = map (\(_, name) -> (name, IsStrict, ConT ''Atom)) atomNames
+ fields = map (\(_, name) -> (name, IsStrict, ConT ''ATOM)) atomNames
in return [DataD [] atomsName [] [RecC atomsName fields] []]
)
-initAtoms :: Display -> IO Atoms
-initAtoms display =
+initAtoms :: Connection -> IO Atoms
+initAtoms conn =
$(do
normalAtomNames <- mapM (\atom -> do
+ receiptName <- newName ('_':atom)
varName <- newName ('_':atom)
- return ([|const atom|], mkName ("atom" ++ atom), varName)
+ return ([|const atom|], mkName ("atom" ++ atom), receiptName, varName)
) atoms
specialAtomNames <- mapM (\(name, atomgen) -> do
+ receiptName <- newName ('_':name)
varName <- newName ('_':name)
- return (atomgen, mkName ("atom" ++ name), varName)
+ return (atomgen, mkName ("atom" ++ name), receiptName, varName)
) specialAtoms
let atomNames = normalAtomNames ++ specialAtomNames
+ atomReceipts <- forM atomNames $
+ \(atomgen, _, receiptName, _) -> liftM (BindS (VarP receiptName))
+ [|let name = ($atomgen conn)
+ in internAtom conn $ MkInternAtom False (genericLength name) $ map (fromIntegral . ord) name|]
atomInitializers <- forM atomNames $
- \(atomgen, _, varName) -> liftM (BindS (VarP varName)) [| internAtom display ($atomgen display) False |]
-
- let atomFieldExps = map (\(_, atomName, varName) -> (atomName, VarE varName)) atomNames
+ \(_, _, receiptName, varName) -> liftM (BindS (VarP varName))
+ [|liftM (\(Right a) -> a) $ getReply $(return $ VarE receiptName)|]
+
+
+ let atomFieldExps = map (\(_, atomName, _, varName) -> (atomName, VarE varName)) atomNames
atomsName = mkName "Atoms"
atomsContruction = NoBindS $ AppE (VarE 'return) $ RecConE atomsName atomFieldExps
- return $ DoE $ atomInitializers ++ [atomsContruction]
+ return $ DoE $ atomReceipts ++ atomInitializers ++ [atomsContruction]
)
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