diff options
Diffstat (limited to 'lib/Phi/Widgets')
| -rw-r--r-- | lib/Phi/Widgets/AlphaBox.hs | 8 | ||||
| -rw-r--r-- | lib/Phi/Widgets/Clock.hs | 8 | ||||
| -rw-r--r-- | lib/Phi/Widgets/X11/Systray.hs (renamed from lib/Phi/Widgets/Systray.hs) | 4 | ||||
| -rw-r--r-- | lib/Phi/Widgets/X11/Taskbar.hs (renamed from lib/Phi/Widgets/Taskbar.hs) | 156 |
4 files changed, 92 insertions, 84 deletions
diff --git a/lib/Phi/Widgets/AlphaBox.hs b/lib/Phi/Widgets/AlphaBox.hs index 6f989ea..59f8aea 100644 --- a/lib/Phi/Widgets/AlphaBox.hs +++ b/lib/Phi/Widgets/AlphaBox.hs @@ -13,11 +13,11 @@ import Control.Monad.State.Strict import Graphics.Rendering.Cairo -data AlphaBox w s c = (Widget w s c) => AlphaBox !Double !w +data AlphaBox w s c d = (Widget w s c d) => AlphaBox !Double !w -data AlphaBoxCache w s c = (Widget w s c) => AlphaBoxCache !c +data AlphaBoxCache w s c d = (Widget w s c d) => AlphaBoxCache !c -instance Eq s => Widget (AlphaBox w s c) s (AlphaBoxCache w s c) where +instance (Eq s, Display d) => Widget (AlphaBox w s c d) s (AlphaBoxCache w s c d) d where initWidget (AlphaBox _ w) = initWidget w initCache (AlphaBox _ w) = AlphaBoxCache $ initCache w @@ -47,6 +47,6 @@ instance Eq s => Widget (AlphaBox w s c) s (AlphaBoxCache w s c) where handleMessage (AlphaBox _ w) = handleMessage w -alphaBox :: (Widget w s c) => Double -> w -> AlphaBox w s c +alphaBox :: (Widget w s c d) => Double -> w -> AlphaBox w s c d alphaBox = AlphaBox diff --git a/lib/Phi/Widgets/Clock.hs b/lib/Phi/Widgets/Clock.hs index 9282432..26b777f 100644 --- a/lib/Phi/Widgets/Clock.hs +++ b/lib/Phi/Widgets/Clock.hs @@ -34,7 +34,7 @@ data ClockConfig = ClockConfig { clockFormat :: !String defaultClockConfig :: ClockConfig defaultClockConfig = ClockConfig "%R" (0, 0, 0, 1) 0 50 -data Clock = Clock !ClockConfig deriving (Show, Eq) +data Clock d = 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 Widget Clock ClockState (RenderCache ClockState) where +instance Display d => Widget (Clock d) ClockState (RenderCache ClockState) d where initWidget (Clock _) phi _ _ = do forkIO $ forever $ do time <- getZonedTime @@ -85,6 +85,6 @@ instance Widget Clock ClockState (RenderCache ClockState) where _ -> priv -clock :: ClockConfig -> Clock +clock :: ClockConfig -> Clock d clock config = do - Clock config
\ No newline at end of file + Clock config diff --git a/lib/Phi/Widgets/Systray.hs b/lib/Phi/Widgets/X11/Systray.hs index 27a5e34..fffb181 100644 --- a/lib/Phi/Widgets/Systray.hs +++ b/lib/Phi/Widgets/X11/Systray.hs @@ -1,7 +1,7 @@ {-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-} -module Phi.Widgets.Systray ( systray - ) where +module Phi.Widgets.X11.Systray ( systray + ) where import Control.Concurrent import Control.Monad diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/X11/Taskbar.hs index f0a8196..07a7292 100644 --- a/lib/Phi/Widgets/Taskbar.hs +++ b/lib/Phi/Widgets/X11/Taskbar.hs @@ -1,15 +1,15 @@ {-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-} -module Phi.Widgets.Taskbar ( IconStyle - , idIconStyle - , desaturateIconStyle - , TaskStyle(..) - , DesktopStyle(..) - , TaskbarConfig(..) - , defaultTaskbarConfig - , Taskbar - , taskbar - ) where +module Phi.Widgets.X11.Taskbar ( IconStyle + , idIconStyle + , desaturateIconStyle + , TaskStyle(..) + , DesktopStyle(..) + , TaskbarConfig(..) + , defaultTaskbarConfig + , Taskbar + , taskbar + ) where import Control.Arrow import Control.Concurrent @@ -48,6 +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 @@ -138,7 +139,7 @@ defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 200 data Taskbar = Taskbar TaskbarConfig -data TaskbarState = TaskbarState { taskbarScreens :: ![RECTANGLE] +data TaskbarState = TaskbarState { taskbarScreens :: ![Rectangle] , taskbarActiveWindow :: !WINDOW , taskbarDesktopCount :: !Int , taskbarCurrentDesktop :: !Int @@ -161,7 +162,7 @@ data WindowState = WindowState { windowTitle :: !String , windowDesktop :: !Int , windowVisible :: !Bool , windowIcons :: ![Icon] - , windowGeometry :: !RECTANGLE + , windowGeometry :: !Rectangle } deriving (Eq, Show) data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Icon)) @@ -208,7 +209,7 @@ data TaskbarMessage = WindowListUpdate ![WINDOW] !(M.Map WINDOW WindowState) | ActiveWindowUpdate !WINDOW deriving (Typeable, Show) -instance Widget Taskbar TaskbarState (M.Map WINDOW WindowCache) where +instance Widget Taskbar TaskbarState (M.Map WINDOW WindowCache) X11 where initWidget (Taskbar _) phi dispvar screens = do phi' <- dupPhi phi forkIO $ taskbarRunner phi' dispvar @@ -398,14 +399,14 @@ windowOnDesktop :: Int -> WindowState -> Bool windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDesktop state) -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) +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 sendMessage phi $ WindowListUpdate windows states sendMessage phi $ DesktopCountUpdate desktopCount sendMessage phi $ CurrentDesktopUpdate current @@ -418,23 +419,24 @@ taskbarRunner phi dispvar = do m <- receiveMessage phi case (fromMessage m) of Just (XEvent event) -> - handleEvent phi dispvar event + handleEvent phi x11 event _ -> return () -handleEvent :: Phi -> Display -> SomeEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () -handleEvent phi dispvar event = +handleEvent :: Phi -> X11 -> SomeEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () +handleEvent phi x11 event = case (fromEvent event) of - Just e -> handlePropertyNotifyEvent phi dispvar e + Just e -> handlePropertyNotifyEvent phi x11 e Nothing -> case (fromEvent event) of - Just e -> handleConfigureNotifyEvent phi dispvar e + Just e -> handleConfigureNotifyEvent phi x11 e Nothing -> return () -handlePropertyNotifyEvent :: Phi -> Display -> PropertyNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () -handlePropertyNotifyEvent phi dispvar MkPropertyNotifyEvent {atom_PropertyNotifyEvent = atom, window_PropertyNotifyEvent = window} = do - let atoms = getAtoms dispvar - +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 @@ -445,29 +447,28 @@ handlePropertyNotifyEvent phi dispvar MkPropertyNotifyEvent {atom_PropertyNotify , atom_NET_WM_NAME , atom_NET_WM_DESKTOP , atom_NET_WM_STATE - ]) $ withDisplay dispvar $ \conn -> do - let rootwin = getRoot conn + ]) $ do if (window == rootwin) then do when (atom == atom_NET_ACTIVE_WINDOW atoms) $ do - activeWindow <- liftIO $ getActiveWindow conn atoms + activeWindow <- liftIO $ getActiveWindow x11 sendMessage phi $ ActiveWindowUpdate activeWindow sendMessage phi Repaint when (atom == atom_NET_NUMBER_OF_DESKTOPS atoms) $ do - desktopCount <- liftIO $ getDesktopCount conn atoms + desktopCount <- liftIO $ getDesktopCount x11 sendMessage phi $ DesktopCountUpdate desktopCount sendMessage phi Repaint when (atom == atom_NET_CURRENT_DESKTOP atoms) $ do - current <- liftIO $ getCurrentDesktop conn atoms + current <- liftIO $ getCurrentDesktop x11 sendMessage phi $ CurrentDesktopUpdate current sendMessage phi Repaint when (atom == atom_NET_DESKTOP_NAMES atoms) $ do - names <- liftIO $ getDesktopNames conn atoms + names <- liftIO $ getDesktopNames x11 sendMessage phi $ DesktopNamesUpdate names sendMessage phi Repaint when (atom == atom_NET_CLIENT_LIST atoms) $ do (windows, windowStates) <- get - (windows', windowStates') <- liftIO $ getWindowStates conn atoms windowStates + (windows', windowStates') <- liftIO $ getWindowStates x11 windowStates when (windows /= windows') $ do sendMessage phi $ WindowListUpdate windows' windowStates' @@ -479,14 +480,14 @@ handlePropertyNotifyEvent phi dispvar MkPropertyNotifyEvent {atom_PropertyNotify when (elem window windows) $ do case () of _ | (atom == atom_NET_WM_ICON atoms) -> do - icons <- liftIO $ getWindowIcons conn atoms window + icons <- liftIO $ getWindowIcons x11 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 conn atoms window + (name, desktop, visible) <- liftIO $ getWindowInfo x11 window let mwindowState = M.lookup window windowStates case mwindowState of Just windowState -> do @@ -501,12 +502,13 @@ handlePropertyNotifyEvent phi dispvar MkPropertyNotifyEvent {atom_PropertyNotify return () -handleConfigureNotifyEvent :: Phi -> Display -> ConfigureNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () -handleConfigureNotifyEvent phi dispvar MkConfigureNotifyEvent {window_ConfigureNotifyEvent = window} = do +handleConfigureNotifyEvent :: Phi -> X11 -> ConfigureNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () +handleConfigureNotifyEvent phi x11 MkConfigureNotifyEvent {window_ConfigureNotifyEvent = window} = do + let conn = x11Connection x11 (windows, windowStates) <- get - when (elem window windows) $ withDisplay dispvar $ \conn -> do + when (elem window windows) $ do let geom = fmap windowGeometry . M.lookup window $ windowStates - geom' <- liftIO $ getWindowGeometry conn window + geom' <- liftIO $ getWindowGeometry x11 window when (geom /= (Just geom')) $ do let windowStates' = M.update (\state -> Just state {windowGeometry = geom'}) window windowStates sendMessage phi $ WindowListUpdate windows windowStates' @@ -514,30 +516,30 @@ handleConfigureNotifyEvent phi dispvar MkConfigureNotifyEvent {window_ConfigureN put (windows, windowStates') -getDesktopCount :: Connection -> Atoms -> IO Int -getDesktopCount conn atoms = - liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 conn (getRoot conn) (atom_NET_NUMBER_OF_DESKTOPS atoms) +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 :: Connection -> Atoms -> IO Int -getCurrentDesktop conn atoms = - liftM (fromIntegral . fromMaybe (-1) . join . fmap listToMaybe) $ getProperty32 conn (getRoot conn) (atom_NET_CURRENT_DESKTOP atoms) +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) -getDesktopNames :: Connection -> Atoms -> IO [String] -getDesktopNames conn atoms = - liftM (map (decode . map fromIntegral) . break' . fromMaybe []) $ getProperty8 conn (getRoot conn) (atom_NET_DESKTOP_NAMES atoms) +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) where break' l = case dropWhile (== 0) l of [] -> [] l' -> w : break' l'' where (w, l'') = break (== 0) l' -getActiveWindow :: Connection -> Atoms -> IO WINDOW -getActiveWindow conn atoms = - liftM (fromXid . toXid . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 conn (getRoot conn) (atom_NET_ACTIVE_WINDOW atoms) +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) -getWindowStates :: Connection -> Atoms -> M.Map WINDOW WindowState -> IO ([WINDOW], M.Map WINDOW WindowState) -getWindowStates conn atoms windowStates = do - windows <- getWindowList conn atoms +getWindowStates :: X11 -> M.Map WINDOW WindowState -> IO ([WINDOW], M.Map WINDOW WindowState) +getWindowStates x11 windowStates = do + windows <- getWindowList x11 let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows @@ -547,15 +549,15 @@ getWindowStates conn atoms windowStates = do where getWindowState' (window, Just windowState) = return (window, windowState) getWindowState' (window, Nothing) = do - changeWindowAttributes conn window $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])] - windowState <- getWindowState conn atoms window + changeWindowAttributes (x11Connection x11) window $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])] + windowState <- getWindowState x11 window return (window, windowState) -getWindowState :: Connection -> Atoms -> WINDOW -> IO WindowState -getWindowState conn atoms window = do - (name, workspace, visible) <- getWindowInfo conn atoms window - icons <- getWindowIcons conn atoms window - geom <- getWindowGeometry conn window +getWindowState :: X11 -> WINDOW -> IO WindowState +getWindowState x11 window = do + (name, workspace, visible) <- getWindowInfo x11 window + icons <- getWindowIcons x11 window + geom <- getWindowGeometry x11 window return $ WindowState { windowTitle = name , windowDesktop = workspace @@ -564,8 +566,10 @@ getWindowState conn atoms window = do , windowGeometry = geom } -getWindowInfo :: Connection -> Atoms -> WINDOW -> IO (String, Int, Bool) -getWindowInfo conn atoms window = do +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) wmname <- case netwmname of Just name -> return name @@ -578,8 +582,8 @@ getWindowInfo conn atoms window = do where unsignedChr = chr . fromIntegral -getWindowIcons :: Connection -> Atoms -> WINDOW -> IO [Icon] -getWindowIcons conn atoms window = getProperty32 conn window (atom_NET_WM_ICON atoms) >>= readIcons . fromMaybe [] +getWindowIcons :: X11 -> WINDOW -> IO [Icon] +getWindowIcons x11 window = getProperty32 (x11Connection x11) window (atom_NET_WM_ICON . x11Atoms $ x11) >>= readIcons . fromMaybe [] readIcons :: [Word32] -> IO [Icon] @@ -612,9 +616,13 @@ premultiply c = a .|. r .|. g .|. b b = pm bmask -getWindowGeometry :: Connection -> WINDOW -> IO RECTANGLE -getWindowGeometry conn window = - getGeometry conn (fromXid . toXid $ window) >>= getReply >>= return . ((const $ MkRECTANGLE 0 0 0 0) ||| (\(MkGetGeometryReply _ _ x y width height _) -> MkRECTANGLE x y width height)) +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 showWindow :: Connection -> Atoms -> WINDOW -> IO Bool showWindow conn atoms window = do @@ -634,8 +642,8 @@ showWindow conn atoms window = do ] -getWindowList :: Connection -> Atoms -> IO [WINDOW] -getWindowList conn atoms = liftM (map (fromXid . toXid) . join . maybeToList) $ getProperty32 conn (getRoot conn) (atom_NET_CLIENT_LIST atoms) +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) taskbar :: TaskbarConfig -> Taskbar taskbar = Taskbar |