summaryrefslogtreecommitdiffstats
path: root/lib/Phi
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Phi')
-rw-r--r--lib/Phi/Border.hs69
-rw-r--r--lib/Phi/Phi.hs18
-rw-r--r--lib/Phi/Widget.hs16
-rw-r--r--lib/Phi/Widgets/Taskbar.hs202
-rw-r--r--lib/Phi/X11.hs25
-rw-r--r--lib/Phi/X11/AtomList.hs9
6 files changed, 269 insertions, 70 deletions
diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs
index 1994724..0576f27 100644
--- a/lib/Phi/Border.hs
+++ b/lib/Phi/Border.hs
@@ -4,6 +4,8 @@ module Phi.Border ( BorderWidth(..)
, simpleBorderWidth
, BorderConfig(..)
, defaultBorderConfig
+ , drawBorder
+ , roundRectangle
, border
) where
@@ -76,41 +78,46 @@ instance WidgetClass Border where
height' = height - borderV m - 2*bw - borderV p
render (Border config _) (BorderState widgetStates) w h = do
- newPath
- arc (x + width - radius) (y + radius) radius (-pi/2) 0
- arc (x + width - radius) (y + height - radius) radius 0 (pi/2)
- arc (x + radius) (y + height - radius) radius (pi/2) pi
- arc (x + radius) (y + radius) radius pi (pi*3/2)
- closePath
-
- save
- setSourceRGBA fr fg fb fa
- fillPreserve
-
- setSourceRGBA br bg bb ba
- setLineWidth $ fromIntegral bw
- strokePreserve
- restore
-
+ drawBorder config 0 0 w h
clip
renderWidgets widgetStates
- where
- m = margin config
- bw = borderWidth config
- p = padding config
- radius = cornerRadius config
-
- x = (fromIntegral $ borderLeft m) + (fromIntegral bw)/2
- y = (fromIntegral $ borderTop m) + (fromIntegral bw)/2
- width = fromIntegral $ w - borderH m - bw
- height = fromIntegral $ h - borderV m - bw
-
- (br, bg, bb, ba) = borderColor config
- (fr, fg, fb, fa) = backgroundColor config
-
handleMessage _ (BorderState widgetStates) m = BorderState $ handleMessageWidgets m widgetStates
-
+
+drawBorder :: BorderConfig -> Int -> Int -> Int -> Int -> Render ()
+drawBorder config dx dy w h = do
+ roundRectangle x y width height radius
+
+ save
+ setSourceRGBA fr fg fb fa
+ fillPreserve
+
+ setSourceRGBA br bg bb ba
+ setLineWidth $ fromIntegral bw
+ strokePreserve
+ restore
+ where
+ m = margin config
+ bw = borderWidth config
+ p = padding config
+ radius = cornerRadius config
+
+ x = (fromIntegral dx) + (fromIntegral $ borderLeft m) + (fromIntegral bw)/2
+ y = (fromIntegral dy) + (fromIntegral $ borderTop m) + (fromIntegral bw)/2
+ width = fromIntegral $ w - borderH m - bw
+ height = fromIntegral $ h - borderV m - bw
+
+ (br, bg, bb, ba) = borderColor config
+ (fr, fg, fb, fa) = backgroundColor config
+
+roundRectangle :: Double -> Double -> Double -> Double -> Double -> Render ()
+roundRectangle x y width height radius = do
+ newPath
+ arc (x + width - radius) (y + radius) radius (-pi/2) 0
+ arc (x + width - radius) (y + height - radius) radius 0 (pi/2)
+ arc (x + radius) (y + height - radius) radius (pi/2) pi
+ arc (x + radius) (y + radius) radius pi (pi*3/2)
+ closePath
border :: BorderConfig -> [Widget] -> Widget
border config widgets = Widget $ Border config widgets
diff --git a/lib/Phi/Phi.hs b/lib/Phi/Phi.hs
index b517de6..3f4b59b 100644
--- a/lib/Phi/Phi.hs
+++ b/lib/Phi/Phi.hs
@@ -12,6 +12,8 @@ module Phi.Phi ( Phi
import Control.Concurrent.Chan
import Control.Monad
+import Control.Monad.IO.Class
+
import Data.Typeable
data Phi = Phi (Chan Message)
@@ -24,14 +26,14 @@ data DefaultMessage = Repaint deriving (Typeable, Show)
fromMessage :: (Typeable a, Show a) => Message -> Maybe a
fromMessage (Message m) = cast m
-initPhi :: IO Phi
-initPhi = liftM Phi newChan
+initPhi :: MonadIO m => m Phi
+initPhi = liftM Phi $ liftIO newChan
-dupPhi :: Phi -> IO Phi
-dupPhi (Phi chan) = liftM Phi $ dupChan chan
+dupPhi :: MonadIO m => Phi -> m Phi
+dupPhi (Phi chan) = liftM Phi $ liftIO $ dupChan chan
-sendMessage :: (Typeable a, Show a) => Phi -> a -> IO ()
-sendMessage (Phi chan) = writeChan chan . Message
+sendMessage :: (MonadIO m, Typeable a, Show a) => Phi -> a -> m ()
+sendMessage (Phi chan) = liftIO . writeChan chan . Message
-receiveMessage :: Phi -> IO Message
-receiveMessage (Phi chan) = readChan chan
+receiveMessage :: MonadIO m => Phi -> m Message
+receiveMessage (Phi chan) = liftIO $ readChan chan
diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs
index 9534c8c..218dea1 100644
--- a/lib/Phi/Widget.hs
+++ b/lib/Phi/Widget.hs
@@ -2,6 +2,7 @@
module Phi.Widget ( Display(..)
, withDisplay
+ , getAtoms
, Widget(..)
, WidgetClass(..)
, WidgetState(..)
@@ -14,6 +15,7 @@ module Phi.Widget ( Display(..)
import Control.Concurrent.MVar
import Control.Monad
+import Control.Monad.IO.Class
import Data.Traversable
@@ -21,17 +23,21 @@ import qualified Graphics.X11.Xlib
import Graphics.Rendering.Cairo
import Phi.Phi
+import Phi.X11.Atoms
-newtype Display = Display (MVar Graphics.X11.Xlib.Display)
+data Display = Display (MVar Graphics.X11.Xlib.Display) Atoms
-withDisplay :: Display -> (Graphics.X11.Xlib.Display -> IO a) -> IO a
-withDisplay (Display dispvar) f = do
- disp <- takeMVar dispvar
+withDisplay :: MonadIO m => Display -> (Graphics.X11.Xlib.Display -> m a) -> m a
+withDisplay (Display dispvar _) f = do
+ disp <- liftIO $ takeMVar dispvar
a <- f disp
- putMVar dispvar disp
+ liftIO $ putMVar dispvar disp
return a
+getAtoms :: Display -> Atoms
+getAtoms (Display _ atoms) = atoms
+
class Show a => WidgetClass a where
type WidgetData a :: *
diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs
index a32c5d2..aa75258 100644
--- a/lib/Phi/Widgets/Taskbar.hs
+++ b/lib/Phi/Widgets/Taskbar.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilies, DeriveDataTypeable #-}
module Phi.Widgets.Taskbar ( TaskbarConfig(..)
, defaultTaskbarConfig
@@ -7,45 +7,225 @@ module Phi.Widgets.Taskbar ( TaskbarConfig(..)
import Control.Concurrent
import Control.Monad
+import Control.Monad.State
+import Control.Monad.Trans
+import Data.Char
+import Data.Maybe
import Data.Typeable
-import Data.Time.LocalTime
-import Data.Time.Format
+import qualified Data.Map as M
-import Graphics.Rendering.Cairo
+import Foreign.C.Types
+import Graphics.Rendering.Cairo
import Graphics.Rendering.Pango.Cairo
import Graphics.Rendering.Pango.Enums (PangoRectangle(..))
import Graphics.Rendering.Pango.Layout
-import System.Locale
+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
import Phi.Phi
import Phi.Types
+import Phi.Border
import Phi.Widget
+import Phi.X11.Atoms
-data TaskbarConfig = TaskbarConfig deriving Show
+data TaskbarConfig = TaskbarConfig { taskMaxSize :: !Int
+ , showDesktops :: !Bool
+ , taskBorder :: !BorderConfig
+ , activeTaskBorder :: !BorderConfig
+ } deriving Show
defaultTaskbarConfig :: TaskbarConfig
-defaultTaskbarConfig = TaskbarConfig
+defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 150
+ , showDesktops = False
+ , taskBorder = defaultBorderConfig
+ , activeTaskBorder = defaultBorderConfig { borderColor = (1, 1, 1, 1) }
+ }
data Taskbar = Taskbar TaskbarConfig deriving Show
-data TaskbarState = TaskbarState deriving Show
+data TaskbarState = TaskbarState { taskbarActiveWindow :: !Window
+ , taskbarDesktopCount :: !Int
+ , taskbarWindows :: ![Window]
+ , taskbarWindowStates :: !(M.Map Window WindowState)
+ } deriving Show
+
+data WindowState = WindowState { windowTitle :: !String
+ , windowDesktop :: !Int
+ , windowVisible :: !Bool
+ } deriving (Show, Eq)
+
+data TaskbarMessage = WindowListUpdate [Xlib.Window] (M.Map Window WindowState)
+ | DesktopCountUpdate Int
+ | ActiveWindowUpdate Window
+ deriving (Show, Typeable)
instance WidgetClass Taskbar where
type WidgetData Taskbar = TaskbarState
initWidget (Taskbar _) phi dispvar = do
- return TaskbarState
+ forkIO $ taskbarRunner phi dispvar
+
+ return $ TaskbarState 0 0 [] M.empty
minSize _ = 0
weight _ = 1
- render (Taskbar config) _ w h = do
- return ()
+ render (Taskbar config) TaskbarState {taskbarActiveWindow = activeWindow, taskbarDesktopCount = desktopCount, taskbarWindows = windows, taskbarWindowStates = windowStates} w h = do
+ let desktopWindows = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop desktop) . flip M.lookup windowStates) windows)) $ take desktopCount [0..]
+ windowCount = sum $ map (length . snd) $ desktopWindows
+ when (windowCount /= 0) $ do
+ let windowWidth = min (taskMaxSize config) (w `div` windowCount)
+
+ forM_ (zip [0..] $ join $ map snd desktopWindows) $ \(i, window) -> do
+ let border = if window == activeWindow then activeTaskBorder config else taskBorder config
+ drawBorder border (i*windowWidth) 0 windowWidth h
+
+ handleMessage _ priv m = case (fromMessage m) of
+ Just (WindowListUpdate windows windowStates) -> priv {taskbarWindows = windows, taskbarWindowStates = windowStates}
+ Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count}
+ Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window}
+ _ -> priv
+
+
+windowOnDesktop :: Int -> WindowState -> Bool
+windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDesktop state)
+
+
+taskbarRunner :: Phi -> Display -> IO ()
+taskbarRunner phi dispvar = do
+ (windows, tasks) <- liftIO $ withDisplay dispvar $ \disp -> do
+ (windows, tasks) <- getWindowStates disp (getAtoms dispvar) [] M.empty
+ desktopCount <- getDesktopCount disp (getAtoms dispvar)
+ activeWindow <- getActiveWindow disp (getAtoms dispvar)
+ sendMessage phi $ WindowListUpdate windows tasks
+ sendMessage phi $ DesktopCountUpdate desktopCount
+ sendMessage phi $ ActiveWindowUpdate activeWindow
+ return (windows, tasks)
+ sendMessage phi Repaint
+
+ flip evalStateT (windows, tasks) $ forever $ do
+ m <- receiveMessage phi
+ case (fromMessage m) of
+ Just event@XExtras.PropertyEvent {} ->
+ handlePropertyUpdate phi dispvar event
+ _ ->
+ return ()
+
+handlePropertyUpdate :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState) IO ()
+handlePropertyUpdate phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do
+ let atoms = getAtoms dispvar
+
+ when (elem atom $ map ($ atoms) [ atom_NET_ACTIVE_WINDOW
+ , atom_NET_NUMBER_OF_DESKTOPS
+ , atom_NET_CLIENT_LIST
+ , atom_NET_WM_NAME
+ , atomWM_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 disp atoms
+ sendMessage phi $ ActiveWindowUpdate activeWindow
+ sendMessage phi Repaint
+ when (atom == atom_NET_NUMBER_OF_DESKTOPS atoms) $ do
+ desktopCount <- liftIO $ getDesktopCount disp atoms
+ sendMessage phi $ DesktopCountUpdate desktopCount
+ sendMessage phi Repaint
+ when (atom == atom_NET_CLIENT_LIST atoms) $ do
+ (windows, windowStates) <- get
+ (windows', windowStates') <- liftIO $ getWindowStates disp atoms windows windowStates
+
+ when (windows /= windows' || windowStates /= windowStates') $ do
+ sendMessage phi $ WindowListUpdate windows' windowStates'
+ sendMessage phi Repaint
+ put (windows', windowStates')
+
+ else do
+ (windows, windowStates) <- get
+ when (elem window windows) $ do
+ let windowState = M.lookup window windowStates
+ windowState' <- liftIO $ getWindowState disp atoms window
+
+ when (windowState /= (Just windowState')) $ do
+ let windowStates' = M.insert window windowState' windowStates
+ sendMessage phi $ WindowListUpdate windows windowStates'
+ sendMessage phi Repaint
+ put (windows, windowStates')
+
+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
+
+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 :: Xlib.Display -> Atoms -> [Window] -> M.Map Window WindowState -> IO ([Window], M.Map Window WindowState)
+getWindowStates disp atoms oldWindows windowStates = do
+ windows <- getWindowList disp atoms oldWindows
+
+ let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows
+
+ newWindowStates <- mapM getWindowState' windowStates'
+
+ return (windows, M.fromList newWindowStates)
+ where
+ rootwin = Xlib.defaultRootWindow disp
+
+ getWindowState' (window, Just windowState) = return (window, windowState)
+ getWindowState' (window, Nothing) = do
+ windowState <- getWindowState disp atoms window
+ return (window, windowState)
+
+getWindowState :: Xlib.Display -> Atoms -> Window -> IO WindowState
+getWindowState disp atoms window = do
+ Xlib.selectInput disp window Xlib.propertyChangeMask
+ 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
+
+ workspace <- liftM (fromIntegral . fromMaybe 0xFFFFFFFF . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_WM_DESKTOP atoms) window
+
+ visible <- showWindow disp atoms window
+
+ return $ WindowState wmname workspace visible
+ where
+ unsignedChr = chr . fromIntegral . (fromIntegral :: (CChar -> CUChar))
+
+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
+ , transientForHint /= Nothing
+ , elem windowType $ map ($ atoms) [ atom_NET_WM_WINDOW_TYPE_DOCK
+ , atom_NET_WM_WINDOW_TYPE_DESKTOP
+ , atom_NET_WM_WINDOW_TYPE_TOOLBAR
+ , atom_NET_WM_WINDOW_TYPE_MENU
+ , atom_NET_WM_WINDOW_TYPE_SPLASH
+ ]
+ ]
+
+
+getWindowList :: Xlib.Display -> Atoms -> [Window] -> IO [Window]
+getWindowList disp atoms windows = do
+ newWindows <- liftM (map fromIntegral . join . maybeToList) $ XExtras.getWindowProperty32 disp (atom_NET_CLIENT_LIST atoms) $ Xlib.defaultRootWindow disp
+ return $ (filter (flip elem newWindows) windows) ++ (filter (not . flip elem windows) newWindows)
+
taskbar :: TaskbarConfig -> Widget
taskbar config = do
diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs
index 4332352..8d037a8 100644
--- a/lib/Phi/X11.hs
+++ b/lib/Phi/X11.hs
@@ -31,6 +31,7 @@ import qualified Phi.Widget as Widget
import Phi.X11.Atoms
import qualified Phi.Bindings.Util as Util
+
data XConfig = XConfig { phiXScreenInfo :: !(Display -> IO [Rectangle])
}
@@ -63,13 +64,6 @@ newtype PhiX a = PhiX (StateT PhiState PhiReader a)
runPhiX :: PhiConfig -> PhiState -> PhiX a -> IO (a, PhiState)
runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st
-withDisplayX :: Widget.Display -> (Display -> PhiX a) -> PhiX a
-withDisplayX (Widget.Display dispvar) f = do
- disp <- liftIO $ takeMVar dispvar
- a <- f disp
- liftIO $ putMVar dispvar disp
- return a
-
defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
}
@@ -88,10 +82,11 @@ runPhi xconfig config widgets = do
screens <- liftIO $ phiXScreenInfo xconfig disp
- dispvar <- liftM Widget.Display $ liftIO $ newMVar disp
+ dispmvar <- liftIO $ newMVar disp
+ let dispvar = Widget.Display dispmvar atoms
widgetStates <- liftIO $ mapM (Widget.createWidgetState phi dispvar) widgets
- withDisplayX dispvar $ \disp -> do
+ Widget.withDisplay dispvar $ \disp -> do
panels <- mapM (createPanel disp widgetStates) screens
forM_ panels $ \panel -> do
@@ -105,7 +100,7 @@ runPhi xconfig config widgets = do
liftIO $ forkIO $ receiveEvents phi dispvar
forever $ do
- message <- liftIO $ receiveMessage phi
+ message <- receiveMessage phi
handleMessage dispvar message
return ()
@@ -120,13 +115,13 @@ handleMessage dispvar m = do
modify $ \state@PhiState {phiPanels = panels} -> state {phiPanels = map (handlePanel m) panels}
case (fromMessage m) of
- Just Repaint -> withDisplayX dispvar $ \disp ->
+ Just Repaint -> Widget.withDisplay dispvar $ \disp ->
updatePanels disp True
_ ->
case (fromMessage m) of
- Just ExposeEvent {} -> withDisplayX dispvar $ \disp ->
+ Just ExposeEvent {} -> Widget.withDisplay dispvar $ \disp ->
updatePanels disp False
- Just event@PropertyEvent {} -> withDisplayX dispvar $ \disp ->
+ Just event@PropertyEvent {} -> Widget.withDisplay dispvar $ \disp ->
handlePropertyUpdate disp event
_ ->
return ()
@@ -206,8 +201,8 @@ updateRootImage disp = do
let screen = defaultScreen disp
visual = defaultVisual disp screen
rootwin = defaultRootWindow disp
- pixmap <- liftM (fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $
- \atom -> liftIO $ rawGetWindowProperty 32 disp atom rootwin
+ pixmap <- liftM (fromIntegral . fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $
+ \atom -> liftIO $ getWindowProperty32 disp atom rootwin
(_, _, _, rootWidth, rootHeight, _, _) <- liftIO $ getGeometry disp rootwin
-- update surface size
diff --git a/lib/Phi/X11/AtomList.hs b/lib/Phi/X11/AtomList.hs
index 258c89a..d1abb24 100644
--- a/lib/Phi/X11/AtomList.hs
+++ b/lib/Phi/X11/AtomList.hs
@@ -2,9 +2,15 @@ module Phi.X11.AtomList ( atoms
) where
atoms = [ "UTF8_STRING"
+ , "WM_NAME"
, "_NET_WM_NAME"
, "_NET_WM_WINDOW_TYPE"
+ , "_NET_WM_WINDOW_TYPE_NORMAL"
, "_NET_WM_WINDOW_TYPE_DOCK"
+ , "_NET_WM_WINDOW_TYPE_DESKTOP"
+ , "_NET_WM_WINDOW_TYPE_TOOLBAR"
+ , "_NET_WM_WINDOW_TYPE_MENU"
+ , "_NET_WM_WINDOW_TYPE_SPLASH"
, "_NET_WM_DESKTOP"
, "_NET_WM_STATE"
, "_NET_WM_STATE_SKIP_PAGER"
@@ -13,6 +19,9 @@ atoms = [ "UTF8_STRING"
, "_NET_WM_STATE_BELOW"
, "_NET_WM_STRUT"
, "_NET_WM_STRUT_PARTIAL"
+ , "_NET_ACTIVE_WINDOW"
+ , "_NET_NUMBER_OF_DESKTOPS"
+ , "_NET_CLIENT_LIST"
, "_MOTIF_WM_HINTS"
, "_XROOTPMAP_ID"
, "_XROOTMAP_ID"
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 01:18:27 +0100