Some initial systray code
This commit is contained in:
parent
b66d6690d8
commit
0fefcaa35f
10 changed files with 213 additions and 32 deletions
|
|
@ -1,10 +1,13 @@
|
|||
{-# LANGUAGE ForeignFunctionInterface #-}
|
||||
|
||||
module Phi.Bindings.Util ( setClassHint
|
||||
, visualIDFromVisual
|
||||
, putClientMessage
|
||||
, createXlibSurface
|
||||
) where
|
||||
|
||||
|
||||
#include <X11/Xlib.h>
|
||||
#include <X11/Xutil.h>
|
||||
#include <cairo.h>
|
||||
#include <cairo-xlib.h>
|
||||
|
|
@ -14,6 +17,7 @@ import Foreign.C.String (withCString)
|
|||
import Foreign.C.Types
|
||||
import Foreign.Ptr
|
||||
import Foreign.Marshal.Alloc (alloca, allocaBytes)
|
||||
import Foreign.Marshal.Array
|
||||
import Foreign.Storable
|
||||
|
||||
import Graphics.X11.Xlib
|
||||
|
|
@ -33,6 +37,17 @@ setClassHint disp wnd hint = allocaBytes (#size XClassHint) $ \p ->
|
|||
(#poke XClassHint, res_class) p res_class
|
||||
xSetClassHint disp wnd p
|
||||
|
||||
foreign import ccall unsafe "X11/Xlib.h XVisualIDFromVisual"
|
||||
visualIDFromVisual :: Visual -> VisualID
|
||||
|
||||
putClientMessage :: XEventPtr -> Window -> Atom -> [CLong] -> IO ()
|
||||
putClientMessage event window message_type messageData = do
|
||||
setEventType event clientMessage
|
||||
(#poke XClientMessageEvent, window) event window
|
||||
(#poke XClientMessageEvent, message_type) event message_type
|
||||
(#poke XClientMessageEvent, format) event (32 :: CInt)
|
||||
pokeArray ((#ptr XClientMessageEvent, data.l) event) $ take 5 messageData
|
||||
|
||||
foreign import ccall unsafe "cairo-xlib.h cairo_xlib_surface_create"
|
||||
xlibSurfaceCreate :: Display -> Drawable -> Visual -> CInt -> CInt -> IO (Ptr Surface)
|
||||
|
||||
|
|
@ -42,3 +57,4 @@ createXlibSurface dpy drawable visual width height = do
|
|||
surface <- mkSurface surfacePtr
|
||||
manageSurface surface
|
||||
return surface
|
||||
|
||||
|
|
|
|||
|
|
@ -41,7 +41,7 @@ data BorderConfig = BorderConfig { margin :: !BorderWidth
|
|||
, padding :: !BorderWidth
|
||||
, borderColor :: !Color
|
||||
, backgroundColor :: !Color
|
||||
, cornerRadius :: !Double
|
||||
, cornerRadius :: !Int
|
||||
, borderWeight :: !Float
|
||||
} deriving Show
|
||||
|
||||
|
|
@ -60,11 +60,14 @@ instance WidgetClass Border where
|
|||
type WidgetData Border = BorderState
|
||||
initWidget (Border _ widgets) phi disp = liftM BorderState $ mapM (createWidgetState phi disp) widgets
|
||||
|
||||
minSize (Border config widgets) = sum (map (\(Widget w) -> minSize w) widgets) + borderH p + 2*bw + borderH m
|
||||
minSize (Border config _) (BorderState widgetStates) height =
|
||||
max (borderH m+2*(bw+cr)) $ sum (map (\(WidgetState {stateWidget = w, statePrivateData = priv}) -> minSize w priv height') widgetStates) + borderH p + 2*bw + borderH m
|
||||
where
|
||||
m = margin config
|
||||
bw = borderWidth config
|
||||
p = padding config
|
||||
cr = cornerRadius config
|
||||
height' = height - borderV m - 2*bw - borderV p
|
||||
|
||||
weight (Border config _) = borderWeight config
|
||||
|
||||
|
|
@ -102,7 +105,7 @@ drawBorder config dx dy w h = do
|
|||
m = margin config
|
||||
bw = borderWidth config
|
||||
p = padding config
|
||||
radius = cornerRadius config
|
||||
radius = fromIntegral $ cornerRadius config
|
||||
|
||||
x = (fromIntegral dx) + (fromIntegral $ borderLeft m) + (fromIntegral bw)/2
|
||||
y = (fromIntegral dy) + (fromIntegral $ borderTop m) + (fromIntegral bw)/2
|
||||
|
|
|
|||
|
|
@ -64,7 +64,7 @@ class Show a => WidgetClass a where
|
|||
|
||||
initWidget :: a -> Phi -> Display -> IO (WidgetData a)
|
||||
|
||||
minSize :: a -> Int
|
||||
minSize :: a -> WidgetData a -> Int -> Int
|
||||
|
||||
weight :: a -> Float
|
||||
weight _ = 0
|
||||
|
|
@ -104,7 +104,7 @@ createWidgetState phi disp (Widget w) = do
|
|||
layoutWidgets :: [WidgetState] -> Int -> Int -> Int -> Int -> [WidgetState]
|
||||
layoutWidgets widgets x y width height = snd $ mapAccumL layoutWidgetAndX x widgets
|
||||
where
|
||||
sizesum = sum $ map (\(WidgetState {stateWidget = w} ) -> nneg . minSize $ w) widgets
|
||||
sizesum = sum $ map (\(WidgetState {stateWidget = w, statePrivateData = priv} ) -> nneg $ minSize w priv height) widgets
|
||||
wsum = let wsum = sum $ map (\(WidgetState {stateWidget = w} ) -> nneg . weight $ w) widgets
|
||||
in if wsum > 0 then wsum else 1
|
||||
|
||||
|
|
@ -115,7 +115,7 @@ layoutWidgets widgets x y width height = snd $ mapAccumL layoutWidgetAndX x widg
|
|||
|
||||
layoutWidget wX state = case state of
|
||||
WidgetState {stateWidget = w, statePrivateData = priv} ->
|
||||
let wWidth = floor $ (fromIntegral $ minSize w) + (fromIntegral surplus)*(nneg $ weight w)/wsum
|
||||
let wWidth = floor $ (fromIntegral $ minSize w priv height) + (fromIntegral surplus)*(nneg $ weight w)/wsum
|
||||
priv' = layout w priv wWidth height
|
||||
in WidgetState w wX y wWidth height priv'
|
||||
|
||||
|
|
@ -145,7 +145,7 @@ instance WidgetClass Separator where
|
|||
type WidgetData Separator = ()
|
||||
initWidget _ _ _ = return ()
|
||||
|
||||
minSize (Separator s _) = s
|
||||
minSize (Separator s _) _ _ = s
|
||||
weight (Separator _ w) = w
|
||||
render _ _ _ _ _ = return ()
|
||||
|
||||
|
|
|
|||
|
|
@ -55,7 +55,7 @@ instance WidgetClass Clock where
|
|||
return $ ClockState time
|
||||
|
||||
|
||||
minSize (Clock config ) = clockSize config
|
||||
minSize (Clock config) _ _ = clockSize config
|
||||
|
||||
render (Clock config) (ClockState time) w h _ = do
|
||||
time <- liftIO getZonedTime
|
||||
|
|
|
|||
137
lib/Phi/Widgets/Systray.hs
Normal file
137
lib/Phi/Widgets/Systray.hs
Normal file
|
|
@ -0,0 +1,137 @@
|
|||
{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}
|
||||
|
||||
module Phi.Widgets.Systray ( systray
|
||||
) where
|
||||
|
||||
import Control.Concurrent
|
||||
import Control.Monad
|
||||
|
||||
import Data.Maybe
|
||||
|
||||
import Foreign.C.Types
|
||||
|
||||
import Graphics.X11.Xlib hiding (Display)
|
||||
import qualified Graphics.X11.Xlib as Xlib
|
||||
import Graphics.X11.Xlib.Extras
|
||||
|
||||
import Phi.Bindings.Util
|
||||
|
||||
import Phi.Phi
|
||||
import Phi.Types
|
||||
import Phi.Widget
|
||||
import Phi.X11.Atoms
|
||||
|
||||
|
||||
data SystrayIconState = SystrayIconState deriving Show
|
||||
|
||||
data SystrayState = SystrayState [SystrayIconState] deriving Show
|
||||
|
||||
data Systray = Systray deriving Show
|
||||
|
||||
|
||||
instance WidgetClass Systray where
|
||||
type WidgetData Systray = SystrayState
|
||||
|
||||
initWidget (Systray) phi dispvar = do
|
||||
forkIO $ systrayRunner phi dispvar
|
||||
|
||||
return $ SystrayState []
|
||||
|
||||
minSize _ (SystrayState icons) height = (length icons)*height
|
||||
weight _ = 0
|
||||
|
||||
render Systray (SystrayState icons) w h screen = do
|
||||
return ()
|
||||
|
||||
|
||||
systrayRunner :: Phi -> Display -> IO ()
|
||||
systrayRunner phi dispvar = do
|
||||
let atoms = getAtoms dispvar
|
||||
initSuccess <- withDisplay dispvar $ flip initSystray atoms
|
||||
|
||||
case initSuccess of
|
||||
Just xembedWindow -> forever $ do
|
||||
m <- receiveMessage phi
|
||||
case (fromMessage m) of
|
||||
Just event ->
|
||||
handleEvent event phi dispvar xembedWindow
|
||||
_ ->
|
||||
return ()
|
||||
Nothing ->
|
||||
return ()
|
||||
|
||||
|
||||
initSystray :: Xlib.Display -> Atoms -> IO (Maybe Window)
|
||||
initSystray disp atoms = do
|
||||
currentSystrayWin <- xGetSelectionOwner disp $ atom_NET_SYSTEM_TRAY_SCREEN atoms
|
||||
|
||||
if currentSystrayWin /= 0 then do
|
||||
pid <- liftM (fromMaybe "" . fmap (\pid -> " (pid" ++ show (fromIntegral pid :: CUShort) ++ ")") . join . fmap listToMaybe) $
|
||||
getWindowProperty16 disp (atom_NET_WM_PID atoms) currentSystrayWin
|
||||
|
||||
putStrLn $ "Phi: another systray is running." ++ pid
|
||||
|
||||
return Nothing
|
||||
else do
|
||||
xembedWin <- createSimpleWindow disp (defaultRootWindow disp) (-1) (-1) 1 1 0 0 0
|
||||
|
||||
-- orient horizontally
|
||||
changeProperty32 disp xembedWin (atom_NET_SYSTEM_TRAY_ORIENTATION atoms) cARDINAL propModeReplace [0]
|
||||
|
||||
-- set visual
|
||||
let rootwin = defaultRootWindow disp
|
||||
screen = defaultScreen disp
|
||||
visual = defaultVisual disp screen
|
||||
visualID = visualIDFromVisual visual
|
||||
changeProperty32 disp xembedWin (atom_NET_SYSTEM_TRAY_VISUAL atoms) vISUALID propModeReplace [fromIntegral visualID]
|
||||
|
||||
xSetSelectionOwner disp (atom_NET_SYSTEM_TRAY_SCREEN atoms) xembedWin currentTime
|
||||
systrayWin <- xGetSelectionOwner disp $ atom_NET_SYSTEM_TRAY_SCREEN atoms
|
||||
if systrayWin /= xembedWin then do
|
||||
destroyWindow disp xembedWin
|
||||
putStrLn $ "Phi: can't initialize systray."
|
||||
return Nothing
|
||||
|
||||
else do
|
||||
allocaXEvent $ \event -> do
|
||||
putClientMessage event rootwin (atomMANAGER atoms) [fromIntegral currentTime, fromIntegral (atom_NET_SYSTEM_TRAY_SCREEN atoms), fromIntegral xembedWin, 0, 0]
|
||||
sendEvent disp rootwin False structureNotifyMask event
|
||||
|
||||
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
|
||||
|
||||
|
||||
handleEvent :: Event -> Phi -> Display -> Window -> IO ()
|
||||
handleEvent ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar xembedWindow = do
|
||||
let atoms = getAtoms dispvar
|
||||
when (window == xembedWindow && message_type == atom_NET_SYSTEM_TRAY_OPCODE atoms) $ do
|
||||
case messageData of
|
||||
(_:opcode:iconID:_) -> do
|
||||
case True of
|
||||
_ | opcode == sYSTEM_TRAY_REQUEST_DOCK -> do
|
||||
return ()
|
||||
|
||||
| opcode == sYSTEM_TRAY_BEGIN_MESSAGE || opcode == sYSTEM_TRAY_CANCEL_MESSAGE -> do
|
||||
return ()
|
||||
|
||||
| otherwise -> do
|
||||
return ()
|
||||
|
||||
|
||||
_ ->
|
||||
return ()
|
||||
|
||||
|
||||
handleEvent _ _ _ _ = return ()
|
||||
|
||||
systray :: Widget
|
||||
systray = Widget $ Systray
|
||||
|
|
@ -145,7 +145,7 @@ instance WidgetClass Taskbar where
|
|||
return $ TaskbarState 0 0 (-1) [] M.empty M.empty M.empty
|
||||
|
||||
|
||||
minSize _ = 0
|
||||
minSize _ _ _ = 0
|
||||
weight _ = 1
|
||||
|
||||
render (Taskbar config) TaskbarState { taskbarActiveWindow = activeWindow
|
||||
|
|
@ -294,13 +294,12 @@ handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.e
|
|||
let atoms = getAtoms dispvar
|
||||
let screens = getScreens dispvar
|
||||
|
||||
when (elem atom $ map ($ atoms) [ atom_NET_ACTIVE_WINDOW
|
||||
when (elem atom $ Xlib.wM_NAME : map ($ atoms) [ atom_NET_ACTIVE_WINDOW
|
||||
, atom_NET_NUMBER_OF_DESKTOPS
|
||||
, atom_NET_CURRENT_DESKTOP
|
||||
, atom_NET_CLIENT_LIST
|
||||
, atom_NET_WM_ICON
|
||||
, atom_NET_WM_NAME
|
||||
, atomWM_NAME
|
||||
, atom_NET_WM_DESKTOP
|
||||
, atom_NET_WM_STATE
|
||||
]) $ withDisplay dispvar $ \disp -> do
|
||||
|
|
@ -414,7 +413,7 @@ getWindowState 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 []) $ XExtras.getWindowProperty8 disp (atomWM_NAME atoms) window
|
||||
Nothing -> liftM (map unsignedChr . fromMaybe []) $ XExtras.getWindowProperty8 disp Xlib.wM_NAME window
|
||||
|
||||
workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_DESKTOP atoms) window
|
||||
|
||||
|
|
@ -434,7 +433,7 @@ readIcons (width:height:iconData) = do
|
|||
let (thisIcon, rest) = splitAt (fromIntegral (width*height)) iconData
|
||||
icon <- createImageSurface FormatARGB32 (fromIntegral width) (fromIntegral height)
|
||||
surfaceData <- imageSurfaceGetPixels icon :: IO (SurfaceData Int Word32)
|
||||
forM_ (zip thisIcon [1..]) $ \(e, i) -> writeArray surfaceData i $ premultiply $ fromIntegral e
|
||||
forM_ (zip thisIcon [0..]) $ \(e, i) -> writeArray surfaceData i $ premultiply $ fromIntegral e
|
||||
|
||||
surfaceMarkDirty icon
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,16 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module Phi.X11.AtomList ( atoms
|
||||
, specialAtoms
|
||||
) where
|
||||
|
||||
import Language.Haskell.TH
|
||||
|
||||
import Graphics.X11.Xlib
|
||||
|
||||
atoms :: [String]
|
||||
atoms = [ "UTF8_STRING"
|
||||
, "WM_NAME"
|
||||
, "MANAGER"
|
||||
, "_NET_WM_NAME"
|
||||
, "_NET_WM_WINDOW_TYPE"
|
||||
, "_NET_WM_WINDOW_TYPE_NORMAL"
|
||||
|
|
@ -20,6 +28,10 @@ atoms = [ "UTF8_STRING"
|
|||
, "_NET_WM_STATE_BELOW"
|
||||
, "_NET_WM_STRUT"
|
||||
, "_NET_WM_STRUT_PARTIAL"
|
||||
, "_NET_WM_PID"
|
||||
, "_NET_SYSTEM_TRAY_OPCODE"
|
||||
, "_NET_SYSTEM_TRAY_ORIENTATION"
|
||||
, "_NET_SYSTEM_TRAY_VISUAL"
|
||||
, "_NET_ACTIVE_WINDOW"
|
||||
, "_NET_NUMBER_OF_DESKTOPS"
|
||||
, "_NET_CURRENT_DESKTOP"
|
||||
|
|
@ -28,3 +40,8 @@ atoms = [ "UTF8_STRING"
|
|||
, "_XROOTPMAP_ID"
|
||||
, "_XROOTMAP_ID"
|
||||
]
|
||||
|
||||
-- the expression must have the type (Display -> String)
|
||||
specialAtoms :: [(String, Q Exp)]
|
||||
specialAtoms = [ ("_NET_SYSTEM_TRAY_SCREEN", [|("_NET_SYSTEM_TRAY_S" ++) . show . defaultScreen|])
|
||||
]
|
||||
|
|
@ -12,7 +12,7 @@ import Phi.X11.AtomList
|
|||
|
||||
|
||||
$(let atomsName = mkName "Atoms"
|
||||
atomNames = map (\atom -> (atom, mkName ("atom" ++ atom))) atoms
|
||||
atomNames = map (\atom -> (atom, mkName ("atom" ++ atom))) $ atoms ++ (map fst specialAtoms)
|
||||
fields = map (\(_, name) -> (name, IsStrict, ConT ''Atom)) atomNames
|
||||
in return [DataD [] atomsName [] [RecC atomsName fields] []]
|
||||
)
|
||||
|
|
@ -20,12 +20,17 @@ $(let atomsName = mkName "Atoms"
|
|||
initAtoms :: Display -> IO Atoms
|
||||
initAtoms display =
|
||||
$(do
|
||||
atomNames <- mapM (\atom -> do
|
||||
normalAtomNames <- mapM (\atom -> do
|
||||
varName <- newName ('_':atom)
|
||||
return (atom, mkName ("atom" ++ atom), varName)
|
||||
return ([|const atom|], mkName ("atom" ++ atom), varName)
|
||||
) atoms
|
||||
specialAtomNames <- mapM (\(name, atomgen) -> do
|
||||
varName <- newName ('_':name)
|
||||
return (atomgen, mkName ("atom" ++ name), varName)
|
||||
) specialAtoms
|
||||
let atomNames = normalAtomNames ++ specialAtomNames
|
||||
atomInitializers <- forM atomNames $
|
||||
\(atom, _, varName) -> liftM (BindS (VarP varName)) [| internAtom display atom False |]
|
||||
\(atomgen, _, varName) -> liftM (BindS (VarP varName)) [| internAtom display ($atomgen display) False |]
|
||||
|
||||
let atomFieldExps = map (\(_, atomName, varName) -> (atomName, VarE varName)) atomNames
|
||||
atomsName = mkName "Atoms"
|
||||
|
|
|
|||
|
|
@ -13,14 +13,14 @@ build-type: Simple
|
|||
library
|
||||
build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, X11, cairo, pango
|
||||
exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11,
|
||||
Phi.Widgets.Clock, Phi.Widgets.Taskbar
|
||||
Phi.Widgets.Clock, Phi.Widgets.Taskbar, Phi.Widgets.Systray
|
||||
other-modules: Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util
|
||||
hs-source-dirs: lib
|
||||
ghc-options: -fspec-constr-count=16
|
||||
extra-libraries: X11
|
||||
pkgconfig-depends: cairo >= 1.2.0, cairo-xlib
|
||||
ghc-options: -fspec-constr-count=16 -threaded
|
||||
|
||||
executable Phi
|
||||
build-depends: base >= 4, phi
|
||||
hs-source-dirs: src
|
||||
main-is: Phi.hs
|
||||
extra-libraries: X11
|
||||
pkgconfig-depends: cairo >= 1.2.0, cairo-xlib
|
||||
|
|
|
|||
|
|
@ -6,11 +6,13 @@ import Phi.X11
|
|||
|
||||
import Phi.Widgets.Clock
|
||||
import Phi.Widgets.Taskbar
|
||||
import Phi.Widgets.Systray
|
||||
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
runPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom }
|
||||
[theTaskbar, brightBorder [theClock]]
|
||||
[theTaskbar, brightBorder [theSystray], brightBorder [theClock]]
|
||||
where
|
||||
normalTaskBorder = BorderConfig (BorderWidth 2 (-3) 2 7) 1 (BorderWidth 0 5 0 5) (0.9, 0.9, 0.9, 0.8) (0.45, 0.45, 0.45, 1) 5 0
|
||||
activeTaskBorder = normalTaskBorder { borderColor = (1, 1, 1, 0.8)
|
||||
|
|
@ -44,6 +46,8 @@ main = do
|
|||
, desktopStyle = Just (normalDesktopStyle, currentDesktopStyle)
|
||||
}
|
||||
|
||||
theSystray = systray
|
||||
|
||||
theClock = clock defaultClockConfig { clockFormat = "<span font='Sans 8'>%R</span>\n<span font='Sans 6'>%A %d %B</span>"
|
||||
, lineSpacing = (-2)
|
||||
, clockSize = 75
|
||||
|
|
|
|||
Reference in a new issue