diff options
author | Matthias Schiffer <mschiffer@universe-factory.net> | 2011-10-10 23:22:59 +0200 |
---|---|---|
committer | Matthias Schiffer <mschiffer@universe-factory.net> | 2011-10-10 23:22:59 +0200 |
commit | 33cd402ae968587d256e11004dac9ed52d1c3cc5 (patch) | |
tree | 4b86bc3d0696d8cfe63a446c86ddde87841d91d2 /lib/Phi | |
parent | 456f9fb6e6d743702fcca79f4d23e1e5f40c530d (diff) | |
download | phi-33cd402ae968587d256e11004dac9ed52d1c3cc5.tar phi-33cd402ae968587d256e11004dac9ed52d1c3cc5.zip |
Use XCB backend
Diffstat (limited to 'lib/Phi')
-rw-r--r-- | lib/Phi/Bindings/Cairo.hsc | 51 | ||||
-rw-r--r-- | lib/Phi/Bindings/XCB.hsc | 92 | ||||
-rw-r--r-- | lib/Phi/Widgets/X11/Taskbar.hs | 3 | ||||
-rw-r--r-- | lib/Phi/X11.hs | 21 | ||||
-rw-r--r-- | lib/Phi/X11/AtomList.hs | 7 | ||||
-rw-r--r-- | lib/Phi/X11/Atoms.hs | 3 | ||||
-rw-r--r-- | lib/Phi/X11/Util.hs | 16 |
7 files changed, 72 insertions, 121 deletions
diff --git a/lib/Phi/Bindings/Cairo.hsc b/lib/Phi/Bindings/Cairo.hsc new file mode 100644 index 0000000..246bc13 --- /dev/null +++ b/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 diff --git a/lib/Phi/Bindings/XCB.hsc b/lib/Phi/Bindings/XCB.hsc deleted file mode 100644 index 1beb5f2..0000000 --- a/lib/Phi/Bindings/XCB.hsc +++ /dev/null @@ -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 diff --git a/lib/Phi/Widgets/X11/Taskbar.hs b/lib/Phi/Widgets/X11/Taskbar.hs index 359fbc6..d52d600 100644 --- a/lib/Phi/Widgets/X11/Taskbar.hs +++ b/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) diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index 9b93328..af4cb0b 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -9,8 +9,7 @@ module Phi.X11 ( X11(..) ) where import Graphics.XHB hiding (Window) -import Graphics.XHB.Connection -import qualified Graphics.XHB.Connection.Open as CO +import Graphics.XHB.Connection.XCB 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 - screen = (roots_Setup . connectionSetup $ conn) !! CO.screen dispname + let screen = (roots_Setup . connectionSetup $ conn) !! connectionScreen conn 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 diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs index 0ab3372..cad753a 100644 --- a/lib/Phi/X11/AtomList.hs +++ b/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.Connection.Open +import Graphics.XHB 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|]) ] diff --git a/lib/Phi/X11/Atoms.hs b/lib/Phi/X11/Atoms.hs index 16945bf..6e69b37 100644 --- a/lib/Phi/X11/Atoms.hs +++ b/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 diff --git a/lib/Phi/X11/Util.hs b/lib/Phi/X11/Util.hs index e1daba5..07eb1cf 100644 --- a/lib/Phi/X11/Util.hs +++ b/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 |