Use XCB backend

lib/Phi/Bindings/Cairo.hsc

@@ -0,0 +1,51 @@
+{-# 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

@@ -1,92 +0,0 @@
-{-# 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 unsafe "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/Widgets/X11/Taskbar.hs

@@ -40,7 +40,6 @@ import Graphics.Rendering.Pango.Layout
 import Graphics.Rendering.Pango.Font
 
 import Graphics.XHB
-import Graphics.XHB.Connection
 import Graphics.XHB.Gen.Xproto
 
 import Codec.Binary.UTF8.String
@@ -625,7 +624,7 @@ getWindowGeometry x11 window =
       fi :: (Integral a, Num b) => a -> b
       fi = fromIntegral
 
-showWindow :: ConnectionClass c r => c -> Atoms -> WINDOW -> IO Bool
+showWindow :: ConnectionClass c => c -> Atoms -> WINDOW -> IO Bool
 showWindow conn atoms window = do
   states <- liftM (map (fromXid . toXid) . fromMaybe []) $ getProperty32 conn window (atom_NET_WM_STATE atoms)
   transientFor <- liftM (map fromIntegral . fromMaybe []) $ getProperty32 conn window (atomWM_TRANSIENT_FOR atoms)

lib/Phi/X11.hs

@@ -9,8 +9,7 @@ module Phi.X11 ( X11(..)
                ) where
 
 import Graphics.XHB hiding (Window)
-import Graphics.XHB.Connection
+import Graphics.XHB.Connection.XCB
-import qualified  Graphics.XHB.Connection.Open as CO
 import Graphics.XHB.Gen.Xinerama
 import Graphics.XHB.Gen.Xproto hiding (Window)
 
@@ -35,7 +34,7 @@ import System.Exit
 import System.Posix.Signals
 import System.Posix.Types
 
-import qualified Phi.Bindings.XCB as XCB
+import Phi.Bindings.Cairo
 
 import Phi.Phi
 import Phi.X11.Util
@@ -82,7 +81,6 @@ data PhiConfig w s c = PhiConfig { phiPhi          :: !Phi
                                  , phiPanelConfig  :: !Panel.PanelConfig
                                  , phiXConfig      :: !XConfig
                                  , phiX11          :: !X11
-                                 , phiXCB          :: !XCB.Connection
                                  , phiWidget       :: !w
                                  }
 
@@ -125,10 +123,8 @@ runPhi xconfig config widget = do
   installHandler sigQUIT (termHandler phi) Nothing
   
   conn <- liftM fromJust connect
-  xcb <- XCB.connect
   
-  let dispname = displayInfo conn
+  let screen = (roots_Setup . connectionSetup $ conn) !! connectionScreen conn
-      screen = (roots_Setup . connectionSetup $ conn) !! CO.screen dispname
 
   atoms <- initAtoms conn
   changeWindowAttributes conn (root_SCREEN screen) $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])]
@@ -150,7 +146,6 @@ runPhi xconfig config widget = do
               , phiXConfig = xconfig
               , phiPanelConfig = config
               , phiX11 = x11
-              , phiXCB = xcb
               , phiWidget = widget'
               }
     PhiState { phiRootImage = bg
@@ -319,7 +314,6 @@ receiveEvents phi conn =
 updatePanels :: (Widget w s c X11) => PhiX w s c ()
 updatePanels = do
   X11 conn _ screen <- asks phiX11
-  xcb <- asks phiXCB
   w <- asks phiWidget
   s <- gets phiWidgetState
   rootImage <- gets phiRootImage
@@ -334,7 +328,7 @@ updatePanels = do
     
     let visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
     
-    xbuffer <- liftIO $ withDimension area $ XCB.createXCBSurface xcb (fromXid . toXid $ pixmap) visualtype
+    xbuffer <- liftIO $ withDimension area $ createXCBSurface conn (fromXid . toXid $ pixmap) visualtype
     
     liftIO $ (withDimension area $ withSimilarSurface xbuffer ContentColor) $ \buffer -> do
       renderWith buffer $ do
@@ -360,7 +354,9 @@ updatePanels = do
     surfaceFinish xbuffer
     
     -- update window
-    liftIO $ withDimension area $ XCB.clearArea xcb True (panelWindow panel) 0 0
+    liftIO $ do
+      clearArea conn $ withDimension area $ MkClearArea True (panelWindow panel) 0 0
+      flush conn
         
     return $ panel { panelWidgetCache = cache' }
   
@@ -370,7 +366,6 @@ updatePanels = do
 updateRootImage :: PhiX w s c ()
 updateRootImage = do
   X11 conn atoms screen <- asks phiX11 
-  xcb <- asks phiXCB
   
   let visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
       rootwin = root_SCREEN screen
@@ -399,7 +394,7 @@ updateRootImage = do
         setSourceRGB 0 0 0
         paint
     _ -> do
-      rootSurface <- liftIO $ XCB.createXCBSurface xcb (fromXid . toXid $ pixmap) visualtype (fromIntegral pixmapWidth) (fromIntegral pixmapHeight)
+      rootSurface <- liftIO $ createXCBSurface conn (fromXid . toXid $ pixmap) visualtype (fromIntegral pixmapWidth) (fromIntegral pixmapHeight)
       
       renderWith bg $ withPatternForSurface rootSurface $ \pattern -> do
         setSource pattern

lib/Phi/X11/AtomList.hs

@@ -6,8 +6,7 @@ module Phi.X11.AtomList ( atoms
 
 import Language.Haskell.TH
 
-import Graphics.XHB.Connection
+import Graphics.XHB
-import Graphics.XHB.Connection.Open
 
 atoms :: [String]
 atoms = [ "ATOM"
@@ -51,7 +50,7 @@ atoms = [ "ATOM"
         , "_XROOTMAP_ID"
         ]
 
--- the expression must have the type (Connection -> String)
+-- the expression must have the type (ConnectionClass c => c -> String)
 specialAtoms :: [(String, Q Exp)]
-specialAtoms = [ ("_NET_SYSTEM_TRAY_SCREEN", [|("_NET_SYSTEM_TRAY_S" ++) . show . screen . displayInfo|])
+specialAtoms = [ ("_NET_SYSTEM_TRAY_SCREEN", [|("_NET_SYSTEM_TRAY_S" ++) . show . connectionScreen|])
                ]

lib/Phi/X11/Atoms.hs

@@ -10,7 +10,6 @@ import Data.List
 
 import Language.Haskell.TH
 import Graphics.XHB
-import Graphics.XHB.Connection
 import Graphics.XHB.Gen.Xproto
 
 import Phi.X11.AtomList
@@ -22,7 +21,7 @@ $(let atomsName = mkName "Atoms"
   in return [DataD [] atomsName [] [RecC atomsName fields] []]
  )
 
-initAtoms :: Connection -> IO Atoms
+initAtoms :: ConnectionClass c => c -> IO Atoms
 initAtoms conn =
   $(do
        normalAtomNames <- mapM (\atom -> do

lib/Phi/X11/Util.hs

@@ -29,7 +29,7 @@ import Graphics.XHB.Gen.Xproto
 import System.IO.Unsafe
 
 
-getReply' :: ConnectionClass c r => String -> r a -> IO a
+getReply' :: String -> Receipt a -> IO a
 getReply' m = getReply >=> return . fromRight
   where
     fromRight (Left _) = error m
@@ -60,17 +60,17 @@ castToCChar input = unsafePerformIO $
   with input $ \ptr ->
     peekArray (sizeOf input) (castPtr ptr)
 
-changeProperty8 :: ConnectionClass c r => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word8] -> IO ()
+changeProperty8 :: ConnectionClass c => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word8] -> IO ()
 changeProperty8 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 8 (genericLength propdata) propdata
 
-changeProperty16 :: ConnectionClass c r => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word16] -> IO ()
+changeProperty16 :: ConnectionClass c => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word16] -> IO ()
 changeProperty16 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 16 (genericLength propdata) (castWord16to8 propdata)
 
-changeProperty32 :: ConnectionClass c r => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word32] -> IO ()
+changeProperty32 :: ConnectionClass c => c -> PropMode -> WINDOW -> ATOM -> ATOM -> [Word32] -> IO ()
 changeProperty32 conn mode win prop proptype propdata = changeProperty conn $ MkChangeProperty mode win prop proptype 32 (genericLength propdata) (castWord32to8 propdata)
 
 
-getProperty' :: ConnectionClass c r => Word8 -> c -> WINDOW -> ATOM -> IO (Maybe [Word8])
+getProperty' :: ConnectionClass c => Word8 -> c -> WINDOW -> ATOM -> IO (Maybe [Word8])
 getProperty' format conn win prop = do
   reply <- getProperty conn (MkGetProperty False win prop (fromXid xidNone) 0 4) >>= getReply
   case reply of
@@ -84,13 +84,13 @@ 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 r => c -> WINDOW -> ATOM -> IO (Maybe [Word8])
+getProperty8 :: ConnectionClass c => c -> WINDOW -> ATOM -> IO (Maybe [Word8])
 getProperty8 = getProperty' 8
 
-getProperty16 :: ConnectionClass c r => c -> WINDOW -> ATOM -> IO (Maybe [Word16])
+getProperty16 :: ConnectionClass c => c -> WINDOW -> ATOM -> IO (Maybe [Word16])
 getProperty16 conn win prop = getProperty' 16 conn win prop >>= return . fmap castWord8to16
 
-getProperty32 :: ConnectionClass c r => c -> WINDOW -> ATOM -> IO (Maybe [Word32])
+getProperty32 :: ConnectionClass c => c -> WINDOW -> ATOM -> IO (Maybe [Word32])
 getProperty32 conn win prop = getProperty' 32 conn win prop >>= return . fmap castWord8to32
 
 

phi.cabal

@@ -12,19 +12,19 @@ build-type:          Simple
 
 
 library
-  build-depends:     base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, xhb >= 0.5, xhb-native,
+  build-depends:     base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, xhb >= 0.5, xhb-xcb,
                      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.Systray
-  other-modules:     Phi.X11.AtomList, Phi.Bindings.XCB, Phi.X11.Atoms, Phi.X11.Util
+  other-modules:     Phi.X11.AtomList, Phi.Bindings.Cairo, Phi.X11.Atoms, Phi.X11.Util
   include-dirs:      include
   hs-source-dirs:    lib
   pkgconfig-depends: xcb, cairo >= 1.2.0, cairo-xcb
   ghc-options:       -fspec-constr-count=16 -threaded
 
 executable PhiSystrayHelper
-  build-depends:     base >= 4, template-haskell, xhb >= 0.5, xhb-native
+  build-depends:     base >= 4, template-haskell, 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
@@ -34,4 +34,4 @@ executable Phi
   build-depends:     base >= 4, phi
   hs-source-dirs:    src
   main-is:           Phi.hs
-  ghc-options:       -threaded
+  ghc-options:       -threaded 

src/Phi.hs

@@ -48,9 +48,9 @@ main = do
       
       --theSystray = systray
       
-      theClock = clock defaultClockConfig { clockFormat = "<span font='Sans 8'>%R</span>\n<span font='Sans 6'>%A %d %B</span>"
+      theClock = clock defaultClockConfig { clockFormat = "<span font='Sans 8'>%R</span>\n<span font='Sans 6'>%a, %b %d</span>"
                                           , lineSpacing = (-3)
-                                          , clockSize = 75
+                                          , clockSize = 60
                                           }
       brightBorder :: (Widget w s c d) => w -> Border w s c d
       brightBorder = border normalDesktopBorder

src/SystrayHelper.hs

@@ -3,9 +3,8 @@ import Control.Monad
 import Data.Maybe
 
 import Graphics.XHB
-import Graphics.XHB.Connection
+import Graphics.XHB.Connection.XCB
 import Graphics.XHB.Gen.Xproto
-import qualified Graphics.XHB.Connection.Open as CO
 
 import System.Exit
 
@@ -31,8 +30,7 @@ main = do
   conn <- liftM fromJust connect
   atoms <- initAtoms conn
   
-  let dispname = displayInfo conn
+  let screen = (roots_Setup . connectionSetup $ conn) !! connectionScreen conn
-      screen = (roots_Setup . connectionSetup $ conn) !! CO.screen dispname
   
   xembedWindow <- initSystray conn atoms screen