diff options
| -rw-r--r-- | lib/Phi/Border.hs | 69 | ||||
| -rw-r--r-- | lib/Phi/Phi.hs | 18 | ||||
| -rw-r--r-- | lib/Phi/Widget.hs | 16 | ||||
| -rw-r--r-- | lib/Phi/Widgets/Taskbar.hs | 202 | ||||
| -rw-r--r-- | lib/Phi/X11.hs | 25 | ||||
| -rw-r--r-- | lib/Phi/X11/AtomList.hs | 9 | ||||
| -rw-r--r-- | phi.cabal | 2 | ||||
| -rw-r--r-- | src/Phi.hs | 4 |
8 files changed, 273 insertions, 72 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" @@ -11,7 +11,7 @@ maintainer: mschiffer@universe-factory.net build-type: Simple library - build-depends: base >= 4, template-haskell, mtl, time, old-locale, X11, cairo, pango + build-depends: base >= 4, template-haskell, 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 other-modules: Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util @@ -12,7 +12,9 @@ main = do runPhi defaultXConfig defaultPanelConfig { panelPosition = Bottom } [theTaskbar, brightBorder [theClock]] where - theTaskbar = taskbar defaultTaskbarConfig + theTaskbar = taskbar defaultTaskbarConfig { taskBorder = BorderConfig (BorderWidth 2 4 2 4) 1 (BorderWidth 0 10 0 10) (0.9, 0.9, 0.9, 0.65) (0.45, 0.45, 0.45, 0.8) 5 0 + , activeTaskBorder = BorderConfig (BorderWidth 2 4 2 4) 1 (BorderWidth 0 10 0 10) (1, 1, 1, 0.65) (0, 0, 0, 0.8) 5 0 + } theClock = clock defaultClockConfig { clockFormat = "<span font='Sans 8'>%R</span>\n<span font='Sans 6'>%A %d %B</span>" , lineSpacing = (-2) , clockSize = 75 |