lib/Phi/Bindings/Cairo.hsc

@@ -1,51 +0,0 @@
-{-# LANGUAGE ForeignFunctionInterface #-}
-
-module Phi.Bindings.Cairo ( createXCBSurface
-                          ) where
-
-import Control.Monad
-
-import Data.Int
-import Data.Word
-
-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.Connection.XCB
-import Graphics.XHB.Gen.Xproto (DRAWABLE, VISUALTYPE(..))
-
-
-#include <cairo-xcb.h>
-
-
-foreign import ccall "cairo-xlib.h cairo_xcb_surface_create"
-  cairo_xcb_surface_create :: Ptr XCBConnection -> 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 conn drawable visual width height =
-  with visual $ \visualptr -> withConnection conn $ \connptr -> do
-    surfacePtr <- cairo_xcb_surface_create connptr drawable visualptr 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/Border.hs

@@ -56,11 +56,11 @@ defaultBorderConfig = BorderConfig { margin = simpleBorderWidth 0
                                    , borderWeight = 1
                                    }
 
-data Border w s c d = (Widget w s c d) => Border !BorderConfig !w
+data Border w s c = (Widget w s c) => Border !BorderConfig !w
 
-data BorderCache w s c d = (Widget w s c d) => BorderCache !c
+data BorderCache w s c = (Widget w s c) => BorderCache !c
 
-instance (Eq s, Display d) => Widget (Border w s c d) s (BorderCache w s c d) d where
+instance Eq s => Widget (Border w s c) s (BorderCache w s c) where
   initWidget (Border _ w) = initWidget w
   initCache (Border _ w) = BorderCache $ initCache w
   
@@ -165,5 +165,5 @@ roundRectangle x y width height radius = do
   arc (x + radius) (y + radius) radius  pi (pi*3/2)
   closePath
 
-border :: (Widget w s c d) => BorderConfig -> w -> Border w s c d
+border :: (Widget w s c) => BorderConfig -> w -> Border w s c
 border = Border

lib/Phi/Phi.hs

@@ -7,7 +7,6 @@ module Phi.Phi ( Phi
                , initPhi
                , dupPhi
                , sendMessage
-               , sendMessages
                , receiveMessage
                , messageAvailable
                ) where
@@ -37,9 +36,6 @@ dupPhi (Phi chan) = liftM Phi $ liftIO $ atomically $ dupTChan chan
 sendMessage :: (MonadIO m, Typeable a, Show a) => Phi -> a -> m ()
 sendMessage (Phi chan) = liftIO . atomically . writeTChan chan . Message
 
-sendMessages :: (MonadIO m, Typeable a, Show a) => Phi -> [a] -> m ()
-sendMessages (Phi chan) = liftIO . atomically . mapM_ (writeTChan chan . Message)
-
 receiveMessage :: MonadIO m => Phi -> m Message
 receiveMessage (Phi chan) = liftIO $ atomically $ readTChan chan
 

lib/Phi/Widget.hs

@@ -1,7 +1,10 @@
-{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}
+{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, DeriveDataTypeable, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-}
 
-module Phi.Widget ( Rectangle(..)
+module Phi.Widget ( XEvent(..)
                   , Display(..)
+                  , withDisplay
+                  , getAtoms
+                  , XMessage(..)
                   , unionArea
                   , SurfaceSlice(..)
                   , Widget(..)
@@ -20,6 +23,7 @@ module Phi.Widget ( Rectangle(..)
 import Control.Arrow
 import Control.Arrow.Transformer
 import Control.CacheArrow
+import Control.Concurrent.MVar
 import Control.Monad
 import Control.Monad.State.Strict hiding (lift)
 import Control.Monad.IO.Class
@@ -27,57 +31,67 @@ import Control.Monad.IO.Class
 import Data.Maybe
 import Data.Typeable
 
+import Graphics.XHB
 import Graphics.Rendering.Cairo
 
 import Phi.Phi
 import Phi.X11.Atoms
 
 
-data Rectangle = Rectangle { rect_x :: !Int
+data Display = Display !Connection !Atoms
-                           , rect_y :: !Int
-                           , rect_width :: !Int
-                           , rect_height :: !Int
-                           } deriving (Show, Eq)
 
-class Display d where
+newtype XEvent = XEvent SomeEvent deriving Typeable
-  type Window d :: *
+
+instance Show XEvent where
+  show _ = "XEvent (..)"
 
 
-unionArea :: Rectangle -> Rectangle -> Int
+withDisplay :: MonadIO m => Display -> (Connection -> m a) -> m a
-unionArea a b = uw*uh
+withDisplay (Display conn _) f = f conn
+
+getAtoms :: Display -> Atoms
+getAtoms (Display _ atoms) = atoms
+
+data XMessage = UpdateScreens [(RECTANGLE, WINDOW)] deriving (Show, Typeable)
+
+
+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)
     
-    Rectangle ax1 ay1 aw ah = a
+    MkRECTANGLE ax1 ay1 aw ah = a
-    Rectangle bx1 by1 bw bh = b
+    MkRECTANGLE bx1 by1 bw bh = b
     
-    ax2 = ax1 + aw
+    ax2 = ax1 + fromIntegral aw
-    ay2 = ay1 + ah
+    ay2 = ay1 + fromIntegral ah
     
-    bx2 = bx1 + bw
+    bx2 = bx1 + fromIntegral bw
-    by2 = by1 + bh
+    by2 = by1 + fromIntegral bh
 
 
 data SurfaceSlice = SurfaceSlice !Int !Surface
 
-class (Eq s, Display d) => Widget w s c d | w -> s, w -> c, w -> d where
+class Eq s => Widget w s c | w -> s, w -> c where
-  initWidget :: w -> Phi -> d -> [(Rectangle, Window d)] -> IO s
+  initWidget :: w -> Phi -> Display -> [(RECTANGLE, WINDOW)] -> IO s
   
   initCache :: w -> c
   
-  minSize :: w -> s -> Int -> Rectangle -> Int
+  minSize :: w -> s -> Int -> RECTANGLE -> Int
   
   weight :: w -> Float
   weight _ = 0
 
-  render :: w -> s -> Int -> Int -> Int -> Int -> 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, 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
@@ -89,8 +103,8 @@ runIOCache a = do
   put cache'
   return b
 
-createRenderCache :: (s -> Int -> Int -> Int -> Int -> Rectangle -> Render ())
+createRenderCache :: (s -> Int -> Int -> Int -> Int -> RECTANGLE -> Render ())
-                     -> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, 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
@@ -100,22 +114,22 @@ 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 -> 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)
   put cache'
   return [(updated, SurfaceSlice 0 surf)]
 
-data CompoundWidget a sa ca b sb cb d = (Widget a sa ca d, Widget b sb cb d) => CompoundWidget !a !b
+data CompoundWidget a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundWidget !a !b
 
-data CompoundState a sa ca b sb cb d = (Widget a sa ca d, Widget b sb cb d) => CompoundState !sa !sb
+data CompoundState a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundState !sa !sb
-deriving instance Eq (CompoundState a sa ca b sb cb d)
+deriving instance Eq (CompoundState a sa ca b sb cb)
 
-data CompoundCache a sa ca b sb cb d = (Widget a sa ca d, Widget b sb cb d) => CompoundCache !ca !cb
+data CompoundCache a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundCache !ca !cb
 
 
-instance Display d => Widget (CompoundWidget a sa ca b sb cb d) (CompoundState a sa ca b sb cb d) (CompoundCache a sa ca b sb cb d) d where
+instance Widget (CompoundWidget a sa ca b sb cb) (CompoundState a sa ca b sb cb) (CompoundCache a sa ca b sb cb) where
   initWidget (CompoundWidget a b) phi disp screens = liftM2 CompoundState (initWidget a phi disp screens) (initWidget b phi disp screens)
   
   initCache (CompoundWidget a b) = CompoundCache (initCache a) (initCache b)
@@ -140,15 +154,15 @@ instance Display d => Widget (CompoundWidget a sa ca b sb cb d) (CompoundState a
     
   handleMessage (CompoundWidget a b) (CompoundState sa sb) message = CompoundState (handleMessage a sa message) (handleMessage b sb message)
 
-weight' :: (Widget a sa ca d) => a -> Float
+weight' :: (Widget a sa ca) => a -> Float
 weight' = max 0 . weight
 
-(<~>) :: (Widget a sa ca d, Widget b sb cb d) => a -> b -> CompoundWidget a sa ca b sb cb d
+(<~>) :: (Widget a sa ca, Widget b sb cb) => a -> b -> CompoundWidget a sa ca b sb cb
 a <~> b = CompoundWidget a b
 
-data Separator d = Separator !Int !Float deriving (Show, Eq)
+data Separator = Separator !Int !Float deriving (Show, Eq)
 
-instance Display d => Widget (Separator d) () (RenderCache ()) d where
+instance Widget Separator () (RenderCache ()) where
   initWidget _ _ _ _ = return ()
   initCache _ = createRenderCache $ \_ _ _ _ _ _ -> do
     setOperator OperatorClear
@@ -159,5 +173,5 @@ instance Display d => Widget (Separator d) () (RenderCache ()) d where
   render _ = renderCached
 
 
-separator :: Int -> Float -> Separator d
+separator :: Int -> Float -> Separator
 separator = Separator

lib/Phi/Widgets/AlphaBox.hs

@@ -13,11 +13,11 @@ import Control.Monad.State.Strict
 import Graphics.Rendering.Cairo
 
 
-data AlphaBox w s c d = (Widget w s c d) => AlphaBox !Double !w
+data AlphaBox w s c = (Widget w s c) => AlphaBox !Double !w
 
-data AlphaBoxCache w s c d = (Widget w s c d) => AlphaBoxCache !c
+data AlphaBoxCache w s c = (Widget w s c) => AlphaBoxCache !c
 
-instance (Eq s, Display d) => Widget (AlphaBox w s c d) s (AlphaBoxCache w s c d) d where
+instance Eq s => Widget (AlphaBox w s c) s (AlphaBoxCache w s c) where
   initWidget (AlphaBox _ w) = initWidget w
   initCache (AlphaBox _ w) = AlphaBoxCache $ initCache w
   
@@ -47,6 +47,6 @@ instance (Eq s, Display d) => Widget (AlphaBox w s c d) s (AlphaBoxCache w s c d
   handleMessage (AlphaBox _ w) = handleMessage w
 
 
-alphaBox :: (Widget w s c d) => Double -> w -> AlphaBox w s c d
+alphaBox :: (Widget w s c) => Double -> w -> AlphaBox w s c
 alphaBox = AlphaBox
 

lib/Phi/Widgets/Clock.hs

@@ -34,7 +34,7 @@ data ClockConfig = ClockConfig { clockFormat :: !String
 defaultClockConfig :: ClockConfig
 defaultClockConfig = ClockConfig "%R" (0, 0, 0, 1) 0 50
 
-data Clock d = Clock !ClockConfig deriving (Show, Eq)
+data Clock = Clock !ClockConfig deriving (Show, Eq)
 
 deriving instance Eq ZonedTime
 
@@ -42,7 +42,7 @@ data ClockState = ClockState !ZonedTime deriving (Show, Eq)
 
 data ClockMessage = UpdateTime !ZonedTime deriving (Show, Typeable)
 
-instance Display d => Widget (Clock d) ClockState (RenderCache ClockState) d where
+instance Widget Clock ClockState (RenderCache ClockState) where
   initWidget (Clock _) phi _ _ = do
     forkIO $ forever $ do
       time <- getZonedTime
@@ -85,6 +85,6 @@ instance Display d => Widget (Clock d) ClockState (RenderCache ClockState) d whe
     _ -> priv
 
 
-clock :: ClockConfig -> Clock d
+clock :: ClockConfig -> Clock
 clock config = do
-  Clock config
+  Clock config

lib/Phi/Widgets/Systray.hs

@@ -1,7 +1,7 @@
 {-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}
 
-module Phi.Widgets.X11.Systray ( systray
+module Phi.Widgets.Systray ( systray
-                               ) where
+                           ) where
 
 import Control.Concurrent
 import Control.Monad
@@ -178,6 +178,18 @@ initSystray disp atoms = do
       return $ Just xembedWin
 
 
+sYSTEM_TRAY_REQUEST_DOCK :: CInt
+sYSTEM_TRAY_REQUEST_DOCK = 0
+
+sYSTEM_TRAY_BEGIN_MESSAGE :: CInt
+sYSTEM_TRAY_BEGIN_MESSAGE = 1
+
+sYSTEM_TRAY_CANCEL_MESSAGE :: CInt
+sYSTEM_TRAY_CANCEL_MESSAGE = 2
+
+xEMBED_EMBEDDED_NOTIFY :: CInt
+xEMBED_EMBEDDED_NOTIFY = 0
+
 handleEvent :: Event -> Phi -> Display -> Window -> Window -> StateT (M.Map Window Window) IO ()
 handleEvent message@ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar panelWindow xembedWindow = do
   let atoms = getAtoms dispvar

lib/Phi/Widgets/Taskbar.hs

@@ -1,17 +1,16 @@
 {-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}
 
-module Phi.Widgets.X11.Taskbar ( IconStyle
+module Phi.Widgets.Taskbar ( IconStyle
-                               , idIconStyle
+                           , idIconStyle
-                               , desaturateIconStyle
+                           , desaturateIconStyle
-                               , TaskStyle(..)
+                           , TaskStyle(..)
-                               , DesktopStyle(..)
+                           , DesktopStyle(..)
-                               , TaskbarConfig(..)
+                           , TaskbarConfig(..)
-                               , defaultTaskbarConfig
+                           , defaultTaskbarConfig
-                               , Taskbar
+                           , Taskbar
-                               , taskbar
+                           , taskbar
-                               ) where
+                           ) where
 
-import Control.Arrow
 import Control.Concurrent
 import Control.Monad
 import Control.Monad.State.Strict
@@ -39,8 +38,9 @@ import Graphics.Rendering.Pango.Enums (PangoRectangle(..))
 import Graphics.Rendering.Pango.Layout
 import Graphics.Rendering.Pango.Font
 
-import Graphics.XHB
+import Graphics.X11.Xlib (Window)
-import Graphics.XHB.Gen.Xproto
+import qualified Graphics.X11.Xlib as Xlib
+import qualified Graphics.X11.Xlib.Extras as XExtras
 
 import Codec.Binary.UTF8.String
 
@@ -48,9 +48,7 @@ import Phi.Phi
 import Phi.Types
 import Phi.Border
 import Phi.Widget
-import Phi.X11
 import Phi.X11.Atoms
-import Phi.X11.Util
 
 
 newtype IconStyle = IconStyle { withIconStyle :: Surface -> Render () }
@@ -139,13 +137,13 @@ defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 200
 
 data Taskbar = Taskbar TaskbarConfig
 
-data TaskbarState = TaskbarState { taskbarScreens           :: ![Rectangle]
+data TaskbarState = TaskbarState { taskbarScreens           :: ![Xlib.Rectangle]
-                                 , taskbarActiveWindow      :: !WINDOW
+                                 , taskbarActiveWindow      :: !Window
                                  , taskbarDesktopCount      :: !Int
                                  , taskbarCurrentDesktop    :: !Int
                                  , taskbarDesktopNames      :: ![String]
-                                 , taskbarWindows           :: ![WINDOW]
+                                 , taskbarWindows           :: ![Window]
-                                 , taskbarWindowStates      :: !(M.Map WINDOW WindowState)
+                                 , taskbarWindowStates      :: !(M.Map Window WindowState)
                                  } deriving Eq
 
 data Icon = Icon !Unique !Int !Surface
@@ -162,7 +160,7 @@ data WindowState = WindowState { windowTitle    :: !String
                                , windowDesktop  :: !Int
                                , windowVisible  :: !Bool
                                , windowIcons    :: ![Icon]
-                               , windowGeometry :: !Rectangle
+                               , windowGeometry :: !Xlib.Rectangle
                                } deriving (Eq, Show)
 
 data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Icon))
@@ -181,7 +179,7 @@ emptyWindowCache = WindowCache { createScaledIconCached = createIOCache createSc
                                }
 
 data TaskbarCache = TaskbarCache { desktopCaches :: !(M.Map Int DesktopCache)
-                                 , windowCaches  :: !(M.Map WINDOW WindowCache)
+                                 , windowCaches  :: !(M.Map Window WindowCache)
                                  }
 
 -- substitute for the liftT function in Data.Accessor.MonadState that uses the strict StateT variant
@@ -202,19 +200,19 @@ liftIOStateT m = do
 cached :: (MonadIO m, Eq a) => A.T s (IOCache a b) -> a -> StateT s m b
 cached t = liftT t . liftIOStateT . runIOCache
 
-data TaskbarMessage = WindowListUpdate ![WINDOW] !(M.Map WINDOW WindowState)
+data TaskbarMessage = WindowListUpdate ![Xlib.Window] !(M.Map Window WindowState)
                     | DesktopCountUpdate !Int
                     | CurrentDesktopUpdate !Int
                     | DesktopNamesUpdate ![String]
-                    | ActiveWindowUpdate !WINDOW
+                    | ActiveWindowUpdate !Window
                     deriving (Typeable, Show)
 
-instance Widget Taskbar TaskbarState (M.Map WINDOW WindowCache) X11 where
+instance Widget Taskbar TaskbarState (M.Map Window WindowCache) where
   initWidget (Taskbar _) phi dispvar screens = do
     phi' <- dupPhi phi
     forkIO $ taskbarRunner phi' dispvar
     
-    return $ TaskbarState (map fst screens) (fromXid xidNone) 0 (-1) [] [] M.empty
+    return $ TaskbarState (map fst screens) 0 0 (-1) [] [] M.empty
   
   initCache _ = M.empty
     
@@ -399,14 +397,14 @@ windowOnDesktop :: Int -> WindowState -> Bool
 windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDesktop state)
 
 
-taskbarRunner :: Phi -> X11 -> IO ()
+taskbarRunner :: Phi -> Display -> IO ()
-taskbarRunner phi x11 = do
+taskbarRunner phi dispvar = do
-  (windows, states) <- liftIO $ do
+  (windows, states) <- liftIO $ withDisplay dispvar $ \disp -> do
-    (windows, states) <- getWindowStates x11 M.empty
+    (windows, states) <- getWindowStates disp (getAtoms dispvar) M.empty
-    desktopCount <- getDesktopCount x11
+    desktopCount <- getDesktopCount disp (getAtoms dispvar) 
-    current <- getCurrentDesktop x11
+    current <- getCurrentDesktop disp (getAtoms dispvar) 
-    names <- getDesktopNames x11
+    names <- getDesktopNames disp (getAtoms dispvar)
-    activeWindow <- getActiveWindow x11
+    activeWindow <- getActiveWindow disp (getAtoms dispvar) 
     sendMessage phi $ WindowListUpdate windows states
     sendMessage phi $ DesktopCountUpdate desktopCount
     sendMessage phi $ CurrentDesktopUpdate current
@@ -418,57 +416,47 @@ taskbarRunner phi x11 = do
   flip evalStateT (windows, states) $ forever $ do
     m <- receiveMessage phi
     case (fromMessage m) of
-      Just (XEvent event) ->
+      Just event ->
-        handleEvent phi x11 event
+        handleEvent phi dispvar event
       _ ->
         return ()
 
-
+handleEvent :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState) IO ()
-handleEvent :: Phi -> X11 -> SomeEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO ()
+handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do
-handleEvent phi x11 event =
+  let atoms = getAtoms dispvar
-  case (fromEvent event) of
+  
-    Just e -> handlePropertyNotifyEvent phi x11 e
+  when (elem atom $ Xlib.wM_NAME : map ($ atoms) [ atom_NET_ACTIVE_WINDOW
-    Nothing -> case (fromEvent event) of
+                                                 , atom_NET_NUMBER_OF_DESKTOPS
-      Just e -> handleConfigureNotifyEvent phi x11 e
+                                                 , atom_NET_CURRENT_DESKTOP
-      Nothing -> return ()
+                                                 , atom_NET_DESKTOP_NAMES
-
+                                                 , atom_NET_CLIENT_LIST
-handlePropertyNotifyEvent :: Phi -> X11 -> PropertyNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO ()
+                                                 , atom_NET_WM_ICON
-handlePropertyNotifyEvent phi x11 MkPropertyNotifyEvent {atom_PropertyNotifyEvent = atom, window_PropertyNotifyEvent = window} = do
+                                                 , atom_NET_WM_NAME
-  let atoms = x11Atoms x11
+                                                 , atom_NET_WM_DESKTOP
-      rootwin = root_SCREEN . x11Screen $ x11
+                                                 , atom_NET_WM_STATE
-      
+                                  ]) $ withDisplay dispvar $ \disp -> do
-  when (elem atom $ map ($ atoms) [ atom_NET_ACTIVE_WINDOW
+    let rootwin = Xlib.defaultRootWindow disp
-                                  , atom_NET_NUMBER_OF_DESKTOPS
-                                  , atom_NET_CURRENT_DESKTOP
-                                  , atom_NET_DESKTOP_NAMES
-                                  , atom_NET_CLIENT_LIST
-                                  , atom_NET_WM_ICON
-                                  , atomWM_NAME
-                                  , atom_NET_WM_NAME
-                                  , atom_NET_WM_DESKTOP
-                                  , atom_NET_WM_STATE
-                                  ]) $ do
     if (window == rootwin)
       then do
       when (atom == atom_NET_ACTIVE_WINDOW atoms) $ do
-        activeWindow <- liftIO $ getActiveWindow x11
+        activeWindow <- liftIO $ getActiveWindow disp atoms
         sendMessage phi $ ActiveWindowUpdate activeWindow
         sendMessage phi Repaint
       when (atom == atom_NET_NUMBER_OF_DESKTOPS atoms) $ do
-        desktopCount <- liftIO $ getDesktopCount x11
+        desktopCount <- liftIO $ getDesktopCount disp atoms
         sendMessage phi $ DesktopCountUpdate desktopCount
         sendMessage phi Repaint
       when (atom == atom_NET_CURRENT_DESKTOP atoms) $ do
-        current <- liftIO $ getCurrentDesktop x11
+        current <- liftIO $ getCurrentDesktop disp atoms
         sendMessage phi $ CurrentDesktopUpdate current
         sendMessage phi Repaint
       when (atom == atom_NET_DESKTOP_NAMES atoms) $ do
-        names <- liftIO $ getDesktopNames x11
+        names <- liftIO $ getDesktopNames disp atoms
         sendMessage phi $ DesktopNamesUpdate names
         sendMessage phi Repaint
       when (atom == atom_NET_CLIENT_LIST atoms) $ do
         (windows, windowStates) <- get
-        (windows', windowStates') <- liftIO $ getWindowStates x11 windowStates
+        (windows', windowStates') <- liftIO $ getWindowStates disp atoms windowStates
         
         when (windows /= windows') $ do
           sendMessage phi $ WindowListUpdate windows' windowStates'
@@ -480,14 +468,14 @@ handlePropertyNotifyEvent phi x11 MkPropertyNotifyEvent {atom_PropertyNotifyEven
       when (elem window windows) $ do
         case () of
           _ | (atom == atom_NET_WM_ICON atoms) -> do
-            icons <- liftIO $ getWindowIcons x11 window
+            icons <- liftIO $ getWindowIcons disp atoms window
             let windowStates' = M.update (\state -> Just state {windowIcons = icons}) window windowStates
             sendMessage phi $ WindowListUpdate windows windowStates'
             sendMessage phi Repaint
             put (windows, windowStates')
         
             | otherwise -> do
-            (name, desktop, visible) <- liftIO $ getWindowInfo x11 window
+            (name, desktop, visible) <- liftIO $ getWindowInfo disp atoms window
             let mwindowState = M.lookup window windowStates
             case mwindowState of
               Just windowState -> do
@@ -501,45 +489,44 @@ handlePropertyNotifyEvent phi x11 MkPropertyNotifyEvent {atom_PropertyNotifyEven
               Nothing ->
                 return ()
 
-
+handleEvent phi dispvar XExtras.ConfigureEvent {XExtras.ev_window = window} = do
-handleConfigureNotifyEvent :: Phi -> X11 -> ConfigureNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO ()
-handleConfigureNotifyEvent phi x11 MkConfigureNotifyEvent {window_ConfigureNotifyEvent = window} = do
-  let conn = x11Connection x11
   (windows, windowStates) <- get
-  when (elem window windows) $  do
+  when (elem window windows) $ withDisplay dispvar $ \disp -> do
-    let geom = fmap windowGeometry . M.lookup window $ windowStates
+    let geom = fmap windowGeometry . M.lookup window $  windowStates
-    geom' <- liftIO $ getWindowGeometry x11 window
+    geom' <- liftIO $ getWindowGeometry disp window
     when (geom /= (Just geom')) $ do
       let windowStates' = M.update (\state -> Just state {windowGeometry = geom'}) window windowStates
       sendMessage phi $ WindowListUpdate windows windowStates'
       sendMessage phi Repaint
       put (windows, windowStates')
 
+handleEvent _ _ _ = return ()
 
-getDesktopCount :: X11 -> IO Int
-getDesktopCount x11 =
-  liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_NUMBER_OF_DESKTOPS . x11Atoms $ x11)
 
-getCurrentDesktop :: X11 -> IO Int
+getDesktopCount :: Xlib.Display -> Atoms -> IO Int
-getCurrentDesktop x11 =
+getDesktopCount disp atoms =
-  liftM (fromIntegral . fromMaybe (-1) . join . fmap listToMaybe) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_CURRENT_DESKTOP . x11Atoms $ x11)
+  liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_NUMBER_OF_DESKTOPS atoms) $ Xlib.defaultRootWindow disp
 
-getDesktopNames :: X11 -> IO [String]
+getCurrentDesktop :: Xlib.Display -> Atoms -> IO Int
-getDesktopNames x11 =
+getCurrentDesktop disp atoms =
-  liftM (map (decode . map fromIntegral) . break' . fromMaybe []) $ getProperty8 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_DESKTOP_NAMES . x11Atoms $ x11)
+  liftM (fromIntegral . fromMaybe (-1) . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_CURRENT_DESKTOP atoms) $ Xlib.defaultRootWindow disp
+
+getDesktopNames :: Xlib.Display -> Atoms -> IO [String]
+getDesktopNames disp atoms =
+  liftM (map (decode . map fromIntegral) . break' . fromMaybe []) $ XExtras.getWindowProperty8 disp (atom_NET_DESKTOP_NAMES atoms) $ Xlib.defaultRootWindow disp
   where
     break' l = case dropWhile (== 0) l of
       [] -> []
       l' -> w : break' l''
         where (w, l'') = break (== 0) l'
 
-getActiveWindow :: X11 -> IO WINDOW
+getActiveWindow :: Xlib.Display -> Atoms -> IO Window
-getActiveWindow x11 =
+getActiveWindow disp atoms =
-  liftM (fromXid . toXid . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_ACTIVE_WINDOW . x11Atoms $ x11)
+  liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_ACTIVE_WINDOW atoms) $ Xlib.defaultRootWindow disp
 
-getWindowStates :: X11 -> M.Map WINDOW WindowState -> IO ([WINDOW], M.Map WINDOW WindowState)
+getWindowStates :: Xlib.Display -> Atoms -> M.Map Window WindowState -> IO ([Window], M.Map Window WindowState)
-getWindowStates x11 windowStates = do
+getWindowStates disp atoms windowStates = do
-  windows <- getWindowList x11
+  windows <- getWindowList disp atoms
   
   let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows
   
@@ -549,15 +536,15 @@ getWindowStates x11 windowStates = do
     where
       getWindowState' (window, Just windowState) = return (window, windowState) 
       getWindowState' (window, Nothing) = do
-        changeWindowAttributes (x11Connection x11) window $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])]
+        Xlib.selectInput disp window $ Xlib.propertyChangeMask .|. Xlib.structureNotifyMask
-        windowState <- getWindowState x11 window
+        windowState <- getWindowState disp atoms window
         return (window, windowState)
 
-getWindowState :: X11 -> WINDOW -> IO WindowState
+getWindowState :: Xlib.Display -> Atoms -> Window -> IO WindowState
-getWindowState x11 window = do
+getWindowState disp atoms window = do
-  (name, workspace, visible) <- getWindowInfo x11 window
+  (name, workspace, visible) <- getWindowInfo disp atoms window
-  icons <- getWindowIcons x11 window
+  icons <- getWindowIcons disp atoms window
-  geom <- getWindowGeometry x11 window
+  geom <- getWindowGeometry disp window
   
   return $ WindowState { windowTitle = name 
                        , windowDesktop = workspace 
@@ -566,27 +553,25 @@ getWindowState x11 window = do
                        , windowGeometry = geom
                        }
 
-getWindowInfo :: X11 -> WINDOW -> IO (String, Int, Bool)
+getWindowInfo :: Xlib.Display -> Atoms -> Window -> IO (String, Int, Bool)
-getWindowInfo x11 window = do
+getWindowInfo disp atoms window = do
-  let conn = x11Connection x11
+  netwmname <- liftM (fmap (decode . map fromIntegral)) $ XExtras.getWindowProperty8 disp (atom_NET_WM_NAME atoms) window
-      atoms = x11Atoms x11
-  netwmname <- liftM (fmap (decode . map fromIntegral)) $ getProperty8 conn window (atom_NET_WM_NAME atoms)
   wmname <- case netwmname of
     Just name -> return name
-    Nothing -> liftM (map unsignedChr . fromMaybe []) $ getProperty8 conn window (atomWM_NAME atoms)
+    Nothing -> liftM (map unsignedChr . fromMaybe []) $ XExtras.getWindowProperty8 disp Xlib.wM_NAME window
   
-  workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ getProperty32 conn window (atom_NET_WM_DESKTOP atoms)
+  workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_DESKTOP atoms) window
-  visible <- showWindow conn atoms window
+  visible <- showWindow disp atoms window
   
   return (wmname, workspace, visible)
     where
-      unsignedChr = chr . fromIntegral
+      unsignedChr = chr . fromIntegral . (fromIntegral :: (CChar -> CUChar))
 
-getWindowIcons :: X11 -> WINDOW -> IO [Icon]
+getWindowIcons :: Xlib.Display -> Atoms -> Window -> IO [Icon]
-getWindowIcons x11 window = getProperty32 (x11Connection x11) window (atom_NET_WM_ICON . x11Atoms $ x11) >>= readIcons . fromMaybe []
+getWindowIcons disp atoms window = XExtras.getWindowProperty32 disp (atom_NET_WM_ICON atoms) window >>= readIcons . fromMaybe []
 
 
-readIcons :: [Word32] -> IO [Icon]
+readIcons :: [CLong] -> IO [Icon]
 readIcons (width:height:iconData) = do
   if ((fromIntegral $ length iconData) < (width*height)) then return [] else do
     let (thisIcon, rest) = splitAt (fromIntegral (width*height)) iconData
@@ -616,23 +601,22 @@ premultiply c = a .|. r .|. g .|. b
     b = pm bmask
 
 
-getWindowGeometry :: X11 -> WINDOW -> IO Rectangle
+getWindowGeometry :: Xlib.Display -> Window -> IO Xlib.Rectangle
-getWindowGeometry x11 window =
+getWindowGeometry disp window = flip catch (\_ -> return $ Xlib.Rectangle 0 0 0 0) $ do
-  getGeometry (x11Connection x11) (fromXid . toXid $ window) >>= getReply >>=
+  (_, _, _, width, height, _, _) <- Xlib.getGeometry disp window
-  return . ((const $ Rectangle 0 0 0 0) ||| (\(MkGetGeometryReply _ _ x y width height _) -> Rectangle (fi x) (fi y) (fi width) (fi height)))
+  (ret, x, y, _) <- Xlib.translateCoordinates disp window (Xlib.defaultRootWindow disp) 0 0
-    where
+  
-      fi :: (Integral a, Num b) => a -> b
+  return $ if ret then Xlib.Rectangle x y width height else Xlib.Rectangle 0 0 0 0
-      fi = fromIntegral
+    
 
-showWindow :: ConnectionClass c => c -> Atoms -> WINDOW -> IO Bool
+showWindow :: Xlib.Display -> Atoms -> Window -> IO Bool
-showWindow conn atoms window = do
+showWindow disp atoms window = do
-  states <- liftM (map (fromXid . toXid) . fromMaybe []) $ getProperty32 conn window (atom_NET_WM_STATE atoms)
+  states <- liftM (map fromIntegral . fromMaybe []) $ XExtras.getWindowProperty32 disp (atom_NET_WM_STATE atoms) window
-  transientFor <- liftM (map fromIntegral . fromMaybe []) $ getProperty32 conn window (atomWM_TRANSIENT_FOR atoms)
+  transientForHint <- XExtras.getTransientForHint disp window
-  windowType <- liftM (fromMaybe (atom_NET_WM_WINDOW_TYPE_NORMAL atoms) . fmap (fromXid . toXid) . join . fmap listToMaybe) $
+  windowType <- liftM (fromMaybe (atom_NET_WM_WINDOW_TYPE_NORMAL atoms) . fmap fromIntegral . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_STATE atoms) window
-                getProperty32 conn window (atom_NET_WM_STATE atoms)
   
   return $ not $ or [ elem (atom_NET_WM_STATE_SKIP_TASKBAR atoms) states 
-                    , transientFor /= [] && transientFor /= [0]
+                    , transientForHint /= Nothing
                     , elem windowType $ map ($ atoms) [ atom_NET_WM_WINDOW_TYPE_DOCK 
                                                       , atom_NET_WM_WINDOW_TYPE_DESKTOP 
                                                       , atom_NET_WM_WINDOW_TYPE_TOOLBAR 
@@ -642,8 +626,8 @@ showWindow conn atoms window = do
                     ]
 
 
-getWindowList :: X11 -> IO [WINDOW]
+getWindowList :: Xlib.Display -> Atoms -> IO [Window]
-getWindowList x11 = liftM (map (fromXid . toXid) . join . maybeToList) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_CLIENT_LIST . x11Atoms $ x11)
+getWindowList disp atoms = liftM (map fromIntegral . join . maybeToList) $ XExtras.getWindowProperty32 disp (atom_NET_CLIENT_LIST atoms) $ Xlib.defaultRootWindow disp
 
 taskbar :: TaskbarConfig -> Taskbar
 taskbar = Taskbar

lib/Phi/X11.hs

@@ -1,17 +1,13 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification, TypeFamilies, FlexibleContexts, DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification #-}
 
-module Phi.X11 ( X11(..)
+module Phi.X11 ( XConfig(..)
-               , XEvent(..)
-               , XMessage(..)
-               , XConfig(..)
                , defaultXConfig
                , runPhi
                ) where
 
-import Graphics.XHB hiding (Window)
+import Graphics.XHB
-import Graphics.XHB.Connection.XCB
 import Graphics.XHB.Gen.Xinerama
-import Graphics.XHB.Gen.Xproto hiding (Window)
+import Graphics.XHB.Gen.Xproto
 
 import Graphics.Rendering.Cairo
 
@@ -34,53 +30,39 @@ import System.Exit
 import System.Posix.Signals
 import System.Posix.Types
 
-import Phi.Bindings.Cairo
+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 (handleMessage)
+import qualified Phi.Widget as Widget
-import Phi.Widget hiding (handleMessage)
+import Phi.Widget hiding (Display, handleMessage)
 import Phi.X11.Atoms
 
 
-data X11 = X11 { x11Connection :: !Connection 
+data XConfig = XConfig { phiXScreenInfo :: !(Connection -> IO [RECTANGLE])
-               , x11Atoms      :: !Atoms
-               , x11Screen     :: !SCREEN
-               }
-
-instance Display X11 where
-  type Window X11 = WINDOW
-
-
-newtype XEvent = XEvent SomeEvent deriving (Show, Typeable)
- 
-data XMessage = UpdateScreens [(Rectangle, WINDOW)] deriving (Show, Typeable)
-
-
-data XConfig = XConfig { phiXScreenInfo :: !(X11 -> IO [Rectangle])
                        }
 
-data PhiState w s c = (Widget w s c X11) => PhiState { phiRootImage    :: !Surface
+data PhiState w s c = (Widget.Widget w s c) => PhiState { phiRootImage    :: !Surface
-                                                     , phiPanels       :: ![PanelState w s c]
+                                                        , phiPanels       :: ![PanelState w s c]
-                                                     , phiRepaint      :: !Bool
+                                                        , phiRepaint      :: !Bool
-                                                     , phiShutdown     :: !Bool
+                                                        , phiShutdown     :: !Bool
-                                                     , phiShutdownHold :: !Int
+                                                        , phiShutdownHold :: !Int
-                                                     , phiWidgetState  :: !s
+                                                        , phiWidgetState  :: !s
-                                                     }
+                                                        }
 
-data PanelState w s c = (Widget w s c X11) => 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
+                                                            , panelWidgetCache  :: !c
-                                                         }
+                                                            }
 
 data PhiConfig w s c = PhiConfig { phiPhi          :: !Phi
                                  , phiPanelConfig  :: !Panel.PanelConfig
                                  , phiXConfig      :: !XConfig
-                                 , phiX11          :: !X11
+                                 , phiAtoms        :: !Atoms
                                  , phiWidget       :: !w
                                  }
 
@@ -99,22 +81,17 @@ runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st
 defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
                          }
 
-getScreenInfo :: X11 -> IO [Rectangle]
+getScreenInfo :: Connection -> IO [RECTANGLE]
-getScreenInfo x11 = do
+getScreenInfo conn = do
-  let conn = x11Connection x11
-      screen = x11Screen x11
   exs <- queryScreens conn >>= getReply
   case exs of
     Right xs -> return . map screenInfoToRect $ screen_info_QueryScreensReply xs
-    Left _ -> getGeometry conn (fromXid . toXid $ root_SCREEN screen) >>= getReply' "getScreenInfo: getGeometry failed" >>=
+    Left _ -> getGeometry conn (fromXid . toXid $ getRoot conn) >>= getReply' "getScreenInfo: getGeometry failed" >>=
-              return . (\(MkGetGeometryReply _ _ x y w h _) -> [Rectangle (fi x) (fi y) (fi w) (fi h)])
+              return . (\(MkGetGeometryReply _ _ x y w h _) -> [MkRECTANGLE x y w h])
   where
-    screenInfoToRect (MkScreenInfo x y w h) = Rectangle (fi x) (fi y) (fi w) (fi h)
+    screenInfoToRect (MkScreenInfo x y w h) = MkRECTANGLE x y w h
-    
-    fi :: (Integral a, Num b) => a -> b
-    fi = fromIntegral
 
-runPhi :: (Widget w s c X11) => XConfig -> Panel.PanelConfig -> w -> IO ()
+runPhi :: (Widget.Widget w s c) => XConfig -> Panel.PanelConfig -> w -> IO ()
 runPhi xconfig config widget = do
   phi <- initPhi
   
@@ -123,67 +100,57 @@ runPhi xconfig config widget = do
   installHandler sigQUIT (termHandler phi) Nothing
   
   conn <- liftM fromJust connect
+  xcb <- XCB.connect
   
-  let screen = (roots_Setup . connectionSetup $ conn) !! connectionScreen conn
-
   atoms <- initAtoms conn
-  changeWindowAttributes conn (root_SCREEN screen) $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])]
+  changeWindowAttributes conn (getRoot conn) $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])]
   
   bg <- createImageSurface FormatRGB24 1 1
   
-  let x11 = X11 conn atoms screen
+  screens <- liftIO $ phiXScreenInfo xconfig conn
-  
+  panelWindows <- mapM (createPanelWindow conn config) screens
-  screens <- liftIO $ phiXScreenInfo xconfig x11
+  let dispvar = Widget.Display conn atoms
-  panelWindows <- mapM (createPanelWindow conn screen config) screens
+      widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1)
-  
-  let widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1)
       screenPanels = zip screens panelWindows
 
-  initialState <- initWidget widget' phi x11 screenPanels
+  initialState <- Widget.initWidget widget' phi dispvar screenPanels
 
   runPhiX
     PhiConfig { phiPhi = phi
               , phiXConfig = xconfig
               , phiPanelConfig = config
-              , phiX11 = x11
+              , phiAtoms = atoms
               , phiWidget = widget'
               }
     PhiState { phiRootImage = bg
              , phiPanels = []
-             , phiRepaint = False
+             , phiRepaint = True
              , phiShutdown = False
              , phiShutdownHold = 0
              , phiWidgetState = initialState
              } $ do
-    updateRootImage
+    updateRootImage conn xcb
     
-    panels <- mapM (\(screen, window) -> createPanel window screen) screenPanels
+    panels <- mapM (\(screen, window) -> createPanel conn window screen) screenPanels
     
-    forM_ panels setPanelProperties
+    forM_ panels $ \panel -> do
+      setPanelProperties conn panel
+      liftIO $ mapWindow conn (panelWindow panel)
     
     modify $ \state -> state { phiPanels = panels }
     
-    updatePanels
+    liftIO $ forkIO $ receiveEvents phi conn
-    
-    forM_ panels $ liftIO . mapWindow conn . panelWindow
-    
-    liftIO $ do
-      forkIO $ receiveEvents phi conn
-      forkIO $ receiveErrors phi conn
     
     forever $ do
       available <- messageAvailable phi
-      repaint <- gets phiRepaint
+      unless available $ do
-      when (not available && repaint) $ liftIO $ threadDelay 20000
+        repaint <- gets phiRepaint
-      
+        when repaint $ do
-      available <- messageAvailable phi
+          updatePanels conn xcb
-      when (not available && repaint) $ do
+          modify $ \state -> state {phiRepaint = False}
-        updatePanels
-        modify $ \state -> state {phiRepaint = False}
       
       message <- receiveMessage phi
-      handleMessage message
+      handleMessage conn xcb message
-      
       
       case (fromMessage message) of
         Just Shutdown ->
@@ -208,8 +175,8 @@ termHandler :: Phi -> Handler
 termHandler phi = Catch $ sendMessage phi Shutdown
 
 
-handleMessage :: (Widget w s c X11) => Message -> PhiX w s c ()
+handleMessage :: (Widget w s c) => Connection -> XCB.Connection -> Message -> PhiX w s c ()
-handleMessage m = do
+handleMessage conn xcb m = do
   w <- asks phiWidget
   modify $ \state -> state {phiWidgetState = Widget.handleMessage w (phiWidgetState state) m}
   
@@ -219,107 +186,80 @@ handleMessage m = do
     _ ->
       case (fromMessage m) of
         Just (XEvent event) ->
-          handleEvent event
+          handleEvent conn xcb event
         _ ->
           return ()
 
-handleEvent :: (Widget w s c X11) => SomeEvent -> PhiX w s c ()
+handleEvent :: (Widget w s c) => Connection -> XCB.Connection -> SomeEvent -> PhiX w s c ()
-handleEvent event =
+handleEvent conn xcb event = do
   case (fromEvent event) of
-    Just e -> handlePropertyNotifyEvent e
+    Just e -> handlePropertyNotifyEvent conn xcb e
     Nothing -> case (fromEvent event) of
-      Just e -> handleConfigureNotifyEvent e
+      Just e -> handleConfigureNotifyEvent conn e
       Nothing -> return ()
 
-handlePropertyNotifyEvent :: (Widget w s c X11) => PropertyNotifyEvent -> PhiX w s c ()
+handlePropertyNotifyEvent :: (Widget w s c) => Connection -> XCB.Connection -> PropertyNotifyEvent -> PhiX w s c ()
-handlePropertyNotifyEvent MkPropertyNotifyEvent { atom_PropertyNotifyEvent = atom } = do
+handlePropertyNotifyEvent conn xcb MkPropertyNotifyEvent { atom_PropertyNotifyEvent = atom } = do
   phi <- asks phiPhi
-  atoms <- asks (x11Atoms . phiX11)
+  atoms <- asks phiAtoms
   panels <- gets phiPanels
 
   when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do
-    updateRootImage
+    updateRootImage conn xcb
     sendMessage phi ResetBackground
     sendMessage phi Repaint
 
-handleConfigureNotifyEvent :: (Widget w s c X11) => ConfigureNotifyEvent -> PhiX w s c ()
+handleConfigureNotifyEvent :: (Widget w s c) => Connection -> ConfigureNotifyEvent -> PhiX w s c ()
-handleConfigureNotifyEvent MkConfigureNotifyEvent { window_ConfigureNotifyEvent = window } = do
+handleConfigureNotifyEvent conn MkConfigureNotifyEvent { window_ConfigureNotifyEvent = window } | window == getRoot conn = do  
-  x11 <- asks phiX11
+  phi <- asks phiPhi
-  let conn = x11Connection x11
+  xconfig <- asks phiXConfig
-      screen = x11Screen x11
+  config <- asks phiPanelConfig
-      rootWindow = root_SCREEN screen
+  panels <- gets phiPanels
-  when (window == rootWindow) $ do
+  let screens = map panelScreenArea panels
-    phi <- asks phiPhi
+  screens' <- liftIO $ phiXScreenInfo xconfig conn
-    xconfig <- asks phiXConfig
+  
-    config <- asks phiPanelConfig
+  when (screens /= screens') $ do
-    panels <- gets phiPanels
+    liftIO $ do
-    let screens = map panelScreenArea panels
+      mapM_ (freePixmap conn . panelPixmap) panels
-    screens' <- liftIO $ phiXScreenInfo xconfig x11
+      mapM_ (destroyWindow conn . panelWindow) $ drop (length screens') panels
     
-    when (screens /= screens') $ do
+    let panelsScreens = zip screens' $ map Just panels ++ repeat Nothing
-      liftIO $ do
+    
-        mapM_ (freePixmap conn . panelPixmap) panels
+    panels' <- forM panelsScreens $ \(screen, mpanel) ->
-        mapM_ (destroyWindow conn . panelWindow) $ drop (length screens') panels
+      case mpanel of
-      
+        Just panel -> do
-      let panelsScreens = zip screens' $ map Just panels ++ repeat Nothing
+          let rect = panelBounds config screen
-      
+              win = panelWindow panel
-      panels' <- forM panelsScreens $ \(screenarea, mpanel) ->
+          
-        case mpanel of
+          liftIO $ configureWindow conn win $ toValueParam [ (ConfigWindowX, fromIntegral $ x_RECTANGLE rect)
-          Just panel -> do
+                                                           , (ConfigWindowY, fromIntegral $ y_RECTANGLE rect)
-            let rect = panelBounds config screenarea
+                                                           , (ConfigWindowWidth, fromIntegral $ width_RECTANGLE rect)
-                win = panelWindow panel
+                                                           , (ConfigWindowHeight, fromIntegral $ height_RECTANGLE rect)
-            
+                                                           ]
-            liftIO $ configureWindow conn $ MkConfigureWindow win (toMask [ConfigWindowX, ConfigWindowY, ConfigWindowWidth, ConfigWindowHeight]) $
+          
-              toValueParam [ (ConfigWindowX, fromIntegral $ rect_x rect)
+          panel' <- createPanel conn win screen
-                           , (ConfigWindowY, fromIntegral $ rect_y rect)
+          setPanelProperties conn panel'
-                           , (ConfigWindowWidth, fromIntegral $ rect_width rect)
+          
-                           , (ConfigWindowHeight, fromIntegral $ rect_height rect)
+          return panel'
-                           ]
+        Nothing -> do
-            
+          win <- liftIO $ createPanelWindow conn config screen
-            panel' <- createPanel win screenarea
+          panel <- createPanel conn win screen
-            setPanelProperties panel'
+          setPanelProperties conn panel
-            
+          liftIO $ mapWindow conn $ panelWindow panel
-            return panel'
+          return panel
-          Nothing -> do
+    
-            win <- liftIO $ createPanelWindow conn screen config screenarea
+    modify $ \state -> state { phiPanels = panels' }
-            panel <- createPanel win screenarea
+    
-            setPanelProperties panel
+    sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels'
-            liftIO $ mapWindow conn $ panelWindow panel
+    sendMessage phi Repaint
-            return panel
-      
-      modify $ \state -> state { phiPanels = panels' }
-      
-      sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels'
-      sendMessage phi Repaint
-
-
-maybeReceiveEvents' :: Connection -> IO [XEvent]
-maybeReceiveEvents' conn = do
-  yield
-  mevent <- pollForEvent conn
-  case mevent of
-    Just event ->
-      liftM2 (:) (return . XEvent $ event) (maybeReceiveEvents' conn)
-    Nothing ->
-      return []
-      
-
-receiveEvents' :: Connection -> IO [XEvent]
-receiveEvents' conn = do
-  liftM2 (:) (liftM XEvent $ waitForEvent conn) (maybeReceiveEvents' conn)
 
 
 receiveEvents :: Phi -> Connection -> IO ()
-receiveEvents phi conn =
+receiveEvents phi conn = do
-  forever $ receiveEvents' conn >>= sendMessages phi
+  forever $ waitForEvent conn >>= sendMessage phi . XEvent
 
-receiveErrors :: Phi -> Connection -> IO ()
+updatePanels :: (Widget w s c) => Connection -> XCB.Connection -> PhiX w s c ()
-receiveErrors phi conn =
+updatePanels conn xcb = do
-  forever $ waitForError conn >>= putStrLn . ("XHB error: " ++) . show
-
-updatePanels :: (Widget w s c X11) => PhiX w s c ()
-updatePanels = do
-  X11 conn _ screen <- asks phiX11
   w <- asks phiWidget
   s <- gets phiWidgetState
   rootImage <- gets phiRootImage
@@ -330,16 +270,17 @@ updatePanels = do
         area = panelArea panel
     
     (panelSurfaces, cache') <- liftIO $ flip runStateT (panelWidgetCache panel) $
-                               (withDimension area $ render w s 0 0) (panelScreenArea panel)
+                               (withDimension area $ Widget.render w s 0 0) (panelScreenArea panel)
     
-    let visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
+    let screen = head . roots_Setup . connectionSetup $ conn
+        visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
     
-    xbuffer <- liftIO $ withDimension area $ createXCBSurface conn (fromXid . toXid $ pixmap) visualtype
+    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 $ rect_x area)) (-(fromIntegral $ rect_y area))
+        translate (-(fromIntegral $ x_RECTANGLE area)) (-(fromIntegral $ y_RECTANGLE area))
         withPatternForSurface rootImage $ \pattern -> do
           patternSetExtend pattern ExtendRepeat
           setSource pattern
@@ -360,20 +301,19 @@ updatePanels = do
     surfaceFinish xbuffer
     
     -- update window
-    liftIO $ do
+    liftIO $ withDimension area $ XCB.clearArea xcb True (panelWindow panel) 0 0
-      clearArea conn $ withDimension area $ MkClearArea True (panelWindow panel) 0 0
-      flush conn
         
     return $ panel { panelWidgetCache = cache' }
   
   modify $ \state -> state { phiPanels = panels' }
 
 
-updateRootImage :: PhiX w s c ()
+updateRootImage :: Connection -> XCB.Connection -> PhiX w s c ()
-updateRootImage = do
+updateRootImage conn xcb = do
-  X11 conn atoms screen <- asks phiX11 
+  atoms <- asks phiAtoms
   
-  let visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
+  let screen = head . roots_Setup . connectionSetup $ conn
+      visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
       rootwin = root_SCREEN screen
   
   pixmap <- liftM (fromXid . toXid . fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $
@@ -400,7 +340,7 @@ updateRootImage = do
         setSourceRGB 0 0 0
         paint
     _ -> do
-      rootSurface <- liftIO $ createXCBSurface conn (fromXid . toXid $ pixmap) visualtype (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
@@ -410,12 +350,12 @@ updateRootImage = do
   return ()
 
 
-createPanel :: (Widget w s c X11) => 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 win screenRect = do
+createPanel conn win screenRect = do
-  (conn, screen) <- asks $ (x11Connection &&& x11Screen) . phiX11
   config <- asks phiPanelConfig
   w <- asks phiWidget
   let rect = panelBounds config screenRect
+      screen = head . roots_Setup . connectionSetup $ conn
       depth = root_depth_SCREEN screen
     
   pixmap <- liftIO $ newResource conn
@@ -429,9 +369,10 @@ createPanel win screenRect = do
                     , panelWidgetCache = initCache w
                     }
 
-createPanelWindow :: Connection -> SCREEN -> Panel.PanelConfig -> Rectangle -> IO WINDOW
+createPanelWindow :: Connection -> Panel.PanelConfig -> RECTANGLE -> IO WINDOW
-createPanelWindow conn screen config screenRect = do
+createPanelWindow conn config screenRect = do
   let rect = panelBounds config screenRect
+      screen = head . roots_Setup . connectionSetup $ conn
       depth = root_depth_SCREEN screen
       rootwin = root_SCREEN screen
       visual = root_visual_SCREEN screen
@@ -441,9 +382,9 @@ createPanelWindow conn screen config screenRect = do
   return win
 
 
-setPanelProperties :: PanelState w s c -> PhiX w s c ()
+setPanelProperties :: Connection -> PanelState w s c -> PhiX w s c ()
-setPanelProperties panel = do
+setPanelProperties conn panel = do
-  (conn, atoms) <- asks $ (x11Connection &&& x11Atoms) .  phiX11
+  atoms <- asks phiAtoms
   liftIO $ do
     let name = map (fromIntegral . ord) "Phi"
     changeProperty8 conn PropModeReplace (panelWindow panel) (atomWM_NAME atoms) (atomSTRING atoms) name
@@ -462,28 +403,28 @@ setPanelProperties panel = do
     
     changeProperty8 conn PropModeReplace (panelWindow panel) (atomWM_CLASS atoms) (atomSTRING atoms) $ map (fromIntegral . ord) "phi\0Phi"
   
-  setStruts panel
+  setStruts conn panel
 
 
-setStruts :: PanelState w s c -> PhiX w s c ()
+setStruts :: Connection -> PanelState w s c -> PhiX w s c ()
-setStruts panel = do
+setStruts conn panel = do
-  X11 conn atoms screen <- asks phiX11
+  atoms <- asks phiAtoms
   config <- asks phiPanelConfig
-  let rootwin = root_SCREEN screen
+  let rootwin = getRoot conn
       position = Panel.panelPosition config
       area = panelArea panel
   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 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
           
-          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
           
           makeStruts = case position of
@@ -495,17 +436,17 @@ setStruts panel = do
     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 = Panel.panelSize config }
+  Phi.Top -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config }
-  Phi.Bottom -> screenBounds { rect_height = Panel.panelSize config,
+  Phi.Bottom -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config,
-                               rect_y = rect_y screenBounds + rect_height screenBounds - 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

@@ -7,16 +7,15 @@ module Phi.X11.AtomList ( atoms
 import Language.Haskell.TH
 
 import Graphics.XHB
+import Graphics.XHB.Connection.Open
 
 atoms :: [String]
 atoms = [ "ATOM"
         , "CARDINAL"
         , "STRING"
-        , "VISUALID"
         , "UTF8_STRING"
         , "WM_NAME"
         , "WM_CLASS"
-        , "WM_TRANSIENT_FOR"
         , "MANAGER"
         , "_NET_WM_NAME"
         , "_NET_WM_WINDOW_TYPE"
@@ -48,10 +47,9 @@ atoms = [ "ATOM"
         , "_XEMBED"
         , "_XROOTPMAP_ID"
         , "_XROOTMAP_ID"
-        , "PHI_SYSTRAY_HELPER"
         ]
 
--- the expression must have the type (ConnectionClass c => c -> String)
+-- the expression must have the type (Connection -> String)
 specialAtoms :: [(String, Q Exp)]
-specialAtoms = [ ("_NET_SYSTEM_TRAY_SCREEN", [|("_NET_SYSTEM_TRAY_S" ++) . show . connectionScreen|])
+specialAtoms = [ ("_NET_SYSTEM_TRAY_SCREEN", [|("_NET_SYSTEM_TRAY_S" ++) . show . screen . displayInfo|])
-               ]
+               ]

lib/Phi/X11/Atoms.hs

@@ -21,7 +21,7 @@ $(let atomsName = mkName "Atoms"
   in return [DataD [] atomsName [] [RecC atomsName fields] []]
  )
 
-initAtoms :: ConnectionClass c => c -> IO Atoms
+initAtoms :: Connection -> IO Atoms
 initAtoms conn =
   $(do
        normalAtomNames <- mapM (\atom -> do

lib/Phi/X11/Util.hs

@@ -6,10 +6,8 @@ module Phi.X11.Util ( getReply'
                     , getProperty16
                     , getProperty32
                     , findVisualtype
-                    , serializeClientMessage
                     ) where
 
-import Control.Exception (assert)
 import Control.Monad
 
 import Data.Int
@@ -17,11 +15,8 @@ import Data.List
 import Data.Maybe
 import Data.Word
 
-import Foreign.C.Types
 import Foreign.Marshal.Array
-import Foreign.Marshal.Utils
 import Foreign.Ptr
-import Foreign.Storable
 
 import Graphics.XHB
 import Graphics.XHB.Gen.Xproto
@@ -55,22 +50,18 @@ castWord8to32 input = unsafePerformIO $
   withArray input $ \ptr ->
     peekArray (length input `div` 4) (castPtr ptr)
 
-castToCChar :: Storable s => s -> [CChar]
-castToCChar input = unsafePerformIO $
-  with input $ \ptr ->
-    peekArray (sizeOf input) (castPtr ptr)
 
-changeProperty8 :: ConnectionClass c => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word8] -> IO ()
+changeProperty8 :: 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 :: ConnectionClass c => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word16] -> IO ()
+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 :: ConnectionClass c => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word32] -> IO ()
+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' :: ConnectionClass c => Word8 -> c -> WINDOW -> ATOM -> IO (Maybe [Word8])
+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
@@ -84,43 +75,15 @@ getProperty' format conn win prop = do
         Right (MkGetPropertyReply {format_GetPropertyReply = format'}) | format' /= format -> return Nothing
         Right (MkGetPropertyReply {value_GetPropertyReply = value}) -> return $ Just value
 
-getProperty8 :: ConnectionClass c => c -> WINDOW -> ATOM -> IO (Maybe [Word8])
+getProperty8 :: Connection -> WINDOW -> ATOM -> IO (Maybe [Word8])
 getProperty8 = getProperty' 8
 
-getProperty16 :: ConnectionClass c => c -> WINDOW -> ATOM -> IO (Maybe [Word16])
+getProperty16 :: Connection -> WINDOW -> ATOM -> IO (Maybe [Word16])
 getProperty16 conn win prop = getProperty' 16 conn win prop >>= return . fmap castWord8to16
 
-getProperty32 :: ConnectionClass c => c -> WINDOW -> ATOM -> IO (Maybe [Word32])
+getProperty32 :: 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
+findVisualtype screen id = listToMaybe . filter ((== id) . visual_id_VISUALTYPE) . join . map visuals_DEPTH . allowed_depths_SCREEN $ screen
-
-
-instance Storable ClientMessageData where
-  sizeOf _ = 20
-  alignment _ = 1
-  peek _ = error "ClientMessageData: peek not implemented"
-  poke ptr (ClientData8 d) = assert (length d == 20) $ pokeArray (castPtr ptr) d
-  poke ptr (ClientData16 d) = assert (length d == 10) $ pokeArray (castPtr ptr) d
-  poke ptr (ClientData32 d) = assert (length d == 5) $ pokeArray (castPtr ptr) d
-
-instance Storable ClientMessageEvent where
-  sizeOf _ = 32
-  alignment _ = 1
-  peek _ = error "ClientMessageEvent: peek not implemented"
-  poke ptr ev = do
-    poke' 0 (33 :: Word8) -- ClientMessage == 33                         -- response_type
-    poke' 1 (format_ClientMessageEvent ev)                               -- format
-    poke' 2 (0 :: Word16)                                                -- sequence
-    poke' 4 (fromXid . toXid . window_ClientMessageEvent $ ev :: Word32) -- window
-    poke' 8 (fromXid . toXid . type_ClientMessageEvent $ ev :: Word32)   -- type
-    poke' 12 (data_ClientMessageEvent ev)                                -- data
-    where
-      poke' :: Storable s => Int -> s -> IO ()
-      poke' = poke . plusPtr ptr
-    
-
-serializeClientMessage :: ClientMessageEvent -> [CChar]
-serializeClientMessage = castToCChar

phi.cabal

@@ -10,28 +10,20 @@ author:              Matthias Schiffer
 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, xhb >= 0.5, xhb-xcb,
+  build-depends:     base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, xhb,
                      cairo, pango, unix, data-accessor, arrows, CacheArrow
   exposed-modules:   Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11
-                     Phi.Widgets.AlphaBox, Phi.Widgets.Clock, Phi.Widgets.X11.Taskbar
+                     Phi.Widgets.AlphaBox, Phi.Widgets.Clock
-		     -- , Phi.Widgets.Systray
+		     -- , Phi.Widgets.Taskbar, Phi.Widgets.Systray
-  other-modules:     Phi.X11.AtomList, Phi.Bindings.Cairo, Phi.X11.Atoms, Phi.X11.Util
+  other-modules:     Phi.X11.Util, Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.XCB
   include-dirs:      include
   hs-source-dirs:    lib
-  pkgconfig-depends: cairo >= 1.2.0, cairo-xcb
+  extra-libraries:   X11
+  pkgconfig-depends: xcb, cairo >= 1.2.0, cairo-xcb
   ghc-options:       -fspec-constr-count=16 -threaded
 
-executable phi-systray-helper
+executable Phi
-  build-depends:     base >= 4, template-haskell, mtl, xhb >= 0.5, xhb-xcb
-  hs-source-dirs:    src, lib
-  main-is:           SystrayHelper.hs
-  other-modules:     Phi.X11.AtomList, Phi.X11.Atoms, Phi.X11.Util
-  ghc-options:       -threaded
-
-executable phi
   build-depends:     base >= 4, phi
   hs-source-dirs:    src
   main-is:           Phi.hs
-  ghc-options:       -threaded 

src/Phi.hs

@@ -6,13 +6,13 @@ import Phi.X11
 
 import Phi.Widgets.AlphaBox
 import Phi.Widgets.Clock
-import Phi.Widgets.X11.Taskbar
+--import Phi.Widgets.Taskbar
---import Phi.Widgets.X11.Systray
+--import Phi.Widgets.Systray
 
 
 main :: IO ()
 main = do
-  runPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom } $ 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,11 +46,11 @@ main = do
                                                 , desktopStyle = Just (normalDesktopStyle, currentDesktopStyle)
                                                 }
       
-      --theSystray = systray
+      theSystray = systray-}
       
-      theClock = clock defaultClockConfig { clockFormat = "<span font='Sans 7'>%R</span>\n<span font='Sans 6'>%a, %b %d</span>"
+      theClock = clock defaultClockConfig { clockFormat = "<span font='Sans 8'>%R</span>\n<span font='Sans 6'>%A %d %B</span>"
-                                          , lineSpacing = (-1)
+                                          , lineSpacing = (-3)
-                                          , clockSize = 55
+                                          , clockSize = 75
                                           }
-      brightBorder :: (Widget w s c d) => w -> Border w s c d
+      brightBorder :: (Widget w s c) => w -> Border w s c
       brightBorder = border normalDesktopBorder

src/SystrayHelper.hs

@@ -1,106 +0,0 @@
-import Control.Concurrent
-import Control.Monad
-import Control.Monad.State.Strict
-
-import Data.Word
-import Data.Maybe
-
-import Graphics.XHB
-import Graphics.XHB.Connection.XCB
-import Graphics.XHB.Gen.Xproto
-
-import System.Exit
-
-import Phi.X11.Atoms
-import Phi.X11.Util
-
-
-sYSTEM_TRAY_REQUEST_DOCK :: Word32
-sYSTEM_TRAY_REQUEST_DOCK = 0
-
-sYSTEM_TRAY_BEGIN_MESSAGE :: Word32
-sYSTEM_TRAY_BEGIN_MESSAGE = 1
-
-sYSTEM_TRAY_CANCEL_MESSAGE :: Word32
-sYSTEM_TRAY_CANCEL_MESSAGE = 2
-
-xEMBED_EMBEDDED_NOTIFY :: Word32
-xEMBED_EMBEDDED_NOTIFY = 0
-
-
-data SystrayState = SystrayState
-                    { systrayIcons :: [(WINDOW, WINDOW)]
-                    }
-
-
-main :: IO ()
-main = do
-  conn <- liftM fromJust connect
-  forkIO $ receiveErrors conn
-  
-  atoms <- initAtoms conn
-  
-  let screen = (roots_Setup . connectionSetup $ conn) !! connectionScreen conn
-  
-  (xembedWin, systrayWin) <- initSystray conn atoms screen
-  
-  execStateT (runSystray xembedWin systrayWin) $ SystrayState []
-  
-  return ()
-
-receiveErrors :: Connection -> IO ()
-receiveErrors conn =
-  forever $ waitForError conn >>= putStrLn . ("XHB error: " ++) . show
-
-initSystray :: Connection -> Atoms -> SCREEN -> IO (WINDOW, WINDOW)
-initSystray conn atoms screen = do
-  currentSystrayWin <- getSelectionOwner conn (atom_NET_SYSTEM_TRAY_SCREEN atoms) >>= getReply' "initSystray: getSelectionOwner failed"
-  when (currentSystrayWin /= fromXid xidNone) $ do
-    putStrLn "phi-systray-helper: another systray is running."
-    exitFailure
-  
-  currentSystrayHelperWin <- getSelectionOwner conn (atomPHI_SYSTRAY_HELPER atoms) >>= getReply' "initSystray: getSelectionOwner failed"
-  when (currentSystrayHelperWin /= fromXid xidNone) $ do
-    putStrLn "phi-systray-helper: another systray helper is running."
-    exitFailure
-
-  let rootwin = root_SCREEN screen
-      depth = root_depth_SCREEN screen
-      visual = root_visual_SCREEN screen
-  xembedWin <- newResource conn
-  createWindow conn $ MkCreateWindow depth xembedWin rootwin (-1) (-1) 1 1 0 WindowClassInputOutput visual emptyValueParam
-  
-  -- orient horizontally
-  changeProperty32 conn PropModeReplace xembedWin (atom_NET_SYSTEM_TRAY_ORIENTATION atoms) (atomCARDINAL atoms) [0]
-  
-  -- set visual
-  changeProperty32 conn PropModeReplace xembedWin (atom_NET_SYSTEM_TRAY_VISUAL atoms) (atomVISUALID atoms) [fromIntegral visual]
-  
-  setSelectionOwner conn $ MkSetSelectionOwner xembedWin (atom_NET_SYSTEM_TRAY_SCREEN atoms) 0
-  systrayWin <- getSelectionOwner conn (atom_NET_SYSTEM_TRAY_SCREEN atoms) >>= getReply' "initSystray: getSelectionOwner failed"
-  when (systrayWin /= xembedWin) $ do
-    destroyWindow conn xembedWin
-    putStrLn $ "phi-systray-helper: can't initialize systray."
-    exitFailure
-  
-  systrayWin <- newResource conn
-  createWindow conn $ MkCreateWindow depth systrayWin rootwin (-1) (-1) 1 1 0 WindowClassInputOutput visual emptyValueParam
-  
-  setSelectionOwner conn $ MkSetSelectionOwner systrayWin (atomPHI_SYSTRAY_HELPER atoms) 0
-  systrayHelperWin <- getSelectionOwner conn (atomPHI_SYSTRAY_HELPER atoms) >>= getReply' "initSystray: getSelectionOwner failed"
-  when (systrayHelperWin /= systrayWin) $ do
-    destroyWindow conn systrayHelperWin
-    destroyWindow conn xembedWin
-    putStrLn $ "phi-systray-helper: can't initialize systray helper."
-    exitFailure
-
-  sendEvent conn $ MkSendEvent False rootwin [EventMaskStructureNotify] $
-    serializeClientMessage $ MkClientMessageEvent 32 rootwin (atomMANAGER atoms) $
-    ClientData32 [0, fromXid . toXid $ atom_NET_SYSTEM_TRAY_SCREEN atoms, fromXid . toXid $ xembedWin, 0, 0]
-  
-  return (xembedWin, systrayWin)
-
-
-runSystray :: WINDOW -> WINDOW -> StateT SystrayState IO ()
-runSystray xembedWin systrayWin = do
-  return ()