Core is independent of X11 now
This commit is contained in:
parent
234388ef38
commit
4d519acbd4
10 changed files with 308 additions and 278 deletions
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
Clock config
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
Reference in a new issue