summaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Phi/Bindings/Util.hsc16
-rw-r--r--lib/Phi/Border.hs9
-rw-r--r--lib/Phi/Widget.hs8
-rw-r--r--lib/Phi/Widgets/Clock.hs2
-rw-r--r--lib/Phi/Widgets/Systray.hs137
-rw-r--r--lib/Phi/Widgets/Taskbar.hs27
-rw-r--r--lib/Phi/X11/AtomList.hs19
-rw-r--r--lib/Phi/X11/Atoms.hs13
8 files changed, 204 insertions, 27 deletions
diff --git a/lib/Phi/Bindings/Util.hsc b/lib/Phi/Bindings/Util.hsc
index 5058a8b..32737ff 100644
--- a/lib/Phi/Bindings/Util.hsc
+++ b/lib/Phi/Bindings/Util.hsc
@@ -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
+
diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs
index 791845d..a025ab6 100644
--- a/lib/Phi/Border.hs
+++ b/lib/Phi/Border.hs
@@ -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
diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs
index 48ab536..d954b58 100644
--- a/lib/Phi/Widget.hs
+++ b/lib/Phi/Widget.hs
@@ -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 ()
diff --git a/lib/Phi/Widgets/Clock.hs b/lib/Phi/Widgets/Clock.hs
index 7172f77..492d807 100644
--- a/lib/Phi/Widgets/Clock.hs
+++ b/lib/Phi/Widgets/Clock.hs
@@ -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
diff --git a/lib/Phi/Widgets/Systray.hs b/lib/Phi/Widgets/Systray.hs
new file mode 100644
index 0000000..26ff0a4
--- /dev/null
+++ b/lib/Phi/Widgets/Systray.hs
@@ -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
diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs
index caa7599..bd45add 100644
--- a/lib/Phi/Widgets/Taskbar.hs
+++ b/lib/Phi/Widgets/Taskbar.hs
@@ -121,8 +121,8 @@ data TaskbarState = TaskbarState { taskbarActiveWindow :: !Window
, taskbarCurrentDesktop :: !Int
, taskbarWindows :: ![Window]
, taskbarWindowStates :: !(M.Map Window WindowState)
- , taskbarWindowIcons :: !(M.Map Window [(Int, Surface)])
- , taskbarWindowScreens :: !(M.Map Window Xlib.Rectangle)
+ , taskbarWindowIcons :: !(M.Map Window [(Int, Surface)])
+ , taskbarWindowScreens :: !(M.Map Window Xlib.Rectangle)
} deriving Show
data WindowState = WindowState { windowTitle :: !String
@@ -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,15 +294,14 @@ 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
- , 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
+ 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
+ , atom_NET_WM_DESKTOP
+ , atom_NET_WM_STATE
]) $ withDisplay dispvar $ \disp -> do
let rootwin = Xlib.defaultRootWindow disp
if (window == rootwin)
@@ -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
diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs
index d18be71..b91ae3e 100644
--- a/lib/Phi/X11/AtomList.hs
+++ b/lib/Phi/X11/AtomList.hs
@@ -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|])
+ ] \ No newline at end of file
diff --git a/lib/Phi/X11/Atoms.hs b/lib/Phi/X11/Atoms.hs
index 38f8f3c..acbae64 100644
--- a/lib/Phi/X11/Atoms.hs
+++ b/lib/Phi/X11/Atoms.hs
@@ -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"
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-21 23:54:24 +0100