Use XCB backend
This commit is contained in:
parent
456f9fb6e6
commit
33cd402ae9
10 changed files with 80 additions and 131 deletions
51
lib/Phi/Bindings/Cairo.hsc
Normal file
51
lib/Phi/Bindings/Cairo.hsc
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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|])
|
||||
]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
screen = (roots_Setup . connectionSetup $ conn) !! CO.screen dispname
|
||||
let screen = (roots_Setup . connectionSetup $ conn) !! connectionScreen conn
|
||||
|
||||
xembedWindow <- initSystray conn atoms screen
|
||||
|
||||
|
|
|
|||
Reference in a new issue