neocturne/phi
Archived
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Core is independent of X11 now

Browse source
This commit is contained in:
Matthias Schiffer 2011-09-08 19:15:23 +02:00
parent 234388ef38
commit 4d519acbd4
10 changed files with 308 additions and 278 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
lib/Phi/Border.hs
View file

@ -56,11 +56,11 @@ defaultBorderConfig = BorderConfig { margin = simpleBorderWidth 0
, borderWeight = 1 , 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 initWidget (Border _ w) = initWidget w
initCache (Border _ w) = BorderCache $ initCache 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) arc (x + radius) (y + radius) radius pi (pi*3/2)
closePath 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 border = Border

86
lib/Phi/Widget.hs
View file

@ -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(..) , Display(..)
, withDisplay
, getAtoms
, XMessage(..)
, unionArea , unionArea
, SurfaceSlice(..) , SurfaceSlice(..)
, Widget(..) , Widget(..)
@ -23,7 +20,6 @@ module Phi.Widget ( XEvent(..)
import Control.Arrow import Control.Arrow
import Control.Arrow.Transformer import Control.Arrow.Transformer
import Control.CacheArrow import Control.CacheArrow
import Control.Concurrent.MVar
import Control.Monad import Control.Monad
import Control.Monad.State.Strict hiding (lift) import Control.Monad.State.Strict hiding (lift)
import Control.Monad.IO.Class import Control.Monad.IO.Class
@ -31,67 +27,57 @@ import Control.Monad.IO.Class
import Data.Maybe import Data.Maybe
import Data.Typeable import Data.Typeable
import Graphics.XHB
import Graphics.Rendering.Cairo import Graphics.Rendering.Cairo
import Phi.Phi import Phi.Phi
import Phi.X11.Atoms 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 class Display d where
type Window d :: *
instance Show XEvent where
show _ = "XEvent (..)"
withDisplay :: MonadIO m => Display -> (Connection -> m a) -> m a unionArea :: Rectangle -> Rectangle -> Int
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 a b = uw*uh unionArea a b = uw*uh
where where
uw = max 0 $ (min ax2 bx2) - fromIntegral (max ax1 bx1) uw = max 0 $ (min ax2 bx2) - (max ax1 bx1)
uh = max 0 $ (min ay2 by2) - fromIntegral (max ay1 by1) uh = max 0 $ (min ay2 by2) - (max ay1 by1)
MkRECTANGLE ax1 ay1 aw ah = a Rectangle ax1 ay1 aw ah = a
MkRECTANGLE bx1 by1 bw bh = b Rectangle bx1 by1 bw bh = b
ax2 = fromIntegral ax1 + fromIntegral aw ax2 = ax1 + aw
ay2 = fromIntegral ay1 + fromIntegral ah ay2 = ay1 + ah
bx2 = fromIntegral bx1 + fromIntegral bw bx2 = bx1 + bw
by2 = fromIntegral by1 + fromIntegral bh by2 = by1 + bh
data SurfaceSlice = SurfaceSlice !Int !Surface data SurfaceSlice = SurfaceSlice !Int !Surface
class Eq s => Widget w s c | w -> s, w -> c where class (Eq s, Display d) => Widget w s c d | w -> s, w -> c, w -> d where
initWidget :: w -> Phi -> Display -> [(RECTANGLE, WINDOW)] -> IO s initWidget :: w -> Phi -> d -> [(Rectangle, Window d)] -> IO s
initCache :: w -> c initCache :: w -> c
minSize :: w -> s -> Int -> RECTANGLE -> Int minSize :: w -> s -> Int -> Rectangle -> Int
weight :: w -> Float weight :: w -> Float
weight _ = 0 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 :: w -> s -> Message -> s
handleMessage _ priv _ = priv handleMessage _ priv _ = priv
deriving instance Eq RECTANGLE
type IOCache = CacheArrow (Kleisli IO) 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 :: Eq a => (a -> IO b) -> IOCache a b
createIOCache = lift . Kleisli createIOCache = lift . Kleisli
@ -103,8 +89,8 @@ runIOCache a = do
put cache' put cache'
return b return b
createRenderCache :: (s -> Int -> Int -> Int -> Int -> RECTANGLE -> Render ()) createRenderCache :: (s -> Int -> Int -> Int -> Int -> Rectangle -> Render ())
-> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, RECTANGLE) Surface -> CacheArrow (Kleisli IO) (s, Int, Int, Int, Int, Rectangle) Surface
createRenderCache f = lift . Kleisli $ \(state, x, y, w, h, screen) -> do createRenderCache f = lift . Kleisli $ \(state, x, y, w, h, screen) -> do
surface <- createImageSurface FormatARGB32 w h surface <- createImageSurface FormatARGB32 w h
renderWith surface $ do 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 f state x y w h screen
return surface 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 renderCached state x y w h screen = do
cache <- get cache <- get
(surf, updated, cache') <- liftIO $ runKleisli (runCache' cache) (state, x, y, w, h, screen) (surf, updated, cache') <- liftIO $ runKleisli (runCache' cache) (state, x, y, w, h, screen)
put cache' put cache'
return [(updated, SurfaceSlice 0 surf)] 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 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) 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) 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) 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) 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 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 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 () initWidget _ _ _ _ = return ()
initCache _ = createRenderCache $ \_ _ _ _ _ _ -> do initCache _ = createRenderCache $ \_ _ _ _ _ _ -> do
setOperator OperatorClear setOperator OperatorClear
@ -173,5 +159,5 @@ instance Widget Separator () (RenderCache ()) where
render _ = renderCached render _ = renderCached
separator :: Int -> Float -> Separator separator :: Int -> Float -> Separator d
separator = Separator separator = Separator

8
lib/Phi/Widgets/AlphaBox.hs
View file

@ -13,11 +13,11 @@ import Control.Monad.State.Strict
import Graphics.Rendering.Cairo 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 initWidget (AlphaBox _ w) = initWidget w
initCache (AlphaBox _ w) = AlphaBoxCache $ initCache 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 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 alphaBox = AlphaBox

6
lib/Phi/Widgets/Clock.hs
View file

@ -34,7 +34,7 @@ data ClockConfig = ClockConfig { clockFormat :: !String
defaultClockConfig :: ClockConfig defaultClockConfig :: ClockConfig
defaultClockConfig = ClockConfig "%R" (0, 0, 0, 1) 0 50 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 deriving instance Eq ZonedTime
@ -42,7 +42,7 @@ data ClockState = ClockState !ZonedTime deriving (Show, Eq)
data ClockMessage = UpdateTime !ZonedTime deriving (Show, Typeable) 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 initWidget (Clock _) phi _ _ = do
forkIO $ forever $ do forkIO $ forever $ do
time <- getZonedTime time <- getZonedTime
@ -85,6 +85,6 @@ instance Widget Clock ClockState (RenderCache ClockState) where
_ -> priv _ -> priv
clock :: ClockConfig -> Clock clock :: ClockConfig -> Clock d
clock config = do clock config = do
Clock config Clock config

4
lib/Phi/Widgets/Systray.hs → lib/Phi/Widgets/X11/Systray.hs
View file

@ -1,7 +1,7 @@
{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}
module Phi.Widgets.Systray ( systray module Phi.Widgets.X11.Systray ( systray
) where ) where
import Control.Concurrent import Control.Concurrent
import Control.Monad import Control.Monad

154
lib/Phi/Widgets/Taskbar.hs → lib/Phi/Widgets/X11/Taskbar.hs
View file

@ -1,15 +1,15 @@
{-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses, DeriveDataTypeable, TypeSynonymInstances, FlexibleInstances #-}
module Phi.Widgets.Taskbar ( IconStyle module Phi.Widgets.X11.Taskbar ( IconStyle
, idIconStyle , idIconStyle
, desaturateIconStyle , desaturateIconStyle
, TaskStyle(..) , TaskStyle(..)
, DesktopStyle(..) , DesktopStyle(..)
, TaskbarConfig(..) , TaskbarConfig(..)
, defaultTaskbarConfig , defaultTaskbarConfig
, Taskbar , Taskbar
, taskbar , taskbar
) where ) where
import Control.Arrow import Control.Arrow
import Control.Concurrent import Control.Concurrent
@ -48,6 +48,7 @@ import Phi.Phi
import Phi.Types import Phi.Types
import Phi.Border import Phi.Border
import Phi.Widget import Phi.Widget
import Phi.X11
import Phi.X11.Atoms import Phi.X11.Atoms
import Phi.X11.Util import Phi.X11.Util
@ -138,7 +139,7 @@ defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 200
data Taskbar = Taskbar TaskbarConfig data Taskbar = Taskbar TaskbarConfig
data TaskbarState = TaskbarState { taskbarScreens :: ![RECTANGLE] data TaskbarState = TaskbarState { taskbarScreens :: ![Rectangle]
, taskbarActiveWindow :: !WINDOW , taskbarActiveWindow :: !WINDOW
, taskbarDesktopCount :: !Int , taskbarDesktopCount :: !Int
, taskbarCurrentDesktop :: !Int , taskbarCurrentDesktop :: !Int
@ -161,7 +162,7 @@ data WindowState = WindowState { windowTitle :: !String
, windowDesktop :: !Int , windowDesktop :: !Int
, windowVisible :: !Bool , windowVisible :: !Bool
, windowIcons :: ![Icon] , windowIcons :: ![Icon]
, windowGeometry :: !RECTANGLE , windowGeometry :: !Rectangle
} deriving (Eq, Show) } deriving (Eq, Show)
data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Icon)) data WindowCache = WindowCache { createScaledIconCached :: !(IOCache ([Icon], Int) (Maybe Icon))
@ -208,7 +209,7 @@ data TaskbarMessage = WindowListUpdate ![WINDOW] !(M.Map WINDOW WindowState)
| ActiveWindowUpdate !WINDOW | ActiveWindowUpdate !WINDOW
deriving (Typeable, Show) 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 initWidget (Taskbar _) phi dispvar screens = do
phi' <- dupPhi phi phi' <- dupPhi phi
forkIO $ taskbarRunner phi' dispvar forkIO $ taskbarRunner phi' dispvar
@ -398,14 +399,14 @@ windowOnDesktop :: Int -> WindowState -> Bool
windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDesktop state) windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDesktop state)
taskbarRunner :: Phi -> Display -> IO () taskbarRunner :: Phi -> X11 -> IO ()
taskbarRunner phi dispvar = do taskbarRunner phi x11 = do
(windows, states) <- liftIO $ withDisplay dispvar $ \disp -> do (windows, states) <- liftIO $ do
(windows, states) <- getWindowStates disp (getAtoms dispvar) M.empty (windows, states) <- getWindowStates x11 M.empty
desktopCount <- getDesktopCount disp (getAtoms dispvar) desktopCount <- getDesktopCount x11
current <- getCurrentDesktop disp (getAtoms dispvar) current <- getCurrentDesktop x11
names <- getDesktopNames disp (getAtoms dispvar) names <- getDesktopNames x11
activeWindow <- getActiveWindow disp (getAtoms dispvar) activeWindow <- getActiveWindow x11
sendMessage phi $ WindowListUpdate windows states sendMessage phi $ WindowListUpdate windows states
sendMessage phi $ DesktopCountUpdate desktopCount sendMessage phi $ DesktopCountUpdate desktopCount
sendMessage phi $ CurrentDesktopUpdate current sendMessage phi $ CurrentDesktopUpdate current
@ -418,22 +419,23 @@ taskbarRunner phi dispvar = do
m <- receiveMessage phi m <- receiveMessage phi
case (fromMessage m) of case (fromMessage m) of
Just (XEvent event) -> Just (XEvent event) ->
handleEvent phi dispvar event handleEvent phi x11 event
_ -> _ ->
return () return ()
handleEvent :: Phi -> Display -> SomeEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () handleEvent :: Phi -> X11 -> SomeEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO ()
handleEvent phi dispvar event = handleEvent phi x11 event =
case (fromEvent event) of case (fromEvent event) of
Just e -> handlePropertyNotifyEvent phi dispvar e Just e -> handlePropertyNotifyEvent phi x11 e
Nothing -> case (fromEvent event) of Nothing -> case (fromEvent event) of
Just e -> handleConfigureNotifyEvent phi dispvar e Just e -> handleConfigureNotifyEvent phi x11 e
Nothing -> return () Nothing -> return ()
handlePropertyNotifyEvent :: Phi -> Display -> PropertyNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () handlePropertyNotifyEvent :: Phi -> X11 -> PropertyNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO ()
handlePropertyNotifyEvent phi dispvar MkPropertyNotifyEvent {atom_PropertyNotifyEvent = atom, window_PropertyNotifyEvent = window} = do handlePropertyNotifyEvent phi x11 MkPropertyNotifyEvent {atom_PropertyNotifyEvent = atom, window_PropertyNotifyEvent = window} = do
let atoms = getAtoms dispvar let atoms = x11Atoms x11
rootwin = root_SCREEN . x11Screen $ x11
when (elem atom $ map ($ atoms) [ atom_NET_ACTIVE_WINDOW when (elem atom $ map ($ atoms) [ atom_NET_ACTIVE_WINDOW
, atom_NET_NUMBER_OF_DESKTOPS , atom_NET_NUMBER_OF_DESKTOPS
@ -445,29 +447,28 @@ handlePropertyNotifyEvent phi dispvar MkPropertyNotifyEvent {atom_PropertyNotify
, atom_NET_WM_NAME , atom_NET_WM_NAME
, atom_NET_WM_DESKTOP , atom_NET_WM_DESKTOP
, atom_NET_WM_STATE , atom_NET_WM_STATE
]) $ withDisplay dispvar $ \conn -> do ]) $ do
let rootwin = getRoot conn
if (window == rootwin) if (window == rootwin)
then do then do
when (atom == atom_NET_ACTIVE_WINDOW atoms) $ do when (atom == atom_NET_ACTIVE_WINDOW atoms) $ do
activeWindow <- liftIO $ getActiveWindow conn atoms activeWindow <- liftIO $ getActiveWindow x11
sendMessage phi $ ActiveWindowUpdate activeWindow sendMessage phi $ ActiveWindowUpdate activeWindow
sendMessage phi Repaint sendMessage phi Repaint
when (atom == atom_NET_NUMBER_OF_DESKTOPS atoms) $ do when (atom == atom_NET_NUMBER_OF_DESKTOPS atoms) $ do
desktopCount <- liftIO $ getDesktopCount conn atoms desktopCount <- liftIO $ getDesktopCount x11
sendMessage phi $ DesktopCountUpdate desktopCount sendMessage phi $ DesktopCountUpdate desktopCount
sendMessage phi Repaint sendMessage phi Repaint
when (atom == atom_NET_CURRENT_DESKTOP atoms) $ do when (atom == atom_NET_CURRENT_DESKTOP atoms) $ do
current <- liftIO $ getCurrentDesktop conn atoms current <- liftIO $ getCurrentDesktop x11
sendMessage phi $ CurrentDesktopUpdate current sendMessage phi $ CurrentDesktopUpdate current
sendMessage phi Repaint sendMessage phi Repaint
when (atom == atom_NET_DESKTOP_NAMES atoms) $ do when (atom == atom_NET_DESKTOP_NAMES atoms) $ do
names <- liftIO $ getDesktopNames conn atoms names <- liftIO $ getDesktopNames x11
sendMessage phi $ DesktopNamesUpdate names sendMessage phi $ DesktopNamesUpdate names
sendMessage phi Repaint sendMessage phi Repaint
when (atom == atom_NET_CLIENT_LIST atoms) $ do when (atom == atom_NET_CLIENT_LIST atoms) $ do
(windows, windowStates) <- get (windows, windowStates) <- get
(windows', windowStates') <- liftIO $ getWindowStates conn atoms windowStates (windows', windowStates') <- liftIO $ getWindowStates x11 windowStates
when (windows /= windows') $ do when (windows /= windows') $ do
sendMessage phi $ WindowListUpdate windows' windowStates' sendMessage phi $ WindowListUpdate windows' windowStates'
@ -479,14 +480,14 @@ handlePropertyNotifyEvent phi dispvar MkPropertyNotifyEvent {atom_PropertyNotify
when (elem window windows) $ do when (elem window windows) $ do
case () of case () of
_ | (atom == atom_NET_WM_ICON atoms) -> do _ | (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 let windowStates' = M.update (\state -> Just state {windowIcons = icons}) window windowStates
sendMessage phi $ WindowListUpdate windows windowStates' sendMessage phi $ WindowListUpdate windows windowStates'
sendMessage phi Repaint sendMessage phi Repaint
put (windows, windowStates') put (windows, windowStates')
| otherwise -> do | otherwise -> do
(name, desktop, visible) <- liftIO $ getWindowInfo conn atoms window (name, desktop, visible) <- liftIO $ getWindowInfo x11 window
let mwindowState = M.lookup window windowStates let mwindowState = M.lookup window windowStates
case mwindowState of case mwindowState of
Just windowState -> do Just windowState -> do
@ -501,12 +502,13 @@ handlePropertyNotifyEvent phi dispvar MkPropertyNotifyEvent {atom_PropertyNotify
return () return ()
handleConfigureNotifyEvent :: Phi -> Display -> ConfigureNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO () handleConfigureNotifyEvent :: Phi -> X11 -> ConfigureNotifyEvent -> StateT ([WINDOW], M.Map WINDOW WindowState) IO ()
handleConfigureNotifyEvent phi dispvar MkConfigureNotifyEvent {window_ConfigureNotifyEvent = window} = do handleConfigureNotifyEvent phi x11 MkConfigureNotifyEvent {window_ConfigureNotifyEvent = window} = do
let conn = x11Connection x11
(windows, windowStates) <- get (windows, windowStates) <- get
when (elem window windows) $ withDisplay dispvar $ \conn -> do when (elem window windows) $ do
let geom = fmap windowGeometry . M.lookup window $ windowStates let geom = fmap windowGeometry . M.lookup window $ windowStates
geom' <- liftIO $ getWindowGeometry conn window geom' <- liftIO $ getWindowGeometry x11 window
when (geom /= (Just geom')) $ do when (geom /= (Just geom')) $ do
let windowStates' = M.update (\state -> Just state {windowGeometry = geom'}) window windowStates let windowStates' = M.update (\state -> Just state {windowGeometry = geom'}) window windowStates
sendMessage phi $ WindowListUpdate windows windowStates' sendMessage phi $ WindowListUpdate windows windowStates'
@ -514,30 +516,30 @@ handleConfigureNotifyEvent phi dispvar MkConfigureNotifyEvent {window_ConfigureN
put (windows, windowStates') put (windows, windowStates')
getDesktopCount :: Connection -> Atoms -> IO Int getDesktopCount :: X11 -> IO Int
getDesktopCount conn atoms = getDesktopCount x11 =
liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 conn (getRoot conn) (atom_NET_NUMBER_OF_DESKTOPS atoms) 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 :: X11 -> IO Int
getCurrentDesktop conn atoms = getCurrentDesktop x11 =
liftM (fromIntegral . fromMaybe (-1) . join . fmap listToMaybe) $ getProperty32 conn (getRoot conn) (atom_NET_CURRENT_DESKTOP atoms) 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 :: X11 -> IO [String]
getDesktopNames conn atoms = getDesktopNames x11 =
liftM (map (decode . map fromIntegral) . break' . fromMaybe []) $ getProperty8 conn (getRoot conn) (atom_NET_DESKTOP_NAMES atoms) liftM (map (decode . map fromIntegral) . break' . fromMaybe []) $ getProperty8 (x11Connection x11) (root_SCREEN . x11Screen $ x11) (atom_NET_DESKTOP_NAMES . x11Atoms $ x11)
where where
break' l = case dropWhile (== 0) l of break' l = case dropWhile (== 0) l of
[] -> [] [] -> []
l' -> w : break' l'' l' -> w : break' l''
where (w, l'') = break (== 0) l' where (w, l'') = break (== 0) l'
getActiveWindow :: Connection -> Atoms -> IO WINDOW getActiveWindow :: X11 -> IO WINDOW
getActiveWindow conn atoms = getActiveWindow x11 =
liftM (fromXid . toXid . fromMaybe 0 . join . fmap listToMaybe) $ getProperty32 conn (getRoot conn) (atom_NET_ACTIVE_WINDOW atoms) 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 :: X11 -> M.Map WINDOW WindowState -> IO ([WINDOW], M.Map WINDOW WindowState)
getWindowStates conn atoms windowStates = do getWindowStates x11 windowStates = do
windows <- getWindowList conn atoms windows <- getWindowList x11
let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows
@ -547,15 +549,15 @@ getWindowStates conn atoms windowStates = do
where where
getWindowState' (window, Just windowState) = return (window, windowState) getWindowState' (window, Just windowState) = return (window, windowState)
getWindowState' (window, Nothing) = do getWindowState' (window, Nothing) = do
changeWindowAttributes conn window $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])] changeWindowAttributes (x11Connection x11) window $ toValueParam [(CWEventMask, toMask [EventMaskPropertyChange, EventMaskStructureNotify])]
windowState <- getWindowState conn atoms window windowState <- getWindowState x11 window
return (window, windowState) return (window, windowState)
getWindowState :: Connection -> Atoms -> WINDOW -> IO WindowState getWindowState :: X11 -> WINDOW -> IO WindowState
getWindowState conn atoms window = do getWindowState x11 window = do
(name, workspace, visible) <- getWindowInfo conn atoms window (name, workspace, visible) <- getWindowInfo x11 window
icons <- getWindowIcons conn atoms window icons <- getWindowIcons x11 window
geom <- getWindowGeometry conn window geom <- getWindowGeometry x11 window
return $ WindowState { windowTitle = name return $ WindowState { windowTitle = name
, windowDesktop = workspace , windowDesktop = workspace
@ -564,8 +566,10 @@ getWindowState conn atoms window = do
, windowGeometry = geom , windowGeometry = geom
} }
getWindowInfo :: Connection -> Atoms -> WINDOW -> IO (String, Int, Bool) getWindowInfo :: X11 -> WINDOW -> IO (String, Int, Bool)
getWindowInfo conn atoms window = do 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) netwmname <- liftM (fmap (decode . map fromIntegral)) $ getProperty8 conn window (atom_NET_WM_NAME atoms)
wmname <- case netwmname of wmname <- case netwmname of
Just name -> return name Just name -> return name
@ -578,8 +582,8 @@ getWindowInfo conn atoms window = do
where where
unsignedChr = chr . fromIntegral unsignedChr = chr . fromIntegral
getWindowIcons :: Connection -> Atoms -> WINDOW -> IO [Icon] getWindowIcons :: X11 -> WINDOW -> IO [Icon]
getWindowIcons conn atoms window = getProperty32 conn window (atom_NET_WM_ICON atoms) >>= readIcons . fromMaybe [] getWindowIcons x11 window = getProperty32 (x11Connection x11) window (atom_NET_WM_ICON . x11Atoms $ x11) >>= readIcons . fromMaybe []
readIcons :: [Word32] -> IO [Icon] readIcons :: [Word32] -> IO [Icon]
@ -612,9 +616,13 @@ premultiply c = a .|. r .|. g .|. b
b = pm bmask b = pm bmask
getWindowGeometry :: Connection -> WINDOW -> IO RECTANGLE getWindowGeometry :: X11 -> WINDOW -> IO Rectangle
getWindowGeometry conn window = getWindowGeometry x11 window =
getGeometry conn (fromXid . toXid $ window) >>= getReply >>= return . ((const $ MkRECTANGLE 0 0 0 0) ||| (\(MkGetGeometryReply _ _ x y width height _) -> MkRECTANGLE x y width height)) 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 :: Connection -> Atoms -> WINDOW -> IO Bool
showWindow conn atoms window = do showWindow conn atoms window = do
@ -634,8 +642,8 @@ showWindow conn atoms window = do
] ]
getWindowList :: Connection -> Atoms -> IO [WINDOW] getWindowList :: X11 -> IO [WINDOW]
getWindowList conn atoms = liftM (map (fromXid . toXid) . join . maybeToList) $ getProperty32 conn (getRoot conn) (atom_NET_CLIENT_LIST atoms) 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 :: TaskbarConfig -> Taskbar
taskbar = Taskbar taskbar = Taskbar

292
lib/Phi/X11.hs
View file

@ -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 , defaultXConfig
, runPhi , runPhi
) where ) 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.Xinerama
import Graphics.XHB.Gen.Xproto import Graphics.XHB.Gen.Xproto hiding (Window)
import Graphics.Rendering.Cairo import Graphics.Rendering.Cairo
@ -36,33 +40,51 @@ import Phi.Phi
import Phi.X11.Util import Phi.X11.Util
import qualified Phi.Types as Phi import qualified Phi.Types as Phi
import qualified Phi.Panel as Panel import qualified Phi.Panel as Panel
import qualified Phi.Widget as Widget import qualified Phi.Widget as Widget (handleMessage)
import Phi.Widget hiding (Display, handleMessage) import Phi.Widget hiding (handleMessage)
import Phi.X11.Atoms 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 data PhiState w s c = (Widget w s c X11) => PhiState { phiRootImage :: !Surface
, phiPanels :: ![PanelState w s c] , phiPanels :: ![PanelState w s c]
, phiRepaint :: !Bool , phiRepaint :: !Bool
, phiShutdown :: !Bool , phiShutdown :: !Bool
, phiShutdownHold :: !Int , phiShutdownHold :: !Int
, phiWidgetState :: !s , phiWidgetState :: !s
} }
data PanelState w s c = (Widget.Widget w s c) => PanelState { panelWindow :: !WINDOW data PanelState w s c = (Widget w s c X11) => PanelState { panelWindow :: !WINDOW
, panelPixmap :: !PIXMAP , panelPixmap :: !PIXMAP
, panelArea :: !RECTANGLE , panelArea :: !Rectangle
, panelScreenArea :: !RECTANGLE , panelScreenArea :: !Rectangle
, panelWidgetCache :: !c , panelWidgetCache :: !c
} }
data PhiConfig w s c = PhiConfig { phiPhi :: !Phi data PhiConfig w s c = PhiConfig { phiPhi :: !Phi
, phiPanelConfig :: !Panel.PanelConfig , phiPanelConfig :: !Panel.PanelConfig
, phiXConfig :: !XConfig , phiXConfig :: !XConfig
, phiAtoms :: !Atoms , phiX11 :: !X11
, phiXCB :: !XCB.Connection
, phiWidget :: !w , phiWidget :: !w
} }
@ -81,17 +103,22 @@ runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st
defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
} }
getScreenInfo :: Connection -> IO [RECTANGLE] getScreenInfo :: X11 -> IO [Rectangle]
getScreenInfo conn = do getScreenInfo x11 = do
let conn = x11Connection x11
screen = x11Screen x11
exs <- queryScreens conn >>= getReply exs <- queryScreens conn >>= getReply
case exs of case exs of
Right xs -> return . map screenInfoToRect $ screen_info_QueryScreensReply xs Right xs -> return . map screenInfoToRect $ screen_info_QueryScreensReply xs
Left _ -> getGeometry conn (fromXid . toXid $ getRoot conn) >>= getReply' "getScreenInfo: getGeometry failed" >>= Left _ -> getGeometry conn (fromXid . toXid $ root_SCREEN screen) >>= getReply' "getScreenInfo: getGeometry failed" >>=
return . (\(MkGetGeometryReply _ _ x y w h _) -> [MkRECTANGLE x y w h]) return . (\(MkGetGeometryReply _ _ x y w h _) -> [Rectangle (fi x) (fi y) (fi w) (fi h)])
where 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 runPhi xconfig config widget = do
phi <- initPhi phi <- initPhi
@ -102,24 +129,30 @@ runPhi xconfig config widget = do
conn <- liftM fromJust connect conn <- liftM fromJust connect
xcb <- XCB.connect xcb <- XCB.connect
let dispname = displayInfo conn
screen = (roots_Setup . connectionSetup $ conn) !! CO.screen dispname
atoms <- initAtoms conn 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 bg <- createImageSurface FormatRGB24 1 1
screens <- liftIO $ phiXScreenInfo xconfig conn let x11 = X11 conn atoms screen
panelWindows <- mapM (createPanelWindow conn config) screens
let dispvar = Widget.Display conn atoms screens <- liftIO $ phiXScreenInfo xconfig x11
widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1) panelWindows <- mapM (createPanelWindow conn screen config) screens
let widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1)
screenPanels = zip screens panelWindows screenPanels = zip screens panelWindows
initialState <- Widget.initWidget widget' phi dispvar screenPanels initialState <- initWidget widget' phi x11 screenPanels
runPhiX runPhiX
PhiConfig { phiPhi = phi PhiConfig { phiPhi = phi
, phiXConfig = xconfig , phiXConfig = xconfig
, phiPanelConfig = config , phiPanelConfig = config
, phiAtoms = atoms , phiX11 = x11
, phiXCB = xcb
, phiWidget = widget' , phiWidget = widget'
} }
PhiState { phiRootImage = bg PhiState { phiRootImage = bg
@ -129,15 +162,15 @@ runPhi xconfig config widget = do
, phiShutdownHold = 0 , phiShutdownHold = 0
, phiWidgetState = initialState , phiWidgetState = initialState
} $ do } $ 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 } modify $ \state -> state { phiPanels = panels }
updatePanels conn xcb updatePanels
forM_ panels $ liftIO . mapWindow conn . panelWindow forM_ panels $ liftIO . mapWindow conn . panelWindow
@ -150,11 +183,11 @@ runPhi xconfig config widget = do
available <- messageAvailable phi available <- messageAvailable phi
when (not available && repaint) $ do when (not available && repaint) $ do
updatePanels conn xcb updatePanels
modify $ \state -> state {phiRepaint = False} modify $ \state -> state {phiRepaint = False}
message <- receiveMessage phi message <- receiveMessage phi
handleMessage conn xcb message handleMessage message
case (fromMessage message) of case (fromMessage message) of
Just Shutdown -> Just Shutdown ->
@ -179,8 +212,8 @@ termHandler :: Phi -> Handler
termHandler phi = Catch $ sendMessage phi Shutdown termHandler phi = Catch $ sendMessage phi Shutdown
handleMessage :: (Widget w s c) => Connection -> XCB.Connection -> Message -> PhiX w s c () handleMessage :: (Widget w s c X11) => Message -> PhiX w s c ()
handleMessage conn xcb m = do handleMessage m = do
w <- asks phiWidget w <- asks phiWidget
modify $ \state -> state {phiWidgetState = Widget.handleMessage w (phiWidgetState state) m} modify $ \state -> state {phiWidgetState = Widget.handleMessage w (phiWidgetState state) m}
@ -190,81 +223,86 @@ handleMessage conn xcb m = do
_ -> _ ->
case (fromMessage m) of case (fromMessage m) of
Just (XEvent event) -> Just (XEvent event) ->
handleEvent conn xcb event handleEvent event
_ -> _ ->
return () return ()
handleEvent :: (Widget w s c) => Connection -> XCB.Connection -> SomeEvent -> PhiX w s c () handleEvent :: (Widget w s c X11) => SomeEvent -> PhiX w s c ()
handleEvent conn xcb event = handleEvent event =
case (fromEvent event) of case (fromEvent event) of
Just e -> handlePropertyNotifyEvent conn xcb e Just e -> handlePropertyNotifyEvent e
Nothing -> case (fromEvent event) of Nothing -> case (fromEvent event) of
Just e -> handleConfigureNotifyEvent conn e Just e -> handleConfigureNotifyEvent e
Nothing -> return () Nothing -> return ()
handlePropertyNotifyEvent :: (Widget w s c) => Connection -> XCB.Connection -> PropertyNotifyEvent -> PhiX w s c () handlePropertyNotifyEvent :: (Widget w s c X11) => PropertyNotifyEvent -> PhiX w s c ()
handlePropertyNotifyEvent conn xcb MkPropertyNotifyEvent { atom_PropertyNotifyEvent = atom } = do handlePropertyNotifyEvent MkPropertyNotifyEvent { atom_PropertyNotifyEvent = atom } = do
phi <- asks phiPhi phi <- asks phiPhi
atoms <- asks phiAtoms atoms <- asks (x11Atoms . phiX11)
panels <- gets phiPanels panels <- gets phiPanels
when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do
updateRootImage conn xcb updateRootImage
sendMessage phi ResetBackground sendMessage phi ResetBackground
sendMessage phi Repaint sendMessage phi Repaint
handleConfigureNotifyEvent :: (Widget w s c) => Connection -> ConfigureNotifyEvent -> PhiX w s c () handleConfigureNotifyEvent :: (Widget w s c X11) => ConfigureNotifyEvent -> PhiX w s c ()
handleConfigureNotifyEvent conn MkConfigureNotifyEvent { window_ConfigureNotifyEvent = window } | window == getRoot conn = do handleConfigureNotifyEvent MkConfigureNotifyEvent { window_ConfigureNotifyEvent = window } = do
phi <- asks phiPhi x11 <- asks phiX11
xconfig <- asks phiXConfig let conn = x11Connection x11
config <- asks phiPanelConfig screen = x11Screen x11
panels <- gets phiPanels rootWindow = root_SCREEN screen
let screens = map panelScreenArea panels when (window == rootWindow) $ do
screens' <- liftIO $ phiXScreenInfo xconfig conn 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 when (screens /= screens') $ do
liftIO $ do liftIO $ do
mapM_ (freePixmap conn . panelPixmap) panels mapM_ (freePixmap conn . panelPixmap) panels
mapM_ (destroyWindow conn . panelWindow) $ drop (length screens') 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) -> panels' <- forM panelsScreens $ \(screenarea, mpanel) ->
case mpanel of case mpanel of
Just panel -> do Just panel -> do
let rect = panelBounds config screen let rect = panelBounds config screenarea
win = panelWindow panel win = panelWindow panel
liftIO $ configureWindow conn win $ toValueParam [ (ConfigWindowX, fromIntegral $ x_RECTANGLE rect) liftIO $ configureWindow conn win $ toValueParam [ (ConfigWindowX, fromIntegral $ rect_x rect)
, (ConfigWindowY, fromIntegral $ y_RECTANGLE rect) , (ConfigWindowY, fromIntegral $ rect_y rect)
, (ConfigWindowWidth, fromIntegral $ width_RECTANGLE rect) , (ConfigWindowWidth, fromIntegral $ rect_width rect)
, (ConfigWindowHeight, fromIntegral $ height_RECTANGLE rect) , (ConfigWindowHeight, fromIntegral $ rect_height rect)
] ]
panel' <- createPanel conn win screen panel' <- createPanel win screenarea
setPanelProperties conn panel' setPanelProperties panel'
return panel' return panel'
Nothing -> do Nothing -> do
win <- liftIO $ createPanelWindow conn config screen win <- liftIO $ createPanelWindow conn screen config screenarea
panel <- createPanel conn win screen panel <- createPanel win screenarea
setPanelProperties conn panel setPanelProperties panel
liftIO $ mapWindow conn $ panelWindow panel liftIO $ mapWindow conn $ panelWindow panel
return panel return panel
modify $ \state -> state { phiPanels = panels' } modify $ \state -> state { phiPanels = panels' }
sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels' sendMessage phi $ UpdateScreens $ map (panelScreenArea &&& panelWindow) panels'
sendMessage phi Repaint sendMessage phi Repaint
handleConfigureNotifyEvent _ _ = return ()
receiveEvents :: Phi -> Connection -> IO () receiveEvents :: Phi -> Connection -> IO ()
receiveEvents phi conn = do receiveEvents phi conn = do
forever $ waitForEvent conn >>= sendMessage phi . XEvent forever $ waitForEvent conn >>= sendMessage phi . XEvent
updatePanels :: (Widget w s c) => Connection -> XCB.Connection -> PhiX w s c () updatePanels :: (Widget w s c X11) => PhiX w s c ()
updatePanels conn xcb = do updatePanels = do
X11 conn _ screen <- asks phiX11
xcb <- asks phiXCB
w <- asks phiWidget w <- asks phiWidget
s <- gets phiWidgetState s <- gets phiWidgetState
rootImage <- gets phiRootImage rootImage <- gets phiRootImage
@ -275,17 +313,16 @@ updatePanels conn xcb = do
area = panelArea panel area = panelArea panel
(panelSurfaces, cache') <- liftIO $ flip runStateT (panelWidgetCache 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 let visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
xbuffer <- liftIO $ withDimension area $ XCB.createXCBSurface xcb (fromXid . toXid $ pixmap) visualtype xbuffer <- liftIO $ withDimension area $ XCB.createXCBSurface xcb (fromXid . toXid $ pixmap) visualtype
liftIO $ (withDimension area $ withSimilarSurface xbuffer ContentColor) $ \buffer -> do liftIO $ (withDimension area $ withSimilarSurface xbuffer ContentColor) $ \buffer -> do
renderWith buffer $ do renderWith buffer $ do
save save
translate (-(fromIntegral $ x_RECTANGLE area)) (-(fromIntegral $ y_RECTANGLE area)) translate (-(fromIntegral $ rect_x area)) (-(fromIntegral $ rect_y area))
withPatternForSurface rootImage $ \pattern -> do withPatternForSurface rootImage $ \pattern -> do
patternSetExtend pattern ExtendRepeat patternSetExtend pattern ExtendRepeat
setSource pattern setSource pattern
@ -313,12 +350,12 @@ updatePanels conn xcb = do
modify $ \state -> state { phiPanels = panels' } modify $ \state -> state { phiPanels = panels' }
updateRootImage :: Connection -> XCB.Connection -> PhiX w s c () updateRootImage :: PhiX w s c ()
updateRootImage conn xcb = do updateRootImage = do
atoms <- asks phiAtoms X11 conn atoms screen <- asks phiX11
xcb <- asks phiXCB
let screen = head . roots_Setup . connectionSetup $ conn let visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
visualtype = fromJust $ findVisualtype screen (root_visual_SCREEN screen)
rootwin = root_SCREEN screen rootwin = root_SCREEN screen
pixmap <- liftM (fromXid . toXid . fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $ 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 () return ()
createPanel :: (Widget w s c) => Connection -> WINDOW -> RECTANGLE -> PhiX w s c (PanelState w s c) createPanel :: (Widget w s c X11) => WINDOW -> Rectangle -> PhiX w s c (PanelState w s c)
createPanel conn win screenRect = do createPanel win screenRect = do
(conn, screen) <- asks $ (x11Connection &&& x11Screen) . phiX11
config <- asks phiPanelConfig config <- asks phiPanelConfig
w <- asks phiWidget w <- asks phiWidget
let rect = panelBounds config screenRect let rect = panelBounds config screenRect
screen = head . roots_Setup . connectionSetup $ conn
depth = root_depth_SCREEN screen depth = root_depth_SCREEN screen
pixmap <- liftIO $ newResource conn pixmap <- liftIO $ newResource conn
@ -374,10 +411,9 @@ createPanel conn win screenRect = do
, panelWidgetCache = initCache w , panelWidgetCache = initCache w
} }
createPanelWindow :: Connection -> Panel.PanelConfig -> RECTANGLE -> IO WINDOW createPanelWindow :: Connection -> SCREEN -> Panel.PanelConfig -> Rectangle -> IO WINDOW
createPanelWindow conn config screenRect = do createPanelWindow conn screen config screenRect = do
let rect = panelBounds config screenRect let rect = panelBounds config screenRect
screen = head . roots_Setup . connectionSetup $ conn
depth = root_depth_SCREEN screen depth = root_depth_SCREEN screen
rootwin = root_SCREEN screen rootwin = root_SCREEN screen
visual = root_visual_SCREEN screen visual = root_visual_SCREEN screen
@ -387,9 +423,9 @@ createPanelWindow conn config screenRect = do
return win return win
setPanelProperties :: Connection -> PanelState w s c -> PhiX w s c () setPanelProperties :: PanelState w s c -> PhiX w s c ()
setPanelProperties conn panel = do setPanelProperties panel = do
atoms <- asks phiAtoms (conn, atoms) <- asks $ (x11Connection &&& x11Atoms) . phiX11
liftIO $ do liftIO $ do
let name = map (fromIntegral . ord) "Phi" let name = map (fromIntegral . ord) "Phi"
changeProperty8 conn PropModeReplace (panelWindow panel) (atomWM_NAME atoms) (atomSTRING atoms) name 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" 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 :: PanelState w s c -> PhiX w s c ()
setStruts conn panel = do setStruts panel = do
atoms <- asks phiAtoms X11 conn atoms screen <- asks phiX11
config <- asks phiPanelConfig config <- asks phiPanelConfig
let rootwin = getRoot conn let rootwin = root_SCREEN screen
position = Panel.panelPosition config position = Panel.panelPosition config
area = panelArea panel area = panelArea panel
rootHeight <- liftIO $ getGeometry conn (fromXid . toXid $ rootwin) >>= getReply' "setStruts: getGeometry failed" >>= return . height_GetGeometryReply rootHeight <- liftIO $ getGeometry conn (fromXid . toXid $ rootwin) >>= getReply' "setStruts: getGeometry failed" >>= return . height_GetGeometryReply
let struts = [makeStruts i | i <- [0..11]] let struts = [makeStruts i | i <- [0..11]]
where where
makeTopStruts 2 = (fromIntegral $ y_RECTANGLE area) + (fromIntegral $ height_RECTANGLE area) makeTopStruts 2 = (fromIntegral $ rect_y area) + (fromIntegral $ rect_height area)
makeTopStruts 8 = (fromIntegral $ x_RECTANGLE area) makeTopStruts 8 = (fromIntegral $ rect_x area)
makeTopStruts 9 = (fromIntegral $ x_RECTANGLE area) + (fromIntegral $ width_RECTANGLE area) - 1 makeTopStruts 9 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1
makeTopStruts _ = 0 makeTopStruts _ = 0
makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ y_RECTANGLE area) makeBottomStruts 3 = (fromIntegral rootHeight) - (fromIntegral $ rect_y area)
makeBottomStruts 10 = (fromIntegral $ x_RECTANGLE area) makeBottomStruts 10 = (fromIntegral $ rect_x area)
makeBottomStruts 11 = (fromIntegral $ x_RECTANGLE area) + (fromIntegral $ width_RECTANGLE area) - 1 makeBottomStruts 11 = (fromIntegral $ rect_x area) + (fromIntegral $ rect_width area) - 1
makeBottomStruts _ = 0 makeBottomStruts _ = 0
makeStruts = case position of 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 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 panelBounds config screenBounds = case Panel.panelPosition config of
Phi.Top -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config } Phi.Top -> screenBounds { rect_height = Panel.panelSize config }
Phi.Bottom -> screenBounds { height_RECTANGLE = fromIntegral $ Panel.panelSize config, Phi.Bottom -> screenBounds { rect_height = Panel.panelSize config,
y_RECTANGLE = (y_RECTANGLE screenBounds) + (fromIntegral $ height_RECTANGLE screenBounds) - (fromIntegral $ 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 withRectangle r = withDimension r . withPosition r
withPosition :: (Num x, Num y) => RECTANGLE -> (x -> y -> a) -> a withPosition :: (Num x, Num y) => Rectangle -> (x -> y -> a) -> a
withPosition r f = f (fromIntegral $ x_RECTANGLE r) (fromIntegral $ y_RECTANGLE r) withPosition r f = f (fromIntegral $ rect_x r) (fromIntegral $ rect_y r)
withDimension :: (Num w, Num h) => RECTANGLE -> (w -> h -> a) -> a withDimension :: (Num w, Num h) => Rectangle -> (w -> h -> a) -> a
withDimension r f = f (fromIntegral $ width_RECTANGLE r) (fromIntegral $ height_RECTANGLE r) withDimension r f = f (fromIntegral $ rect_width r) (fromIntegral $ rect_height r)

2
phi.cabal
View file

@ -14,7 +14,7 @@ library
build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, xhb, build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, xhb,
cairo, pango, unix, data-accessor, arrows, CacheArrow cairo, pango, unix, data-accessor, arrows, CacheArrow
exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11 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 -- , Phi.Widgets.Systray
other-modules: Phi.X11.Util, Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.XCB other-modules: Phi.X11.Util, Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.XCB
include-dirs: include include-dirs: include

6
src/Phi.hs
View file

@ -6,8 +6,8 @@ import Phi.X11
import Phi.Widgets.AlphaBox import Phi.Widgets.AlphaBox
import Phi.Widgets.Clock import Phi.Widgets.Clock
import Phi.Widgets.Taskbar import Phi.Widgets.X11.Taskbar
--import Phi.Widgets.Systray --import Phi.Widgets.X11.Systray
main :: IO () main :: IO ()
@ -52,5 +52,5 @@ main = do
, lineSpacing = (-3) , lineSpacing = (-3)
, clockSize = 75 , 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 brightBorder = border normalDesktopBorder