Compare commits
No commits in common. "3e1ca8091269fcd30a7d89cbe2f9d68d7447b0fc" and "15d9304e052d2e5d4416e54a6fd24fbd0a252964" have entirely different histories.
3e1ca80912
...
15d9304e05
16 changed files with 451 additions and 616 deletions
|
|
@ -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
|
||||
92
lib/Phi/Bindings/XCB.hsc
Normal file
92
lib/Phi/Bindings/XCB.hsc
Normal file
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
, rect_y :: !Int
|
||||
, rect_width :: !Int
|
||||
, rect_height :: !Int
|
||||
} deriving (Show, Eq)
|
||||
data Display = Display !Connection !Atoms
|
||||
|
||||
class Display d where
|
||||
type Window d :: *
|
||||
newtype XEvent = XEvent SomeEvent deriving Typeable
|
||||
|
||||
instance Show XEvent where
|
||||
show _ = "XEvent (..)"
|
||||
|
||||
|
||||
unionArea :: Rectangle -> Rectangle -> Int
|
||||
unionArea a b = uw*uh
|
||||
withDisplay :: MonadIO m => Display -> (Connection -> m a) -> m a
|
||||
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
|
||||
Rectangle bx1 by1 bw bh = b
|
||||
MkRECTANGLE ax1 ay1 aw ah = a
|
||||
MkRECTANGLE bx1 by1 bw bh = b
|
||||
|
||||
ax2 = ax1 + aw
|
||||
ay2 = ay1 + ah
|
||||
ax2 = ax1 + fromIntegral aw
|
||||
ay2 = ay1 + fromIntegral ah
|
||||
|
||||
bx2 = bx1 + bw
|
||||
by2 = by1 + bh
|
||||
bx2 = bx1 + fromIntegral bw
|
||||
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
|
||||
initWidget :: w -> Phi -> d -> [(Rectangle, Window d)] -> IO s
|
||||
class Eq s => Widget w s c | w -> s, w -> c where
|
||||
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 ())
|
||||
-> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, Rectangle) Surface
|
||||
createRenderCache :: (s -> Int -> Int -> Int -> Int -> RECTANGLE -> Render ())
|
||||
-> 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
|
||||
deriving instance Eq (CompoundState a sa ca b sb cb d)
|
||||
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)
|
||||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}
|
||||
|
||||
module Phi.Widgets.X11.Systray ( systray
|
||||
) where
|
||||
module Phi.Widgets.Systray ( systray
|
||||
) 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
|
||||
|
|
@ -1,17 +1,16 @@
|
|||
{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}
|
||||
|
||||
module Phi.Widgets.X11.Taskbar ( IconStyle
|
||||
, idIconStyle
|
||||
, desaturateIconStyle
|
||||
, TaskStyle(..)
|
||||
, DesktopStyle(..)
|
||||
, TaskbarConfig(..)
|
||||
, defaultTaskbarConfig
|
||||
, Taskbar
|
||||
, taskbar
|
||||
) where
|
||||
module Phi.Widgets.Taskbar ( IconStyle
|
||||
, idIconStyle
|
||||
, desaturateIconStyle
|
||||
, TaskStyle(..)
|
||||
, DesktopStyle(..)
|
||||
, TaskbarConfig(..)
|
||||
, defaultTaskbarConfig
|
||||
, Taskbar
|
||||
, taskbar
|
||||
) 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.XHB.Gen.Xproto
|
||||
import Graphics.X11.Xlib (Window)
|
||||
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]
|
||||
, taskbarActiveWindow :: !WINDOW
|
||||
data TaskbarState = TaskbarState { taskbarScreens :: ![Xlib.Rectangle]
|
||||
, taskbarActiveWindow :: !Window
|
||||
, taskbarDesktopCount :: !Int
|
||||
, taskbarCurrentDesktop :: !Int
|
||||
, taskbarDesktopNames :: ![String]
|
||||
, taskbarWindows :: ![WINDOW]
|
||||
, taskbarWindowStates :: !(M.Map WINDOW WindowState)
|
||||
, taskbarWindows :: ![Window]
|
||||
, 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 x11 = do
|
||||
(windows, states) <- liftIO $ do
|
||||
(windows, states) <- getWindowStates x11 M.empty
|
||||
desktopCount <- getDesktopCount x11
|
||||
current <- getCurrentDesktop x11
|
||||
names <- getDesktopNames x11
|
||||
activeWindow <- getActiveWindow x11
|
||||
taskbarRunner :: Phi -> Display -> IO ()
|
||||
taskbarRunner phi dispvar = do
|
||||
(windows, states) <- liftIO $ withDisplay dispvar $ \disp -> do
|
||||
(windows, states) <- getWindowStates disp (getAtoms dispvar) M.empty
|
||||
desktopCount <- getDesktopCount disp (getAtoms dispvar)
|
||||
current <- getCurrentDesktop disp (getAtoms dispvar)
|
||||
names <- getDesktopNames disp (getAtoms dispvar)
|
||||
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) ->
|
||||
handleEvent phi x11 event
|
||||
Just event ->
|
||||
handleEvent phi dispvar event
|
||||
_ ->
|
||||
return ()
|
||||
|
||||
|
||||
handleEvent :: Phi -> X11 -> SomeEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO ()
|
||||
handleEvent phi x11 event =
|
||||
case (fromEvent event) of
|
||||
Just e -> handlePropertyNotifyEvent phi x11 e
|
||||
Nothing -> case (fromEvent event) of
|
||||
Just e -> handleConfigureNotifyEvent phi x11 e
|
||||
Nothing -> return ()
|
||||
|
||||
handlePropertyNotifyEvent :: Phi -> X11 -> PropertyNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO ()
|
||||
handlePropertyNotifyEvent phi x11 MkPropertyNotifyEvent {atom_PropertyNotifyEvent = atom, window_PropertyNotifyEvent = window} = do
|
||||
let atoms = x11Atoms x11
|
||||
rootwin = root_SCREEN . x11Screen $ x11
|
||||
|
||||
when (elem atom $ map ($ atoms) [ atom_NET_ACTIVE_WINDOW
|
||||
, 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
|
||||
handleEvent :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState) IO ()
|
||||
handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do
|
||||
let atoms = getAtoms dispvar
|
||||
|
||||
when (elem atom $ Xlib.wM_NAME : map ($ atoms) [ atom_NET_ACTIVE_WINDOW
|
||||
, atom_NET_NUMBER_OF_DESKTOPS
|
||||
, atom_NET_CURRENT_DESKTOP
|
||||
, atom_NET_DESKTOP_NAMES
|
||||
, atom_NET_CLIENT_LIST
|
||||
, atom_NET_WM_ICON
|
||||
, atom_NET_WM_NAME
|
||||
, atom_NET_WM_DESKTOP
|
||||
, atom_NET_WM_STATE
|
||||
]) $ withDisplay dispvar $ \disp -> do
|
||||
let rootwin = Xlib.defaultRootWindow disp
|
||||
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 ()
|
||||
|
||||
|
||||
handleConfigureNotifyEvent :: Phi -> X11 -> ConfigureNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO ()
|
||||
handleConfigureNotifyEvent phi x11 MkConfigureNotifyEvent {window_ConfigureNotifyEvent = window} = do
|
||||
let conn = x11Connection x11
|
||||
handleEvent phi dispvar XExtras.ConfigureEvent {XExtras.ev_window = window} = do
|
||||
(windows, windowStates) <- get
|
||||
when (elem window windows) $ do
|
||||
let geom = fmap windowGeometry . M.lookup window $ windowStates
|
||||
geom' <- liftIO $ getWindowGeometry x11 window
|
||||
when (elem window windows) $ withDisplay dispvar $ \disp -> do
|
||||
let geom = fmap windowGeometry . M.lookup window $ windowStates
|
||||
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
|
||||
getCurrentDesktop x11 =
|
||||
liftM (fromIntegral . fromMaybe (-1) . join . fmap listToMaybe) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_CURRENT_DESKTOP . x11Atoms $ x11)
|
||||
getDesktopCount :: Xlib.Display -> Atoms -> IO Int
|
||||
getDesktopCount disp atoms =
|
||||
liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_NUMBER_OF_DESKTOPS atoms) $ Xlib.defaultRootWindow disp
|
||||
|
||||
getDesktopNames :: X11 -> IO [String]
|
||||
getDesktopNames x11 =
|
||||
liftM (map (decode . map fromIntegral) . break' . fromMaybe []) $ getProperty8 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_DESKTOP_NAMES . x11Atoms $ x11)
|
||||
getCurrentDesktop :: Xlib.Display -> Atoms -> IO Int
|
||||
getCurrentDesktop disp atoms =
|
||||
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 x11 =
|
||||
liftM (fromXid . toXid . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_ACTIVE_WINDOW . x11Atoms $ x11)
|
||||
getActiveWindow :: Xlib.Display -> Atoms -> IO Window
|
||||
getActiveWindow disp atoms =
|
||||
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 x11 windowStates = do
|
||||
windows <- getWindowList x11
|
||||
getWindowStates :: Xlib.Display -> Atoms -> M.Map Window WindowState -> IO ([Window], M.Map Window WindowState)
|
||||
getWindowStates disp atoms windowStates = do
|
||||
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])]
|
||||
windowState <- getWindowState x11 window
|
||||
Xlib.selectInput disp window $ Xlib.propertyChangeMask .|. Xlib.structureNotifyMask
|
||||
windowState <- getWindowState disp atoms window
|
||||
return (window, windowState)
|
||||
|
||||
getWindowState :: X11 -> WINDOW -> IO WindowState
|
||||
getWindowState x11 window = do
|
||||
(name, workspace, visible) <- getWindowInfo x11 window
|
||||
icons <- getWindowIcons x11 window
|
||||
geom <- getWindowGeometry x11 window
|
||||
getWindowState :: Xlib.Display -> Atoms -> Window -> IO WindowState
|
||||
getWindowState disp atoms window = do
|
||||
(name, workspace, visible) <- getWindowInfo disp atoms window
|
||||
icons <- getWindowIcons disp atoms 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 x11 window = do
|
||||
let conn = x11Connection x11
|
||||
atoms = x11Atoms x11
|
||||
netwmname <- liftM (fmap (decode . map fromIntegral)) $ getProperty8 conn window (atom_NET_WM_NAME atoms)
|
||||
getWindowInfo :: Xlib.Display -> Atoms -> Window -> IO (String, Int, Bool)
|
||||
getWindowInfo disp atoms window = do
|
||||
netwmname <- liftM (fmap (decode . map fromIntegral)) $ XExtras.getWindowProperty8 disp (atom_NET_WM_NAME atoms) window
|
||||
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)
|
||||
visible <- showWindow conn atoms window
|
||||
workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_DESKTOP 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 x11 window = getProperty32 (x11Connection x11) window (atom_NET_WM_ICON . x11Atoms $ x11) >>= readIcons . fromMaybe []
|
||||
getWindowIcons :: Xlib.Display -> Atoms -> Window -> IO [Icon]
|
||||
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 x11 window =
|
||||
getGeometry (x11Connection x11) (fromXid . toXid $ window) >>= getReply >>=
|
||||
return . ((const $ Rectangle 0 0 0 0) ||| (\(MkGetGeometryReply _ _ x y width height _) -> Rectangle (fi x) (fi y) (fi width) (fi height)))
|
||||
where
|
||||
fi :: (Integral a, Num b) => a -> b
|
||||
fi = fromIntegral
|
||||
getWindowGeometry :: Xlib.Display -> Window -> IO Xlib.Rectangle
|
||||
getWindowGeometry disp window = flip catch (\_ -> return $ Xlib.Rectangle 0 0 0 0) $ do
|
||||
(_, _, _, width, height, _, _) <- Xlib.getGeometry disp window
|
||||
(ret, x, y, _) <- Xlib.translateCoordinates disp window (Xlib.defaultRootWindow disp) 0 0
|
||||
|
||||
return $ if ret then Xlib.Rectangle x y width height else Xlib.Rectangle 0 0 0 0
|
||||
|
||||
|
||||
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)
|
||||
windowType <- liftM (fromMaybe (atom_NET_WM_WINDOW_TYPE_NORMAL atoms) . fmap (fromXid . toXid) . join . fmap listToMaybe) $
|
||||
getProperty32 conn window (atom_NET_WM_STATE atoms)
|
||||
showWindow :: Xlib.Display -> Atoms -> Window -> IO Bool
|
||||
showWindow disp atoms window = do
|
||||
states <- liftM (map fromIntegral . fromMaybe []) $ XExtras.getWindowProperty32 disp (atom_NET_WM_STATE atoms) window
|
||||
transientForHint <- XExtras.getTransientForHint disp window
|
||||
windowType <- liftM (fromMaybe (atom_NET_WM_WINDOW_TYPE_NORMAL atoms) . fmap fromIntegral . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_STATE atoms) window
|
||||
|
||||
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 x11 = liftM (map (fromXid . toXid) . join . maybeToList) $ getProperty32 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_CLIENT_LIST . x11Atoms $ x11)
|
||||
getWindowList :: Xlib.Display -> Atoms -> IO [Window]
|
||||
getWindowList disp atoms = liftM (map fromIntegral . join . maybeToList) $ XExtras.getWindowProperty32 disp (atom_NET_CLIENT_LIST atoms) $ Xlib.defaultRootWindow disp
|
||||
|
||||
taskbar :: TaskbarConfig -> Taskbar
|
||||
taskbar = Taskbar
|
||||
353
lib/Phi/X11.hs
353
lib/Phi/X11.hs
|
|
@ -1,17 +1,13 @@
|
|||
{-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification, TypeFamilies, FlexibleContexts, DeriveDataTypeable #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification #-}
|
||||
|
||||
module Phi.X11 ( X11(..)
|
||||
, XEvent(..)
|
||||
, XMessage(..)
|
||||
, XConfig(..)
|
||||
module Phi.X11 ( XConfig(..)
|
||||
, defaultXConfig
|
||||
, runPhi
|
||||
) where
|
||||
|
||||
import Graphics.XHB hiding (Window)
|
||||
import Graphics.XHB.Connection.XCB
|
||||
import Graphics.XHB
|
||||
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 Phi.Widget hiding (handleMessage)
|
||||
import qualified Phi.Widget as Widget
|
||||
import Phi.Widget hiding (Display, handleMessage)
|
||||
import Phi.X11.Atoms
|
||||
|
||||
|
||||
data X11 = X11 { x11Connection :: !Connection
|
||||
, 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 XConfig = XConfig { phiXScreenInfo :: !(Connection -> IO [RECTANGLE])
|
||||
}
|
||||
|
||||
data PhiState w s c = (Widget w s c X11) => PhiState { phiRootImage :: !Surface
|
||||
, phiPanels :: ![PanelState w s c]
|
||||
, phiRepaint :: !Bool
|
||||
, phiShutdown :: !Bool
|
||||
, phiShutdownHold :: !Int
|
||||
, phiWidgetState :: !s
|
||||
}
|
||||
data PhiState w s c = (Widget.Widget w s c) => PhiState { phiRootImage :: !Surface
|
||||
, phiPanels :: ![PanelState w s c]
|
||||
, phiRepaint :: !Bool
|
||||
, phiShutdown :: !Bool
|
||||
, phiShutdownHold :: !Int
|
||||
, phiWidgetState :: !s
|
||||
}
|
||||
|
||||
data PanelState w s c = (Widget w s c X11) => PanelState { panelWindow :: !WINDOW
|
||||
, panelPixmap :: !PIXMAP
|
||||
, panelArea :: !Rectangle
|
||||
, panelScreenArea :: !Rectangle
|
||||
, panelWidgetCache :: !c
|
||||
}
|
||||
data PanelState w s c = (Widget.Widget w s c) => PanelState { panelWindow :: !WINDOW
|
||||
, panelPixmap :: !PIXMAP
|
||||
, panelArea :: !RECTANGLE
|
||||
, panelScreenArea :: !RECTANGLE
|
||||
, 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 x11 = do
|
||||
let conn = x11Connection x11
|
||||
screen = x11Screen x11
|
||||
getScreenInfo :: Connection -> IO [RECTANGLE]
|
||||
getScreenInfo conn = do
|
||||
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" >>=
|
||||
return . (\(MkGetGeometryReply _ _ x y w h _) -> [Rectangle (fi x) (fi y) (fi w) (fi h)])
|
||||
Left _ -> getGeometry conn (fromXid . toXid $ getRoot conn) >>= getReply' "getScreenInfo: getGeometry failed" >>=
|
||||
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)
|
||||
|
||||
fi :: (Integral a, Num b) => a -> b
|
||||
fi = fromIntegral
|
||||
screenInfoToRect (MkScreenInfo x y w h) = MkRECTANGLE x y w h
|
||||
|
||||
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 x11
|
||||
panelWindows <- mapM (createPanelWindow conn screen config) screens
|
||||
|
||||
let widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1)
|
||||
screens <- liftIO $ phiXScreenInfo xconfig conn
|
||||
panelWindows <- mapM (createPanelWindow conn config) screens
|
||||
let dispvar = Widget.Display conn atoms
|
||||
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
|
||||
|
||||
forM_ panels $ liftIO . mapWindow conn . panelWindow
|
||||
|
||||
liftIO $ do
|
||||
forkIO $ receiveEvents phi conn
|
||||
forkIO $ receiveErrors phi conn
|
||||
liftIO $ forkIO $ receiveEvents phi conn
|
||||
|
||||
forever $ do
|
||||
available <- messageAvailable phi
|
||||
repaint <- gets phiRepaint
|
||||
when (not available && repaint) $ liftIO $ threadDelay 20000
|
||||
|
||||
available <- messageAvailable phi
|
||||
when (not available && repaint) $ do
|
||||
updatePanels
|
||||
modify $ \state -> state {phiRepaint = False}
|
||||
unless available $ do
|
||||
repaint <- gets phiRepaint
|
||||
when repaint $ do
|
||||
updatePanels conn xcb
|
||||
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 m = do
|
||||
handleMessage :: (Widget w s c) => Connection -> XCB.Connection -> Message -> PhiX w s c ()
|
||||
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 event =
|
||||
handleEvent :: (Widget w s c) => Connection -> XCB.Connection -> SomeEvent -> PhiX w s c ()
|
||||
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 MkPropertyNotifyEvent { atom_PropertyNotifyEvent = atom } = do
|
||||
handlePropertyNotifyEvent :: (Widget w s c) => Connection -> XCB.Connection -> PropertyNotifyEvent -> PhiX w s c ()
|
||||
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 MkConfigureNotifyEvent { window_ConfigureNotifyEvent = window } = do
|
||||
x11 <- asks phiX11
|
||||
let conn = x11Connection x11
|
||||
screen = x11Screen x11
|
||||
rootWindow = root_SCREEN screen
|
||||
when (window == rootWindow) $ do
|
||||
phi <- asks phiPhi
|
||||
xconfig <- asks phiXConfig
|
||||
config <- asks phiPanelConfig
|
||||
panels <- gets phiPanels
|
||||
let screens = map panelScreenArea panels
|
||||
screens' <- liftIO $ phiXScreenInfo xconfig x11
|
||||
handleConfigureNotifyEvent :: (Widget w s c) => Connection -> ConfigureNotifyEvent -> PhiX w s c ()
|
||||
handleConfigureNotifyEvent conn MkConfigureNotifyEvent { window_ConfigureNotifyEvent = window } | window == getRoot conn = do
|
||||
phi <- asks phiPhi
|
||||
xconfig <- asks phiXConfig
|
||||
config <- asks phiPanelConfig
|
||||
panels <- gets phiPanels
|
||||
let screens = map panelScreenArea panels
|
||||
screens' <- liftIO $ phiXScreenInfo xconfig conn
|
||||
|
||||
when (screens /= screens') $ do
|
||||
liftIO $ do
|
||||
mapM_ (freePixmap conn . panelPixmap) panels
|
||||
mapM_ (destroyWindow conn . panelWindow) $ drop (length screens') panels
|
||||
|
||||
when (screens /= screens') $ do
|
||||
liftIO $ do
|
||||
mapM_ (freePixmap conn . panelPixmap) panels
|
||||
mapM_ (destroyWindow conn . panelWindow) $ drop (length screens') panels
|
||||
|
||||
let panelsScreens = zip screens' $ map Just panels ++ repeat Nothing
|
||||
|
||||
panels' <- forM panelsScreens $ \(screenarea, mpanel) ->
|
||||
case mpanel of
|
||||
Just panel -> do
|
||||
let rect = panelBounds config screenarea
|
||||
win = panelWindow panel
|
||||
|
||||
liftIO $ configureWindow conn $ MkConfigureWindow win (toMask [ConfigWindowX, ConfigWindowY, ConfigWindowWidth, ConfigWindowHeight]) $
|
||||
toValueParam [ (ConfigWindowX, fromIntegral $ rect_x rect)
|
||||
, (ConfigWindowY, fromIntegral $ rect_y rect)
|
||||
, (ConfigWindowWidth, fromIntegral $ rect_width rect)
|
||||
, (ConfigWindowHeight, fromIntegral $ rect_height rect)
|
||||
]
|
||||
|
||||
panel' <- createPanel win screenarea
|
||||
setPanelProperties panel'
|
||||
|
||||
return panel'
|
||||
Nothing -> do
|
||||
win <- liftIO $ createPanelWindow conn screen config screenarea
|
||||
panel <- createPanel win screenarea
|
||||
setPanelProperties panel
|
||||
liftIO $ mapWindow conn $ panelWindow panel
|
||||
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)
|
||||
let panelsScreens = zip screens' $ map Just panels ++ repeat Nothing
|
||||
|
||||
panels' <- forM panelsScreens $ \(screen, mpanel) ->
|
||||
case mpanel of
|
||||
Just panel -> do
|
||||
let rect = panelBounds config screen
|
||||
win = panelWindow panel
|
||||
|
||||
liftIO $ configureWindow conn win $ toValueParam [ (ConfigWindowX, fromIntegral $ x_RECTANGLE rect)
|
||||
, (ConfigWindowY, fromIntegral $ y_RECTANGLE rect)
|
||||
, (ConfigWindowWidth, fromIntegral $ width_RECTANGLE rect)
|
||||
, (ConfigWindowHeight, fromIntegral $ height_RECTANGLE rect)
|
||||
]
|
||||
|
||||
panel' <- createPanel conn win screen
|
||||
setPanelProperties conn panel'
|
||||
|
||||
return panel'
|
||||
Nothing -> do
|
||||
win <- liftIO $ createPanelWindow conn config screen
|
||||
panel <- createPanel conn win screen
|
||||
setPanelProperties conn panel
|
||||
liftIO $ mapWindow conn $ panelWindow panel
|
||||
return panel
|
||||
|
||||
modify $ \state -> state { phiPanels = panels' }
|
||||
|
||||
sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels'
|
||||
sendMessage phi Repaint
|
||||
|
||||
|
||||
receiveEvents :: Phi -> Connection -> IO ()
|
||||
receiveEvents phi conn =
|
||||
forever $ receiveEvents' conn >>= sendMessages phi
|
||||
receiveEvents phi conn = do
|
||||
forever $ waitForEvent conn >>= sendMessage phi . XEvent
|
||||
|
||||
receiveErrors :: Phi -> Connection -> IO ()
|
||||
receiveErrors phi conn =
|
||||
forever $ waitForError conn >>= putStrLn . ("XHB error: " ++) . show
|
||||
|
||||
updatePanels :: (Widget w s c X11) => PhiX w s c ()
|
||||
updatePanels = do
|
||||
X11 conn _ screen <- asks phiX11
|
||||
updatePanels :: (Widget w s c) => Connection -> XCB.Connection -> PhiX w s c ()
|
||||
updatePanels conn xcb = do
|
||||
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
|
||||
clearArea conn $ withDimension area $ MkClearArea True (panelWindow panel) 0 0
|
||||
flush conn
|
||||
liftIO $ withDimension area $ XCB.clearArea xcb True (panelWindow panel) 0 0
|
||||
|
||||
return $ panel { panelWidgetCache = cache' }
|
||||
|
||||
modify $ \state -> state { phiPanels = panels' }
|
||||
|
||||
|
||||
updateRootImage :: PhiX w s c ()
|
||||
updateRootImage = do
|
||||
X11 conn atoms screen <- asks phiX11
|
||||
updateRootImage :: Connection -> XCB.Connection -> PhiX w s c ()
|
||||
updateRootImage conn xcb = do
|
||||
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 win screenRect = do
|
||||
(conn, screen) <- asks $ (x11Connection &&& x11Screen) . phiX11
|
||||
createPanel :: (Widget w s c) => Connection -> WINDOW -> RECTANGLE -> PhiX w s c (PanelState w s c)
|
||||
createPanel conn win screenRect = do
|
||||
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 conn screen config screenRect = do
|
||||
createPanelWindow :: Connection -> Panel.PanelConfig -> RECTANGLE -> IO WINDOW
|
||||
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 panel = do
|
||||
(conn, atoms) <- asks $ (x11Connection &&& x11Atoms) . phiX11
|
||||
setPanelProperties :: Connection -> PanelState w s c -> PhiX w s c ()
|
||||
setPanelProperties conn panel = do
|
||||
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 panel = do
|
||||
X11 conn atoms screen <- asks phiX11
|
||||
setStruts :: Connection -> PanelState w s c -> PhiX w s c ()
|
||||
setStruts conn panel = do
|
||||
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 8 = (fromIntegral $ rect_x area)
|
||||
makeTopStruts 9 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1
|
||||
makeTopStruts 2 = (fromIntegral $ y_RECTANGLE area) + (fromIntegral $ height_RECTANGLE area)
|
||||
makeTopStruts 8 = (fromIntegral $ x_RECTANGLE area)
|
||||
makeTopStruts 9 = (fromIntegral $ x_RECTANGLE area) + (fromIntegral $ width_RECTANGLE area) - 1
|
||||
makeTopStruts _ = 0
|
||||
|
||||
makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ rect_y area)
|
||||
makeBottomStruts 10 = (fromIntegral $ rect_x area)
|
||||
makeBottomStruts 11 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1
|
||||
makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ y_RECTANGLE area)
|
||||
makeBottomStruts 10 = (fromIntegral $ x_RECTANGLE area)
|
||||
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.Bottom -> screenBounds { rect_height = Panel.panelSize config,
|
||||
rect_y = rect_y screenBounds + rect_height screenBounds - Panel.panelSize config }
|
||||
Phi.Top -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config }
|
||||
Phi.Bottom -> screenBounds { height_RECTANGLE = fromIntegral $ 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 r f = f (fromIntegral $ rect_x r) (fromIntegral $ rect_y r)
|
||||
withPosition :: (Num x, Num y) => RECTANGLE -> (x -> y -> a) -> a
|
||||
withPosition r f = f (fromIntegral $ x_RECTANGLE r) (fromIntegral $ y_RECTANGLE r)
|
||||
|
||||
withDimension :: (Num w, Num h) => Rectangle -> (w -> h -> a) -> a
|
||||
withDimension r f = f (fromIntegral $ rect_width r) (fromIntegral $ rect_height r)
|
||||
withDimension :: (Num w, Num h) => RECTANGLE -> (w -> h -> a) -> a
|
||||
withDimension r f = f (fromIntegral $ width_RECTANGLE r) (fromIntegral $ height_RECTANGLE r)
|
||||
|
|
|
|||
|
|
@ -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|])
|
||||
]
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
||||
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
|
||||
findVisualtype screen id = listToMaybe . filter ((== id) . visual_id_VISUALTYPE) . join . map visuals_DEPTH . allowed_depths_SCREEN $ screen
|
||||
22
phi.cabal
22
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.Systray
|
||||
other-modules: Phi.X11.AtomList, Phi.Bindings.Cairo, Phi.X11.Atoms, Phi.X11.Util
|
||||
Phi.Widgets.AlphaBox, Phi.Widgets.Clock
|
||||
-- , Phi.Widgets.Taskbar, Phi.Widgets.Systray
|
||||
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
|
||||
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
|
||||
executable Phi
|
||||
build-depends: base >= 4, phi
|
||||
hs-source-dirs: src
|
||||
main-is: Phi.hs
|
||||
ghc-options: -threaded
|
||||
|
|
|
|||
18
src/Phi.hs
18
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.X11.Systray
|
||||
--import Phi.Widgets.Taskbar
|
||||
--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>"
|
||||
, lineSpacing = (-1)
|
||||
, clockSize = 55
|
||||
theClock = clock defaultClockConfig { clockFormat = "<span font='Sans 8'>%R</span>\n<span font='Sans 6'>%A %d %B</span>"
|
||||
, lineSpacing = (-3)
|
||||
, 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
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
Reference in a new issue