Converted core to XHB/XCB

csrc/SystrayErrorHandler.c

@@ -1,27 +0,0 @@
-#include <SystrayErrorHandler.h>
-
-
-static Window lastErrorWindow = 0;
-
-
-static int systrayErrorHandler (Display *display, XErrorEvent *event)
-{
-	if (event->error_code == BadWindow) {
-		lastErrorWindow = event->resourceid;
-	}
-
-	return 0;
-}
-
-void setSystrayErrorHandler (void)
-{
-	lastErrorWindow = 0;
-	XSetErrorHandler(systrayErrorHandler);
-}
-
-Window getLastErrorWindow (void)
-{
-	Window ret = lastErrorWindow;
-	lastErrorWindow = 0;
-	return ret;
-}

lib/Phi/Bindings/SystrayErrorHandler.hsc

@@ -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

lib/Phi/Bindings/Util.hsc

@@ -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
-

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

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
+newtype XEvent = XEvent SomeEvent deriving Typeable
-withDisplay (Display dispvar _) f = do
+
-  disp <- liftIO $ takeMVar dispvar
+instance Show XEvent where
-  a <- f disp
+  show _ = "XEvent (..)"
-  liftIO $ putMVar dispvar disp
+
-  return a
+
+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
+    MkRECTANGLE ax1 ay1 aw ah = a
-    Xlib.Rectangle bx1 by1 bw bh = b
+    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 ())
+createRenderCache :: (s -> Int -> Int -> Int -> Int -> RECTANGLE -> Render ())
-                     -> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, Xlib.Rectangle) Surface
+                     -> 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)

lib/Phi/X11.hs

@@ -5,16 +5,19 @@ module Phi.X11 ( XConfig(..)
                , runPhi
                ) where
 
-import Graphics.X11.Xlib
+import Graphics.XHB
-import Graphics.X11.Xlib.Extras
+import Graphics.XHB.Gen.Xinerama
-import Graphics.X11.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
+data PanelState w s c = (Widget.Widget w s c) => PanelState { panelWindow       :: !WINDOW
-                                                            , panelPixmap       :: !Pixmap
+                                                            , panelPixmap       :: !PIXMAP
-                                                            , panelArea         :: !Rectangle
+                                                            , panelArea         :: !RECTANGLE
-                                                            , panelScreenArea   :: !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
+  atoms <- initAtoms conn
-  selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask
+  changeWindowAttributes conn (getRoot conn) $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])]
   
   bg <- createImageSurface FormatRGB24 1 1
   
-  dispmvar <- newMVar disp
+  screens <- liftIO $ phiXScreenInfo xconfig conn
-  screens <- liftIO $ phiXScreenInfo xconfig disp
+  panelWindows <- mapM (createPanelWindow conn config) screens
-  panelWindows <- mapM (createPanelWindow disp config) screens
+  let dispvar = Widget.Display conn atoms
-  let dispvar = Widget.Display dispmvar 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 :: (Widget w s c) => Connection -> XCB.Connection -> Message -> PhiX w s c ()
-handleMessage dispvar m = do
+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 ->
+        Just (XEvent event) ->
-          Widget.withDisplay dispvar $ flip handleEvent event
+          handleEvent conn xcb event
         _ ->
           return ()
 
-handleEvent :: (Widget w s c) => Display -> Event -> PhiX w s c ()
+handleEvent :: (Widget w s c) => Connection -> XCB.Connection -> SomeEvent -> PhiX w s c ()
-handleEvent disp PropertyEvent { ev_atom = atom } = do
+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_ (freePixmap conn . panelPixmap) panels
-      mapM_ (destroyWindow disp . panelWindow) $ drop (length screens') 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
+          panel' <- createPanel conn win screen
-          setPanelProperties disp panel'
+          setPanelProperties conn panel'
           
           return panel'
         Nothing -> do
-          win <- liftIO $ createPanelWindow disp config screen
+          win <- liftIO $ createPanelWindow conn config screen
-          panel <- createPanel disp win screen
+          panel <- createPanel conn win screen
-          setPanelProperties disp panel
+          setPanelProperties conn panel
-          liftIO $ mapWindow disp $ panelWindow 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 ()
+updatePanels :: (Widget w s c) => Connection -> XCB.Connection -> PhiX w s c ()
-receiveEvents phi dispvar = do
+updatePanels conn xcb = 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
   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 = head . roots_Setup . connectionSetup $ conn
-      let screen = defaultScreen disp
+        visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
-          visual = defaultVisual disp screen
+    
-      
+    xbuffer <- liftIO $ withDimension area $ XCB.createXCBSurface xcb (fromXid . toXid $ pixmap) visualtype
-      xbuffer <- liftIO $ withDimension area $ Util.createXlibSurface disp pixmap visual
+    
-      
+    liftIO $ (withDimension area $ withSimilarSurface xbuffer ContentColor) $ \buffer -> do
-      liftIO $ (withDimension area $ withSimilarSurface xbuffer ContentColor) $ \buffer -> do
+      renderWith 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))
+          translate (fromIntegral x) 0
-          withPatternForSurface rootImage $ \pattern -> do
+          withPatternForSurface surface setSource
-            patternSetExtend pattern ExtendRepeat
-            setSource pattern
           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
+      renderWith xbuffer $ do
-      
+        withPatternForSurface buffer setSource
-      -- update window
+        paint
-      liftIO $ do
-        (withDimension area $ clearArea disp (panelWindow panel) 0 0) True
-        sync disp False
     
+    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 :: Connection -> XCB.Connection -> PhiX w s c ()
-updateRootImage disp = do
+updateRootImage conn xcb = do
   atoms <- asks phiAtoms
   
-  let screen = defaultScreen disp
+  let screen = head . roots_Setup . connectionSetup $ conn
-      visual = defaultVisual disp screen
+      visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
-      rootwin = defaultRootWindow disp
+      rootwin = root_SCREEN screen
-  pixmap <- liftM (fromIntegral . fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $
-            \atom -> liftIO $ getWindowProperty32 disp atom rootwin
   
-  (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
+    _ -> liftIO $ getGeometry conn (fromXid . toXid $ pixmap) >>= getReply' "updateRootImage: getGeometry failed" >>= return . (width_GetGeometryReply &&& height_GetGeometryReply)
-      (_, _, _, pixmapWidth, pixmapHeight, _, _) <- liftIO $ getGeometry disp pixmap
-      return (pixmapWidth, pixmapHeight)
   
   -- 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 :: (Widget w s c) => Connection -> WINDOW -> RECTANGLE -> PhiX w s c (PanelState w s c)
-createPanel disp win screenRect = do
+createPanel conn win screenRect = do
   config <- asks phiPanelConfig
   w <- asks phiWidget
   let rect = panelBounds config screenRect
-      screen = defaultScreen disp
+      screen = head . roots_Setup . connectionSetup $ conn
-      depth = defaultDepth disp screen
+      depth = root_depth_SCREEN screen
     
-  pixmap <- liftIO $ (withDimension rect $ createPixmap disp win) depth
+  pixmap <- liftIO $ newResource conn
-  liftIO $ setWindowBackgroundPixmap disp win pixmap
+  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 :: Connection -> Panel.PanelConfig -> RECTANGLE -> IO WINDOW
-createPanelWindow disp config screenRect = do
+createPanelWindow conn config screenRect = do
   let rect = panelBounds config screenRect
-      screen = defaultScreen disp
+      screen = head . roots_Setup . connectionSetup $ conn
-      depth = defaultDepth disp screen
+      depth = root_depth_SCREEN screen
-      visual = defaultVisual disp screen
+      rootwin = root_SCREEN screen
-      colormap = defaultColormap disp screen
+      visual = root_visual_SCREEN screen
-      rootwin = defaultRootWindow disp
+  win <- liftIO $ newResource conn
-      mask = cWEventMask.|.cWColormap.|.cWBackPixel.|.cWBorderPixel
+  createWindow conn $ (withRectangle rect $ MkCreateWindow depth win rootwin) 0 WindowClassInputOutput visual $
-
+    toValueParam [(CWEventMask, toMask [EventMaskExposure]), (CWBackPixel, 0), (CWBorderPixel, 0)]
-  allocaSetWindowAttributes $ \attr -> do
+  return win
-    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 :: Connection -> PanelState w s c -> PhiX w s c ()
-setPanelProperties disp panel = do
+setPanelProperties conn panel = do
   atoms <- asks phiAtoms
   liftIO $ do
-    storeName disp (panelWindow panel) "Phi"
+    let name = map (fromIntegral . ord) "Phi"
-    changeProperty8 disp (panelWindow panel) (atom_NET_WM_NAME atoms) (atomUTF8_STRING atoms) propModeReplace $ 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 conn PropModeReplace (panelWindow panel) (atom_NET_WM_WINDOW_TYPE atoms) (atomATOM atoms) [fromXid . toXid $ atom_NET_WM_WINDOW_TYPE_DOCK atoms]
-    changeProperty32 disp (panelWindow panel) (atom_NET_WM_DESKTOP atoms) cARDINAL propModeReplace [0xFFFFFFFF]
+    changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_DESKTOP atoms) (atomCARDINAL atoms) [0xFFFFFFFF]
-    changeProperty32 disp (panelWindow panel) (atom_NET_WM_STATE atoms) aTOM propModeReplace [ fromIntegral (atom_NET_WM_STATE_SKIP_PAGER atoms)
+    changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_STATE atoms) (atomATOM atoms) $
-                                                                                             , fromIntegral (atom_NET_WM_STATE_SKIP_TASKBAR atoms)
+      map (fromXid . toXid) [ atom_NET_WM_STATE_SKIP_PAGER atoms
-                                                                                             , fromIntegral (atom_NET_WM_STATE_STICKY atoms)
+                            , atom_NET_WM_STATE_SKIP_TASKBAR atoms
-                                                                                             , fromIntegral (atom_NET_WM_STATE_BELOW atoms)
+                            , atom_NET_WM_STATE_STICKY atoms
-                                                                                             ]
+                            , 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 ]
     
-    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 :: Connection -> PanelState w s c -> PhiX w s c ()
-setStruts disp panel = do
+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
+        where
-            makeTopStruts 2 = (fromIntegral $ rect_y area) + (fromIntegral $ rect_height area)
+          makeTopStruts 2 = (fromIntegral $ y_RECTANGLE area) + (fromIntegral $ height_RECTANGLE area)
-            makeTopStruts 8 = (fromIntegral $ rect_x area)
+          makeTopStruts 8 = (fromIntegral $ x_RECTANGLE area)
-            makeTopStruts 9 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1
+          makeTopStruts 9 = (fromIntegral $ x_RECTANGLE area) + (fromIntegral $ width_RECTANGLE area) - 1
-            makeTopStruts _ = 0
+          makeTopStruts _ = 0
-            
+          
-            makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ rect_y area)
+          makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ y_RECTANGLE area)
-            makeBottomStruts 10 = (fromIntegral $ rect_x area)
+          makeBottomStruts 10 = (fromIntegral $ x_RECTANGLE area)
-            makeBottomStruts 11 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1
+          makeBottomStruts 11 = (fromIntegral $ x_RECTANGLE area) + (fromIntegral $ width_RECTANGLE area) - 1
-            makeBottomStruts _ = 0
+          makeBottomStruts _ = 0
-            
+          
-            makeStruts = case position of
+          makeStruts = case position of
-              Phi.Top -> makeTopStruts
+            Phi.Top -> makeTopStruts
-              Phi.Bottom -> makeBottomStruts
+            Phi.Bottom -> makeBottomStruts
   
   liftIO $ do
-    changeProperty32 disp (panelWindow panel) (atom_NET_WM_STRUT atoms) cARDINAL propModeReplace $ take 4 struts
+    changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_STRUT atoms) (atomCARDINAL atoms) $ 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_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.Top -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config }
-  Phi.Bottom -> screenBounds { rect_height = fromIntegral $ Panel.panelSize config,
+  Phi.Bottom -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config,
-                                        rect_y = (rect_y screenBounds) + (fromIntegral $ rect_height screenBounds) - (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 :: (Num x, Num y) => RECTANGLE -> (x -> y -> a) -> a
-withPosition r f = f (fromIntegral $ rect_x r) (fromIntegral $ rect_y r)
+withPosition r f = f (fromIntegral $ x_RECTANGLE r) (fromIntegral $ y_RECTANGLE r)
 
-withDimension :: (Num w, Num h) => Rectangle -> (w -> h -> a) -> a
+withDimension :: (Num w, Num h) => RECTANGLE -> (w -> h -> a) -> a
-withDimension r f = f (fromIntegral $ rect_width r) (fromIntegral $ rect_height r)
+withDimension r f = f (fromIntegral $ width_RECTANGLE r) (fromIntegral $ height_RECTANGLE r)

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|])
                ]

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 :: Connection -> IO Atoms
-initAtoms display =
+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 |]
+                           \(_, _, receiptName, varName) -> liftM (BindS (VarP varName))
-           
+                                                            [|liftM (\(Right a) -> a) $ getReply $(return $ VarE receiptName)|]
-       let atomFieldExps = map (\(_, atomName, varName) -> (atomName, VarE varName)) atomNames
+       
+       
+       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]
    )

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

phi.cabal

@@ -11,15 +11,16 @@ maintainer:          mschiffer@universe-factory.net
 build-type:          Simple
 
 library
-  build-depends:     base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, X11, cairo, pango, unix, data-accessor, arrows, CacheArrow
+  build-depends:     base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, xhb,
-  exposed-modules:   Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11,
+                     cairo, pango, unix, data-accessor, arrows, CacheArrow
-                     Phi.Widgets.AlphaBox, Phi.Widgets.Clock, Phi.Widgets.Taskbar, Phi.Widgets.Systray
+  exposed-modules:   Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11
-  other-modules:     Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util, Phi.Bindings.SystrayErrorHandler
+                     Phi.Widgets.AlphaBox, Phi.Widgets.Clock
-  c-sources:         csrc/SystrayErrorHandler.c
+		     -- , Phi.Widgets.Taskbar, Phi.Widgets.Systray
+  other-modules:     Phi.X11.Util, Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.XCB
   include-dirs:      include
   hs-source-dirs:    lib
   extra-libraries:   X11
-  pkgconfig-depends: cairo >= 1.2.0, cairo-xlib
+  pkgconfig-depends: xcb, cairo >= 1.2.0, cairo-xcb
   ghc-options:       -fspec-constr-count=16 -threaded
 
 executable Phi

src/Phi.hs

@@ -6,13 +6,13 @@ import Phi.X11
 
 import Phi.Widgets.AlphaBox
 import Phi.Widgets.Clock
-import Phi.Widgets.Taskbar
+--import Phi.Widgets.Taskbar
-import Phi.Widgets.Systray
+--import Phi.Widgets.Systray
 
 
 main :: IO ()
 main = do
-  runPhi defaultXConfig defaultPanelConfig { panelPosition = Top } $ alphaBox 0.9 $ theTaskbar <~> brightBorder theSystray <~> brightBorder theClock
+  runPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom } $ alphaBox 0.9 $ {- theTaskbar <~> brightBorder theSystray <~> -} brightBorder theClock
     where
       normalTaskBorder = BorderConfig (BorderWidth (-1) (-3) (-1) 7) 1 (BorderWidth 0 5 0 5) (0.9, 0.9, 0.9, 0.8) (0.45, 0.45, 0.45, 0.8) 5 0
       activeTaskBorder = normalTaskBorder { borderColor = (1, 1, 1, 0.8)
@@ -25,7 +25,7 @@ main = do
                                              }
       currentDesktopBorder = normalDesktopBorder { backgroundColor = (0.2, 0.2, 0.2, 0.9)
                                                  }
-      taskStyle = TaskStyle { taskFont = "Sans 7"
+      {-taskStyle = TaskStyle { taskFont = "Sans 7"
                             , taskColor = (1, 1, 1, 1)
                             , taskBorder = normalTaskBorder
                             , taskIconStyle = idIconStyle
@@ -46,7 +46,7 @@ main = do
                                                 , desktopStyle = Just (normalDesktopStyle, currentDesktopStyle)
                                                 }
       
-      theSystray = systray
+      theSystray = systray-}
       
       theClock = clock defaultClockConfig { clockFormat = "<span font='Sans 8'>%R</span>\n<span font='Sans 6'>%A %d %B</span>"
                                           , lineSpacing = (-3)