summaryrefslogtreecommitdiffstats
path: root/lib/Phi
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Phi')
-rw-r--r--lib/Phi/Bindings/Cairo.hsc51
-rw-r--r--lib/Phi/Bindings/XCB.hsc92
-rw-r--r--lib/Phi/Widgets/X11/Taskbar.hs3
-rw-r--r--lib/Phi/X11.hs21
-rw-r--r--lib/Phi/X11/AtomList.hs7
-rw-r--r--lib/Phi/X11/Atoms.hs3
-rw-r--r--lib/Phi/X11/Util.hs16
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 01:55:48 +0100