Core is independent of X11 now
This commit is contained in:
parent
234388ef38
commit
4d519acbd4
10 changed files with 308 additions and 278 deletions
|
|
@ -56,11 +56,11 @@ defaultBorderConfig = BorderConfig { margin = simpleBorderWidth 0
|
|||
, borderWeight = 1
|
||||
}
|
||||
|
||||
data Border w s c = (Widget w s c) => Border !BorderConfig !w
|
||||
data Border w s c d = (Widget w s c d) => Border !BorderConfig !w
|
||||
|
||||
data BorderCache w s c = (Widget w s c) => BorderCache !c
|
||||
data BorderCache w s c d = (Widget w s c d) => BorderCache !c
|
||||
|
||||
instance Eq s => Widget (Border w s c) s (BorderCache w s c) where
|
||||
instance (Eq s, Display d) => Widget (Border w s c d) s (BorderCache w s c d) d where
|
||||
initWidget (Border _ w) = initWidget w
|
||||
initCache (Border _ w) = BorderCache $ initCache w
|
||||
|
||||
|
|
@ -165,5 +165,5 @@ roundRectangle x y width height radius = do
|
|||
arc (x + radius) (y + radius) radius pi (pi*3/2)
|
||||
closePath
|
||||
|
||||
border :: (Widget w s c) => BorderConfig -> w -> Border w s c
|
||||
border :: (Widget w s c d) => BorderConfig -> w -> Border w s c d
|
||||
border = Border
|
||||
|
|
|
|||
|
|
@ -1,10 +1,7 @@
|
|||
{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, DeriveDataTypeable, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-}
|
||||
{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances, TypeFamilies #-}
|
||||
|
||||
module Phi.Widget ( XEvent(..)
|
||||
module Phi.Widget ( Rectangle(..)
|
||||
, Display(..)
|
||||
, withDisplay
|
||||
, getAtoms
|
||||
, XMessage(..)
|
||||
, unionArea
|
||||
, SurfaceSlice(..)
|
||||
, Widget(..)
|
||||
|
|
@ -23,7 +20,6 @@ module Phi.Widget ( XEvent(..)
|
|||
import Control.Arrow
|
||||
import Control.Arrow.Transformer
|
||||
import Control.CacheArrow
|
||||
import Control.Concurrent.MVar
|
||||
import Control.Monad
|
||||
import Control.Monad.State.Strict hiding (lift)
|
||||
import Control.Monad.IO.Class
|
||||
|
|
@ -31,67 +27,57 @@ import Control.Monad.IO.Class
|
|||
import Data.Maybe
|
||||
import Data.Typeable
|
||||
|
||||
import Graphics.XHB
|
||||
import Graphics.Rendering.Cairo
|
||||
|
||||
import Phi.Phi
|
||||
import Phi.X11.Atoms
|
||||
|
||||
|
||||
data Display = Display !Connection !Atoms
|
||||
data Rectangle = Rectangle { rect_x :: !Int
|
||||
, rect_y :: !Int
|
||||
, rect_width :: !Int
|
||||
, rect_height :: !Int
|
||||
} deriving (Show, Eq)
|
||||
|
||||
newtype XEvent = XEvent SomeEvent deriving Typeable
|
||||
|
||||
instance Show XEvent where
|
||||
show _ = "XEvent (..)"
|
||||
class Display d where
|
||||
type Window d :: *
|
||||
|
||||
|
||||
withDisplay :: MonadIO m => Display -> (Connection -> m a) -> m a
|
||||
withDisplay (Display conn _) f = f conn
|
||||
|
||||
getAtoms :: Display -> Atoms
|
||||
getAtoms (Display _ atoms) = atoms
|
||||
|
||||
data XMessage = UpdateScreens [(RECTANGLE, WINDOW)] deriving (Show, Typeable)
|
||||
|
||||
|
||||
unionArea :: RECTANGLE -> RECTANGLE -> Int
|
||||
unionArea :: Rectangle -> Rectangle -> Int
|
||||
unionArea a b = uw*uh
|
||||
where
|
||||
uw = max 0 $ (min ax2 bx2) - fromIntegral (max ax1 bx1)
|
||||
uh = max 0 $ (min ay2 by2) - fromIntegral (max ay1 by1)
|
||||
uw = max 0 $ (min ax2 bx2) - (max ax1 bx1)
|
||||
uh = max 0 $ (min ay2 by2) - (max ay1 by1)
|
||||
|
||||
MkRECTANGLE ax1 ay1 aw ah = a
|
||||
MkRECTANGLE bx1 by1 bw bh = b
|
||||
Rectangle ax1 ay1 aw ah = a
|
||||
Rectangle bx1 by1 bw bh = b
|
||||
|
||||
ax2 = fromIntegral ax1 + fromIntegral aw
|
||||
ay2 = fromIntegral ay1 + fromIntegral ah
|
||||
ax2 = ax1 + aw
|
||||
ay2 = ay1 + ah
|
||||
|
||||
bx2 = fromIntegral bx1 + fromIntegral bw
|
||||
by2 = fromIntegral by1 + fromIntegral bh
|
||||
bx2 = bx1 + bw
|
||||
by2 = by1 + bh
|
||||
|
||||
|
||||
data SurfaceSlice = SurfaceSlice !Int !Surface
|
||||
|
||||
class Eq s => Widget w s c | w -> s, w -> c where
|
||||
initWidget :: w -> Phi -> Display -> [(RECTANGLE, WINDOW)] -> IO s
|
||||
class (Eq s, Display d) => Widget w s c d | w -> s, w -> c, w -> d where
|
||||
initWidget :: w -> Phi -> d -> [(Rectangle, Window d)] -> IO s
|
||||
|
||||
initCache :: w -> c
|
||||
|
||||
minSize :: w -> s -> Int -> RECTANGLE -> Int
|
||||
minSize :: w -> s -> Int -> Rectangle -> Int
|
||||
|
||||
weight :: w -> Float
|
||||
weight _ = 0
|
||||
|
||||
render :: w -> s -> Int -> Int -> Int -> Int -> RECTANGLE -> StateT c IO [(Bool, SurfaceSlice)]
|
||||
render :: w -> s -> Int -> Int -> Int -> Int -> Rectangle -> StateT c IO [(Bool, SurfaceSlice)]
|
||||
|
||||
handleMessage :: w -> s -> Message -> s
|
||||
handleMessage _ priv _ = priv
|
||||
|
||||
deriving instance Eq RECTANGLE
|
||||
|
||||
type IOCache = CacheArrow (Kleisli IO)
|
||||
type RenderCache s = IOCache (s, Int, Int, Int, Int, RECTANGLE) Surface
|
||||
type RenderCache s = IOCache (s, Int, Int, Int, Int, Rectangle) Surface
|
||||
|
||||
createIOCache :: Eq a => (a -> IO b) -> IOCache a b
|
||||
createIOCache = lift . Kleisli
|
||||
|
|
@ -103,8 +89,8 @@ runIOCache a = do
|
|||
put cache'
|
||||
return b
|
||||
|
||||
createRenderCache :: (s -> Int -> Int -> Int -> Int -> RECTANGLE -> Render ())
|
||||
-> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, RECTANGLE) Surface
|
||||
createRenderCache :: (s -> Int -> Int -> Int -> Int -> Rectangle -> Render ())
|
||||
-> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, Rectangle) Surface
|
||||
createRenderCache f = lift . Kleisli $ \(state, x, y, w, h, screen) -> do
|
||||
surface <- createImageSurface FormatARGB32 w h
|
||||
renderWith surface $ do
|
||||
|
|
@ -114,22 +100,22 @@ createRenderCache f = lift . Kleisli $ \(state, x, y, w, h, screen) -> do
|
|||
f state x y w h screen
|
||||
return surface
|
||||
|
||||
renderCached :: Eq s => s -> Int -> Int -> Int -> Int -> RECTANGLE -> StateT (RenderCache s) IO [(Bool, SurfaceSlice)]
|
||||
renderCached :: Eq s => s -> Int -> Int -> Int -> Int -> Rectangle -> StateT (RenderCache s) IO [(Bool, SurfaceSlice)]
|
||||
renderCached state x y w h screen = do
|
||||
cache <- get
|
||||
(surf, updated, cache') <- liftIO $ runKleisli (runCache' cache) (state, x, y, w, h, screen)
|
||||
put cache'
|
||||
return [(updated, SurfaceSlice 0 surf)]
|
||||
|
||||
data CompoundWidget a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundWidget !a !b
|
||||
data CompoundWidget a sa ca b sb cb d = (Widget a sa ca d, Widget b sb cb d) => CompoundWidget !a !b
|
||||
|
||||
data CompoundState a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundState !sa !sb
|
||||
deriving instance Eq (CompoundState a sa ca b sb cb)
|
||||
data CompoundState a sa ca b sb cb d = (Widget a sa ca d, Widget b sb cb d) => CompoundState !sa !sb
|
||||
deriving instance Eq (CompoundState a sa ca b sb cb d)
|
||||
|
||||
data CompoundCache a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundCache !ca !cb
|
||||
data CompoundCache a sa ca b sb cb d = (Widget a sa ca d, Widget b sb cb d) => CompoundCache !ca !cb
|
||||
|
||||
|
||||
instance Widget (CompoundWidget a sa ca b sb cb) (CompoundState a sa ca b sb cb) (CompoundCache a sa ca b sb cb) where
|
||||
instance Display d => Widget (CompoundWidget a sa ca b sb cb d) (CompoundState a sa ca b sb cb d) (CompoundCache a sa ca b sb cb d) d where
|
||||
initWidget (CompoundWidget a b) phi disp screens = liftM2 CompoundState (initWidget a phi disp screens) (initWidget b phi disp screens)
|
||||
|
||||
initCache (CompoundWidget a b) = CompoundCache (initCache a) (initCache b)
|
||||
|
|
@ -154,15 +140,15 @@ instance Widget (CompoundWidget a sa ca b sb cb) (CompoundState a sa ca b sb cb)
|
|||
|
||||
handleMessage (CompoundWidget a b) (CompoundState sa sb) message = CompoundState (handleMessage a sa message) (handleMessage b sb message)
|
||||
|
||||
weight' :: (Widget a sa ca) => a -> Float
|
||||
weight' :: (Widget a sa ca d) => a -> Float
|
||||
weight' = max 0 . weight
|
||||
|
||||
(<~>) :: (Widget a sa ca, Widget b sb cb) => a -> b -> CompoundWidget a sa ca b sb cb
|
||||
(<~>) :: (Widget a sa ca d, Widget b sb cb d) => a -> b -> CompoundWidget a sa ca b sb cb d
|
||||
a <~> b = CompoundWidget a b
|
||||
|
||||
data Separator = Separator !Int !Float deriving (Show, Eq)
|
||||
data Separator d = Separator !Int !Float deriving (Show, Eq)
|
||||
|
||||
instance Widget Separator () (RenderCache ()) where
|
||||
instance Display d => Widget (Separator d) () (RenderCache ()) d where
|
||||
initWidget _ _ _ _ = return ()
|
||||
initCache _ = createRenderCache $ \_ _ _ _ _ _ -> do
|
||||
setOperator OperatorClear
|
||||
|
|
@ -173,5 +159,5 @@ instance Widget Separator () (RenderCache ()) where
|
|||
render _ = renderCached
|
||||
|
||||
|
||||
separator :: Int -> Float -> Separator
|
||||
separator :: Int -> Float -> Separator d
|
||||
separator = Separator
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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,22 +419,23 @@ 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
|
||||
|
|
@ -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
|
||||
292
lib/Phi/X11.hs
292
lib/Phi/X11.hs
|
|
@ -1,13 +1,17 @@
|
|||
{-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification #-}
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, ExistentialQuantification, TypeFamilies, FlexibleContexts, DeriveDataTypeable #-}
|
||||
|
||||
module Phi.X11 ( XConfig(..)
|
||||
module Phi.X11 ( X11(..)
|
||||
, XEvent(..)
|
||||
, XMessage(..)
|
||||
, XConfig(..)
|
||||
, defaultXConfig
|
||||
, runPhi
|
||||
) where
|
||||
|
||||
import Graphics.XHB
|
||||
import Graphics.XHB hiding (Window)
|
||||
import qualified Graphics.XHB.Connection.Open as CO
|
||||
import Graphics.XHB.Gen.Xinerama
|
||||
import Graphics.XHB.Gen.Xproto
|
||||
import Graphics.XHB.Gen.Xproto hiding (Window)
|
||||
|
||||
import Graphics.Rendering.Cairo
|
||||
|
||||
|
|
@ -36,33 +40,51 @@ import Phi.Phi
|
|||
import Phi.X11.Util
|
||||
import qualified Phi.Types as Phi
|
||||
import qualified Phi.Panel as Panel
|
||||
import qualified Phi.Widget as Widget
|
||||
import Phi.Widget hiding (Display, handleMessage)
|
||||
import qualified Phi.Widget as Widget (handleMessage)
|
||||
import Phi.Widget hiding (handleMessage)
|
||||
import Phi.X11.Atoms
|
||||
|
||||
|
||||
data XConfig = XConfig { phiXScreenInfo :: !(Connection -> IO [RECTANGLE])
|
||||
data X11 = X11 { x11Connection :: !Connection
|
||||
, x11Atoms :: !Atoms
|
||||
, x11Screen :: !SCREEN
|
||||
}
|
||||
|
||||
instance Display X11 where
|
||||
type Window X11 = WINDOW
|
||||
|
||||
|
||||
newtype XEvent = XEvent SomeEvent deriving Typeable
|
||||
|
||||
instance Show XEvent where
|
||||
show _ = "XEvent (..)"
|
||||
|
||||
data XMessage = UpdateScreens [(Rectangle, WINDOW)] deriving (Show, Typeable)
|
||||
|
||||
|
||||
data XConfig = XConfig { phiXScreenInfo :: !(X11 -> IO [Rectangle])
|
||||
}
|
||||
|
||||
data PhiState w s c = (Widget.Widget w s c) => PhiState { phiRootImage :: !Surface
|
||||
, phiPanels :: ![PanelState w s c]
|
||||
, phiRepaint :: !Bool
|
||||
, phiShutdown :: !Bool
|
||||
, phiShutdownHold :: !Int
|
||||
, phiWidgetState :: !s
|
||||
}
|
||||
data PhiState w s c = (Widget w s c X11) => PhiState { phiRootImage :: !Surface
|
||||
, phiPanels :: ![PanelState w s c]
|
||||
, phiRepaint :: !Bool
|
||||
, phiShutdown :: !Bool
|
||||
, phiShutdownHold :: !Int
|
||||
, phiWidgetState :: !s
|
||||
}
|
||||
|
||||
data PanelState w s c = (Widget.Widget w s c) => PanelState { panelWindow :: !WINDOW
|
||||
, panelPixmap :: !PIXMAP
|
||||
, panelArea :: !RECTANGLE
|
||||
, panelScreenArea :: !RECTANGLE
|
||||
, panelWidgetCache :: !c
|
||||
}
|
||||
data PanelState w s c = (Widget w s c X11) => PanelState { panelWindow :: !WINDOW
|
||||
, panelPixmap :: !PIXMAP
|
||||
, panelArea :: !Rectangle
|
||||
, panelScreenArea :: !Rectangle
|
||||
, panelWidgetCache :: !c
|
||||
}
|
||||
|
||||
data PhiConfig w s c = PhiConfig { phiPhi :: !Phi
|
||||
, phiPanelConfig :: !Panel.PanelConfig
|
||||
, phiXConfig :: !XConfig
|
||||
, phiAtoms :: !Atoms
|
||||
, phiX11 :: !X11
|
||||
, phiXCB :: !XCB.Connection
|
||||
, phiWidget :: !w
|
||||
}
|
||||
|
||||
|
|
@ -81,17 +103,22 @@ runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st
|
|||
defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
|
||||
}
|
||||
|
||||
getScreenInfo :: Connection -> IO [RECTANGLE]
|
||||
getScreenInfo conn = do
|
||||
getScreenInfo :: X11 -> IO [Rectangle]
|
||||
getScreenInfo x11 = do
|
||||
let conn = x11Connection x11
|
||||
screen = x11Screen x11
|
||||
exs <- queryScreens conn >>= getReply
|
||||
case exs of
|
||||
Right xs -> return . map screenInfoToRect $ screen_info_QueryScreensReply xs
|
||||
Left _ -> getGeometry conn (fromXid . toXid $ getRoot conn) >>= getReply' "getScreenInfo: getGeometry failed" >>=
|
||||
return . (\(MkGetGeometryReply _ _ x y w h _) -> [MkRECTANGLE x y w h])
|
||||
Left _ -> getGeometry conn (fromXid . toXid $ root_SCREEN screen) >>= getReply' "getScreenInfo: getGeometry failed" >>=
|
||||
return . (\(MkGetGeometryReply _ _ x y w h _) -> [Rectangle (fi x) (fi y) (fi w) (fi h)])
|
||||
where
|
||||
screenInfoToRect (MkScreenInfo x y w h) = MkRECTANGLE x y w h
|
||||
screenInfoToRect (MkScreenInfo x y w h) = Rectangle (fi x) (fi y) (fi w) (fi h)
|
||||
|
||||
runPhi :: (Widget.Widget w s c) => XConfig -> Panel.PanelConfig -> w -> IO ()
|
||||
fi :: (Integral a, Num b) => a -> b
|
||||
fi = fromIntegral
|
||||
|
||||
runPhi :: (Widget w s c X11) => XConfig -> Panel.PanelConfig -> w -> IO ()
|
||||
runPhi xconfig config widget = do
|
||||
phi <- initPhi
|
||||
|
||||
|
|
@ -102,24 +129,30 @@ runPhi xconfig config widget = do
|
|||
conn <- liftM fromJust connect
|
||||
xcb <- XCB.connect
|
||||
|
||||
let dispname = displayInfo conn
|
||||
screen = (roots_Setup . connectionSetup $ conn) !! CO.screen dispname
|
||||
|
||||
atoms <- initAtoms conn
|
||||
changeWindowAttributes conn (getRoot conn) $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])]
|
||||
changeWindowAttributes conn (root_SCREEN screen) $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])]
|
||||
|
||||
bg <- createImageSurface FormatRGB24 1 1
|
||||
|
||||
screens <- liftIO $ phiXScreenInfo xconfig conn
|
||||
panelWindows <- mapM (createPanelWindow conn config) screens
|
||||
let dispvar = Widget.Display conn atoms
|
||||
widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1)
|
||||
let x11 = X11 conn atoms screen
|
||||
|
||||
screens <- liftIO $ phiXScreenInfo xconfig x11
|
||||
panelWindows <- mapM (createPanelWindow conn screen config) screens
|
||||
|
||||
let widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1)
|
||||
screenPanels = zip screens panelWindows
|
||||
|
||||
initialState <- Widget.initWidget widget' phi dispvar screenPanels
|
||||
initialState <- initWidget widget' phi x11 screenPanels
|
||||
|
||||
runPhiX
|
||||
PhiConfig { phiPhi = phi
|
||||
, phiXConfig = xconfig
|
||||
, phiPanelConfig = config
|
||||
, phiAtoms = atoms
|
||||
, phiX11 = x11
|
||||
, phiXCB = xcb
|
||||
, phiWidget = widget'
|
||||
}
|
||||
PhiState { phiRootImage = bg
|
||||
|
|
@ -129,15 +162,15 @@ runPhi xconfig config widget = do
|
|||
, phiShutdownHold = 0
|
||||
, phiWidgetState = initialState
|
||||
} $ do
|
||||
updateRootImage conn xcb
|
||||
updateRootImage
|
||||
|
||||
panels <- mapM (\(screen, window) -> createPanel conn window screen) screenPanels
|
||||
panels <- mapM (\(screen, window) -> createPanel window screen) screenPanels
|
||||
|
||||
forM_ panels $ setPanelProperties conn
|
||||
forM_ panels setPanelProperties
|
||||
|
||||
modify $ \state -> state { phiPanels = panels }
|
||||
|
||||
updatePanels conn xcb
|
||||
updatePanels
|
||||
|
||||
forM_ panels $ liftIO . mapWindow conn . panelWindow
|
||||
|
||||
|
|
@ -150,11 +183,11 @@ runPhi xconfig config widget = do
|
|||
|
||||
available <- messageAvailable phi
|
||||
when (not available && repaint) $ do
|
||||
updatePanels conn xcb
|
||||
updatePanels
|
||||
modify $ \state -> state {phiRepaint = False}
|
||||
|
||||
message <- receiveMessage phi
|
||||
handleMessage conn xcb message
|
||||
handleMessage message
|
||||
|
||||
case (fromMessage message) of
|
||||
Just Shutdown ->
|
||||
|
|
@ -179,8 +212,8 @@ termHandler :: Phi -> Handler
|
|||
termHandler phi = Catch $ sendMessage phi Shutdown
|
||||
|
||||
|
||||
handleMessage :: (Widget w s c) => Connection -> XCB.Connection -> Message -> PhiX w s c ()
|
||||
handleMessage conn xcb m = do
|
||||
handleMessage :: (Widget w s c X11) => Message -> PhiX w s c ()
|
||||
handleMessage m = do
|
||||
w <- asks phiWidget
|
||||
modify $ \state -> state {phiWidgetState = Widget.handleMessage w (phiWidgetState state) m}
|
||||
|
||||
|
|
@ -190,81 +223,86 @@ handleMessage conn xcb m = do
|
|||
_ ->
|
||||
case (fromMessage m) of
|
||||
Just (XEvent event) ->
|
||||
handleEvent conn xcb event
|
||||
handleEvent event
|
||||
_ ->
|
||||
return ()
|
||||
|
||||
handleEvent :: (Widget w s c) => Connection -> XCB.Connection -> SomeEvent -> PhiX w s c ()
|
||||
handleEvent conn xcb event =
|
||||
handleEvent :: (Widget w s c X11) => SomeEvent -> PhiX w s c ()
|
||||
handleEvent event =
|
||||
case (fromEvent event) of
|
||||
Just e -> handlePropertyNotifyEvent conn xcb e
|
||||
Just e -> handlePropertyNotifyEvent e
|
||||
Nothing -> case (fromEvent event) of
|
||||
Just e -> handleConfigureNotifyEvent conn e
|
||||
Just e -> handleConfigureNotifyEvent e
|
||||
Nothing -> return ()
|
||||
|
||||
handlePropertyNotifyEvent :: (Widget w s c) => Connection -> XCB.Connection -> PropertyNotifyEvent -> PhiX w s c ()
|
||||
handlePropertyNotifyEvent conn xcb MkPropertyNotifyEvent { atom_PropertyNotifyEvent = atom } = do
|
||||
handlePropertyNotifyEvent :: (Widget w s c X11) => PropertyNotifyEvent -> PhiX w s c ()
|
||||
handlePropertyNotifyEvent MkPropertyNotifyEvent { atom_PropertyNotifyEvent = atom } = do
|
||||
phi <- asks phiPhi
|
||||
atoms <- asks phiAtoms
|
||||
atoms <- asks (x11Atoms . phiX11)
|
||||
panels <- gets phiPanels
|
||||
|
||||
when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do
|
||||
updateRootImage conn xcb
|
||||
updateRootImage
|
||||
sendMessage phi ResetBackground
|
||||
sendMessage phi Repaint
|
||||
|
||||
handleConfigureNotifyEvent :: (Widget w s c) => Connection -> ConfigureNotifyEvent -> PhiX w s c ()
|
||||
handleConfigureNotifyEvent conn MkConfigureNotifyEvent { window_ConfigureNotifyEvent = window } | window == getRoot conn = do
|
||||
phi <- asks phiPhi
|
||||
xconfig <- asks phiXConfig
|
||||
config <- asks phiPanelConfig
|
||||
panels <- gets phiPanels
|
||||
let screens = map panelScreenArea panels
|
||||
screens' <- liftIO $ phiXScreenInfo xconfig conn
|
||||
handleConfigureNotifyEvent :: (Widget w s c X11) => ConfigureNotifyEvent -> PhiX w s c ()
|
||||
handleConfigureNotifyEvent MkConfigureNotifyEvent { window_ConfigureNotifyEvent = window } = do
|
||||
x11 <- asks phiX11
|
||||
let conn = x11Connection x11
|
||||
screen = x11Screen x11
|
||||
rootWindow = root_SCREEN screen
|
||||
when (window == rootWindow) $ do
|
||||
phi <- asks phiPhi
|
||||
xconfig <- asks phiXConfig
|
||||
config <- asks phiPanelConfig
|
||||
panels <- gets phiPanels
|
||||
let screens = map panelScreenArea panels
|
||||
screens' <- liftIO $ phiXScreenInfo xconfig x11
|
||||
|
||||
when (screens /= screens') $ do
|
||||
liftIO $ do
|
||||
mapM_ (freePixmap conn . panelPixmap) panels
|
||||
mapM_ (destroyWindow conn . panelWindow) $ drop (length screens') panels
|
||||
when (screens /= screens') $ do
|
||||
liftIO $ do
|
||||
mapM_ (freePixmap conn . panelPixmap) panels
|
||||
mapM_ (destroyWindow conn . panelWindow) $ drop (length screens') panels
|
||||
|
||||
let panelsScreens = zip screens' $ map Just panels ++ repeat Nothing
|
||||
let panelsScreens = zip screens' $ map Just panels ++ repeat Nothing
|
||||
|
||||
panels' <- forM panelsScreens $ \(screen, mpanel) ->
|
||||
case mpanel of
|
||||
Just panel -> do
|
||||
let rect = panelBounds config screen
|
||||
win = panelWindow panel
|
||||
panels' <- forM panelsScreens $ \(screenarea, mpanel) ->
|
||||
case mpanel of
|
||||
Just panel -> do
|
||||
let rect = panelBounds config screenarea
|
||||
win = panelWindow panel
|
||||
|
||||
liftIO $ configureWindow conn win $ toValueParam [ (ConfigWindowX, fromIntegral $ x_RECTANGLE rect)
|
||||
, (ConfigWindowY, fromIntegral $ y_RECTANGLE rect)
|
||||
, (ConfigWindowWidth, fromIntegral $ width_RECTANGLE rect)
|
||||
, (ConfigWindowHeight, fromIntegral $ height_RECTANGLE rect)
|
||||
]
|
||||
liftIO $ configureWindow conn win $ toValueParam [ (ConfigWindowX, fromIntegral $ rect_x rect)
|
||||
, (ConfigWindowY, fromIntegral $ rect_y rect)
|
||||
, (ConfigWindowWidth, fromIntegral $ rect_width rect)
|
||||
, (ConfigWindowHeight, fromIntegral $ rect_height rect)
|
||||
]
|
||||
|
||||
panel' <- createPanel conn win screen
|
||||
setPanelProperties conn panel'
|
||||
panel' <- createPanel win screenarea
|
||||
setPanelProperties panel'
|
||||
|
||||
return panel'
|
||||
Nothing -> do
|
||||
win <- liftIO $ createPanelWindow conn config screen
|
||||
panel <- createPanel conn win screen
|
||||
setPanelProperties conn panel
|
||||
liftIO $ mapWindow conn $ panelWindow panel
|
||||
return panel
|
||||
return panel'
|
||||
Nothing -> do
|
||||
win <- liftIO $ createPanelWindow conn screen config screenarea
|
||||
panel <- createPanel win screenarea
|
||||
setPanelProperties panel
|
||||
liftIO $ mapWindow conn $ panelWindow panel
|
||||
return panel
|
||||
|
||||
modify $ \state -> state { phiPanels = panels' }
|
||||
modify $ \state -> state { phiPanels = panels' }
|
||||
|
||||
sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels'
|
||||
sendMessage phi Repaint
|
||||
|
||||
handleConfigureNotifyEvent _ _ = return ()
|
||||
sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels'
|
||||
sendMessage phi Repaint
|
||||
|
||||
receiveEvents :: Phi -> Connection -> IO ()
|
||||
receiveEvents phi conn = do
|
||||
forever $ waitForEvent conn >>= sendMessage phi . XEvent
|
||||
|
||||
updatePanels :: (Widget w s c) => Connection -> XCB.Connection -> PhiX w s c ()
|
||||
updatePanels conn xcb = do
|
||||
updatePanels :: (Widget w s c X11) => PhiX w s c ()
|
||||
updatePanels = do
|
||||
X11 conn _ screen <- asks phiX11
|
||||
xcb <- asks phiXCB
|
||||
w <- asks phiWidget
|
||||
s <- gets phiWidgetState
|
||||
rootImage <- gets phiRootImage
|
||||
|
|
@ -275,17 +313,16 @@ updatePanels conn xcb = do
|
|||
area = panelArea panel
|
||||
|
||||
(panelSurfaces, cache') <- liftIO $ flip runStateT (panelWidgetCache panel) $
|
||||
(withDimension area $ Widget.render w s 0 0) (panelScreenArea panel)
|
||||
(withDimension area $ render w s 0 0) (panelScreenArea panel)
|
||||
|
||||
let screen = head . roots_Setup . connectionSetup $ conn
|
||||
visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
|
||||
let visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
|
||||
|
||||
xbuffer <- liftIO $ withDimension area $ XCB.createXCBSurface xcb (fromXid . toXid $ pixmap) visualtype
|
||||
|
||||
liftIO $ (withDimension area $ withSimilarSurface xbuffer ContentColor) $ \buffer -> do
|
||||
renderWith buffer $ do
|
||||
save
|
||||
translate (-(fromIntegral $ x_RECTANGLE area)) (-(fromIntegral $ y_RECTANGLE area))
|
||||
translate (-(fromIntegral $ rect_x area)) (-(fromIntegral $ rect_y area))
|
||||
withPatternForSurface rootImage $ \pattern -> do
|
||||
patternSetExtend pattern ExtendRepeat
|
||||
setSource pattern
|
||||
|
|
@ -313,12 +350,12 @@ updatePanels conn xcb = do
|
|||
modify $ \state -> state { phiPanels = panels' }
|
||||
|
||||
|
||||
updateRootImage :: Connection -> XCB.Connection -> PhiX w s c ()
|
||||
updateRootImage conn xcb = do
|
||||
atoms <- asks phiAtoms
|
||||
updateRootImage :: PhiX w s c ()
|
||||
updateRootImage = do
|
||||
X11 conn atoms screen <- asks phiX11
|
||||
xcb <- asks phiXCB
|
||||
|
||||
let screen = head . roots_Setup . connectionSetup $ conn
|
||||
visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
|
||||
let visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
|
||||
rootwin = root_SCREEN screen
|
||||
|
||||
pixmap <- liftM (fromXid . toXid . fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $
|
||||
|
|
@ -355,12 +392,12 @@ updateRootImage conn xcb = do
|
|||
return ()
|
||||
|
||||
|
||||
createPanel :: (Widget w s c) => Connection -> WINDOW -> RECTANGLE -> PhiX w s c (PanelState w s c)
|
||||
createPanel conn win screenRect = do
|
||||
createPanel :: (Widget w s c X11) => WINDOW -> Rectangle -> PhiX w s c (PanelState w s c)
|
||||
createPanel win screenRect = do
|
||||
(conn, screen) <- asks $ (x11Connection &&& x11Screen) . phiX11
|
||||
config <- asks phiPanelConfig
|
||||
w <- asks phiWidget
|
||||
let rect = panelBounds config screenRect
|
||||
screen = head . roots_Setup . connectionSetup $ conn
|
||||
depth = root_depth_SCREEN screen
|
||||
|
||||
pixmap <- liftIO $ newResource conn
|
||||
|
|
@ -374,10 +411,9 @@ createPanel conn win screenRect = do
|
|||
, panelWidgetCache = initCache w
|
||||
}
|
||||
|
||||
createPanelWindow :: Connection -> Panel.PanelConfig -> RECTANGLE -> IO WINDOW
|
||||
createPanelWindow conn config screenRect = do
|
||||
createPanelWindow :: Connection -> SCREEN -> Panel.PanelConfig -> Rectangle -> IO WINDOW
|
||||
createPanelWindow conn screen config screenRect = do
|
||||
let rect = panelBounds config screenRect
|
||||
screen = head . roots_Setup . connectionSetup $ conn
|
||||
depth = root_depth_SCREEN screen
|
||||
rootwin = root_SCREEN screen
|
||||
visual = root_visual_SCREEN screen
|
||||
|
|
@ -387,9 +423,9 @@ createPanelWindow conn config screenRect = do
|
|||
return win
|
||||
|
||||
|
||||
setPanelProperties :: Connection -> PanelState w s c -> PhiX w s c ()
|
||||
setPanelProperties conn panel = do
|
||||
atoms <- asks phiAtoms
|
||||
setPanelProperties :: PanelState w s c -> PhiX w s c ()
|
||||
setPanelProperties panel = do
|
||||
(conn, atoms) <- asks $ (x11Connection &&& x11Atoms) . phiX11
|
||||
liftIO $ do
|
||||
let name = map (fromIntegral . ord) "Phi"
|
||||
changeProperty8 conn PropModeReplace (panelWindow panel) (atomWM_NAME atoms) (atomSTRING atoms) name
|
||||
|
|
@ -408,28 +444,28 @@ setPanelProperties conn panel = do
|
|||
|
||||
changeProperty8 conn PropModeReplace (panelWindow panel) (atomWM_CLASS atoms) (atomSTRING atoms) $ map (fromIntegral . ord) "phi\0Phi"
|
||||
|
||||
setStruts conn panel
|
||||
setStruts panel
|
||||
|
||||
|
||||
setStruts :: Connection -> PanelState w s c -> PhiX w s c ()
|
||||
setStruts conn panel = do
|
||||
atoms <- asks phiAtoms
|
||||
setStruts :: PanelState w s c -> PhiX w s c ()
|
||||
setStruts panel = do
|
||||
X11 conn atoms screen <- asks phiX11
|
||||
config <- asks phiPanelConfig
|
||||
let rootwin = getRoot conn
|
||||
let rootwin = root_SCREEN screen
|
||||
position = Panel.panelPosition config
|
||||
area = panelArea panel
|
||||
rootHeight <- liftIO $ getGeometry conn (fromXid . toXid $ rootwin) >>= getReply' "setStruts: getGeometry failed" >>= return . height_GetGeometryReply
|
||||
|
||||
let struts = [makeStruts i | i <- [0..11]]
|
||||
where
|
||||
makeTopStruts 2 = (fromIntegral $ y_RECTANGLE area) + (fromIntegral $ height_RECTANGLE area)
|
||||
makeTopStruts 8 = (fromIntegral $ x_RECTANGLE area)
|
||||
makeTopStruts 9 = (fromIntegral $ x_RECTANGLE area) + (fromIntegral $ width_RECTANGLE area) - 1
|
||||
makeTopStruts 2 = (fromIntegral $ rect_y area) + (fromIntegral $ rect_height area)
|
||||
makeTopStruts 8 = (fromIntegral $ rect_x area)
|
||||
makeTopStruts 9 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1
|
||||
makeTopStruts _ = 0
|
||||
|
||||
makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ y_RECTANGLE area)
|
||||
makeBottomStruts 10 = (fromIntegral $ x_RECTANGLE area)
|
||||
makeBottomStruts 11 = (fromIntegral $ x_RECTANGLE area) + (fromIntegral $ width_RECTANGLE area) - 1
|
||||
makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ rect_y area)
|
||||
makeBottomStruts 10 = (fromIntegral $ rect_x area)
|
||||
makeBottomStruts 11 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1
|
||||
makeBottomStruts _ = 0
|
||||
|
||||
makeStruts = case position of
|
||||
|
|
@ -441,17 +477,17 @@ setStruts conn panel = do
|
|||
changeProperty32 conn PropModeReplace (panelWindow panel) (atom_NET_WM_STRUT_PARTIAL atoms) (atomCARDINAL atoms) struts
|
||||
|
||||
|
||||
panelBounds :: Panel.PanelConfig -> RECTANGLE -> RECTANGLE
|
||||
panelBounds :: Panel.PanelConfig -> Rectangle -> Rectangle
|
||||
panelBounds config screenBounds = case Panel.panelPosition config of
|
||||
Phi.Top -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config }
|
||||
Phi.Bottom -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config,
|
||||
y_RECTANGLE = (y_RECTANGLE screenBounds) + (fromIntegral $ height_RECTANGLE screenBounds) - (fromIntegral $ Panel.panelSize config) }
|
||||
Phi.Top -> screenBounds { rect_height = Panel.panelSize config }
|
||||
Phi.Bottom -> screenBounds { rect_height = Panel.panelSize config,
|
||||
rect_y = rect_y screenBounds + rect_height screenBounds - Panel.panelSize config }
|
||||
|
||||
withRectangle :: (Num x, Num y, Num w, Num h) => RECTANGLE -> (x -> y -> w -> h -> a) -> a
|
||||
withRectangle :: (Num x, Num y, Num w, Num h) => Rectangle -> (x -> y -> w -> h -> a) -> a
|
||||
withRectangle r = withDimension r . withPosition r
|
||||
|
||||
withPosition :: (Num x, Num y) => RECTANGLE -> (x -> y -> a) -> a
|
||||
withPosition r f = f (fromIntegral $ x_RECTANGLE r) (fromIntegral $ y_RECTANGLE r)
|
||||
withPosition :: (Num x, Num y) => Rectangle -> (x -> y -> a) -> a
|
||||
withPosition r f = f (fromIntegral $ rect_x r) (fromIntegral $ rect_y r)
|
||||
|
||||
withDimension :: (Num w, Num h) => RECTANGLE -> (w -> h -> a) -> a
|
||||
withDimension r f = f (fromIntegral $ width_RECTANGLE r) (fromIntegral $ height_RECTANGLE r)
|
||||
withDimension :: (Num w, Num h) => Rectangle -> (w -> h -> a) -> a
|
||||
withDimension r f = f (fromIntegral $ rect_width r) (fromIntegral $ rect_height r)
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ library
|
|||
build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, xhb,
|
||||
cairo, pango, unix, data-accessor, arrows, CacheArrow
|
||||
exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11
|
||||
Phi.Widgets.AlphaBox, Phi.Widgets.Clock, Phi.Widgets.Taskbar
|
||||
Phi.Widgets.AlphaBox, Phi.Widgets.Clock, Phi.Widgets.X11.Taskbar
|
||||
-- , Phi.Widgets.Systray
|
||||
other-modules: Phi.X11.Util, Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.XCB
|
||||
include-dirs: include
|
||||
|
|
|
|||
|
|
@ -6,8 +6,8 @@ import Phi.X11
|
|||
|
||||
import Phi.Widgets.AlphaBox
|
||||
import Phi.Widgets.Clock
|
||||
import Phi.Widgets.Taskbar
|
||||
--import Phi.Widgets.Systray
|
||||
import Phi.Widgets.X11.Taskbar
|
||||
--import Phi.Widgets.X11.Systray
|
||||
|
||||
|
||||
main :: IO ()
|
||||
|
|
@ -52,5 +52,5 @@ main = do
|
|||
, lineSpacing = (-3)
|
||||
, clockSize = 75
|
||||
}
|
||||
brightBorder :: (Widget w s c) => w -> Border w s c
|
||||
brightBorder :: (Widget w s c d) => w -> Border w s c d
|
||||
brightBorder = border normalDesktopBorder
|
||||
|
|
|
|||
Reference in a new issue