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

Get rid of layout function

Browse source
This commit is contained in:
Matthias Schiffer 2011-08-29 15:10:55 +02:00
parent e48e3a6fe0
commit 7a87ba6f2e
7 changed files with 131 additions and 159 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

13
lib/Phi/Border.hs
View file

@ -79,17 +79,6 @@ instance Eq s => Widget (Border w s c) s (BorderCache w s c) where
weight (Border config _) = borderWeight config weight (Border config _) = borderWeight config
layout (Border config w) s width height screen = case True of
_ | width' > 0 -> layout w s width' height' screen
| otherwise -> s
where
m = margin config
bw = borderWidth config
p = padding config
width' = width - borderH m - 2*bw - borderH p
height' = height - borderV m - 2*bw - borderV p
render (Border config w) s x y width height screen = case () of render (Border config w) s x y width height screen = case () of
_ | (width > borderH m - 2*bw - borderH p) -> do _ | (width > borderH m - 2*bw - borderH p) -> do
border <- liftIO $ createImageSurface FormatARGB32 width height border <- liftIO $ createImageSurface FormatARGB32 width height
@ -104,7 +93,7 @@ instance Eq s => Widget (Border w s c) s (BorderCache w s c) where
let surfaces' = (True, 0, Nothing):(map (\(updated, SurfaceSlice x surf) -> (updated, x+dx, Just surf)) surfaces)++[(True, width-rightWidth, Nothing)] let surfaces' = (True, 0, Nothing):(map (\(updated, SurfaceSlice x surf) -> (updated, x+dx, Just surf)) surfaces)++[(True, width-rightWidth, Nothing)]
surfacesWidths = zipWith (\(updated, x, surf) (_, x', _) -> (updated, x, x'-x, surf)) surfaces' (tail surfaces' ++ [(False, width, Nothing)]) surfacesWidths = zipWith (\(updated, x, surf) (_, x', _) -> (updated, x, x'-x, surf)) surfaces' (tail surfaces' ++ [(False, width, Nothing)])
forM surfacesWidths $ \(updated, x, surfWidth, surf) -> do forM surfacesWidths $ \(updated, x, surfWidth, surf) -> do
surf' <- liftIO $ createImageSurface FormatARGB32 surfWidth height surf' <- liftIO $ createImageSurface FormatARGB32 surfWidth height
renderWith surf' $ do renderWith surf' $ do
setOperator OperatorClear setOperator OperatorClear
paint paint

54
lib/Phi/Widget.hs
View file

@ -1,10 +1,9 @@
{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-} {-# LANGUAGE ExistentialQuantification, StandaloneDeriving, DeriveDataTypeable, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-}
module Phi.Widget ( Display(..) module Phi.Widget ( Display(..)
, withDisplay , withDisplay
, getAtoms , getAtoms
, getScreenWindows , XMessage(..)
, getScreens
, unionArea , unionArea
, SurfaceSlice(..) , SurfaceSlice(..)
, Widget(..) , Widget(..)
@ -29,6 +28,7 @@ import Control.Monad.State.Strict hiding (lift)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Data.Maybe import Data.Maybe
import Data.Typeable
import qualified Graphics.X11.Xlib as Xlib import qualified Graphics.X11.Xlib as Xlib
import Graphics.Rendering.Cairo import Graphics.Rendering.Cairo
@ -37,23 +37,19 @@ import Phi.Phi
import Phi.X11.Atoms import Phi.X11.Atoms
data Display = Display !(MVar Xlib.Display) !Atoms ![(Xlib.Rectangle, Xlib.Window)] data Display = Display !(MVar Xlib.Display) !Atoms
withDisplay :: MonadIO m => Display -> (Xlib.Display -> m a) -> m a withDisplay :: MonadIO m => Display -> (Xlib.Display -> m a) -> m a
withDisplay (Display dispvar _ _) f = do withDisplay (Display dispvar _) f = do
disp <- liftIO $ takeMVar dispvar disp <- liftIO $ takeMVar dispvar
a <- f disp a <- f disp
liftIO $ putMVar dispvar disp liftIO $ putMVar dispvar disp
return a return a
getAtoms :: Display -> Atoms getAtoms :: Display -> Atoms
getAtoms (Display _ atoms _) = atoms getAtoms (Display _ atoms) = atoms
getScreenWindows :: Display -> [(Xlib.Rectangle, Xlib.Window)] data XMessage = UpdateScreens [(Xlib.Rectangle, Xlib.Window)] deriving (Show, Typeable)
getScreenWindows (Display _ _ screenWindows) = screenWindows
getScreens :: Display -> [Xlib.Rectangle]
getScreens = map fst . getScreenWindows
unionArea :: Xlib.Rectangle -> Xlib.Rectangle -> Int unionArea :: Xlib.Rectangle -> Xlib.Rectangle -> Int
@ -75,7 +71,7 @@ unionArea a b = fromIntegral $ uw*uh
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 => Widget w s c | w -> s, w -> c where
initWidget :: w -> Phi -> Display -> IO s initWidget :: w -> Phi -> Display -> [(Xlib.Rectangle, Xlib.Window)] -> IO s
initCache :: w -> c initCache :: w -> c
@ -84,9 +80,6 @@ class Eq s => Widget w s c | w -> s, w -> c where
weight :: w -> Float weight :: w -> Float
weight _ = 0 weight _ = 0
layout :: w -> s -> Int -> Int -> Xlib.Rectangle -> s
layout _ priv _ _ _ = priv
render :: w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> StateT c IO [(Bool, SurfaceSlice)] render :: w -> s -> Int -> Int -> Int -> Int -> Xlib.Rectangle -> StateT c IO [(Bool, SurfaceSlice)]
handleMessage :: w -> s -> Message -> s handleMessage :: w -> s -> Message -> s
@ -125,43 +118,36 @@ renderCached widget state x y w h screen = do
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 = (Widget a sa ca, Widget b sb cb) => CompoundWidget !a !b
data CompoundState a sa ca b sb cb = (Widget a sa ca, Widget b sb cb) => CompoundState !sa !sb !Int 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) deriving instance Eq (CompoundState a sa ca b sb cb)
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 = (Widget a sa ca, Widget b sb cb) => 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 Widget (CompoundWidget a sa ca b sb cb) (CompoundState a sa ca b sb cb) (CompoundCache a sa ca b sb cb) where
initWidget (CompoundWidget a b) phi disp = liftM3 CompoundState (initWidget a phi disp) (initWidget b phi disp) (return 0) 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)
minSize (CompoundWidget a b) (CompoundState da db _) height screen = minSize a da height screen + minSize b db height screen minSize (CompoundWidget a b) (CompoundState da db) height screen = minSize a da height screen + minSize b db height screen
weight (CompoundWidget a b) = weight' a + weight' b weight (CompoundWidget a b) = weight' a + weight' b
layout c@(CompoundWidget a b) s@(CompoundState sa sb _) width height screen = CompoundState sa' sb' xb render c@(CompoundWidget a b) s@(CompoundState sa sb) x y w h screen = do
where let sizesum = minSize c s h screen
sizesum = minSize c s height screen wsum = let wsum = weight c
wsum = let wsum = weight c in if wsum > 0 then wsum else 1
in if wsum > 0 then wsum else 1 surplus = w - sizesum
xb = floor $ (fromIntegral $ minSize a sa h screen) + (fromIntegral surplus)*(weight' a)/wsum
surplus = width - sizesum
(xb, sa') = layoutWidget a sa
(_, sb') = layoutWidget b sb
layoutWidget w s = let wWidth = floor $ (fromIntegral $ minSize w s height screen) + (fromIntegral surplus)*(weight' w)/wsum
in (wWidth, layout w s wWidth height screen)
render (CompoundWidget a b) (CompoundState sa sb xb) x y w h screen = do
CompoundCache ca cb <- get CompoundCache ca cb <- get
(surfacea, ca') <- liftIO $ flip runStateT ca $ render a sa x y xb h screen (surfacea, ca') <- liftIO $ flip runStateT ca $ render a sa x y xb h screen
(surfaceb, cb') <- liftIO $ flip runStateT cb $ render b sb (x+xb) y (w-xb) h screen (surfaceb, cb') <- liftIO $ flip runStateT cb $ render b sb (x+xb) y (w-xb) h screen
put $ CompoundCache ca' cb' put $ CompoundCache ca' cb'
return $ surfacea ++ map (\(updated, SurfaceSlice x surface) -> (updated, SurfaceSlice (x+xb) surface)) surfaceb return $ surfacea ++ map (\(updated, SurfaceSlice x surface) -> (updated, SurfaceSlice (x+xb) surface)) surfaceb
handleMessage (CompoundWidget a b) (CompoundState sa sb xb) message = CompoundState (handleMessage a sa message) (handleMessage b sb message) xb 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) => a -> Float
weight' = max 0 . weight weight' = max 0 . weight
@ -172,7 +158,7 @@ a <~> b = CompoundWidget a b
data Separator = Separator !Int !Float deriving (Show, Eq) data Separator = Separator !Int !Float deriving (Show, Eq)
instance Widget Separator () (RenderCache Separator ()) where instance Widget Separator () (RenderCache Separator ()) where
initWidget _ _ _ = return () initWidget _ _ _ _ = return ()
initCache _ = createRenderCache $ \_ _ _ _ _ _ _ -> do initCache _ = createRenderCache $ \_ _ _ _ _ _ _ -> do
setOperator OperatorClear setOperator OperatorClear
paint paint

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

@ -25,8 +25,6 @@ instance Eq s => Widget (AlphaBox w s c) s (AlphaBoxCache w s c) where
weight (AlphaBox _ w) = weight w weight (AlphaBox _ w) = weight w
layout (AlphaBox _ w) = layout w
render (AlphaBox alpha w) s x y width height screen = do render (AlphaBox alpha w) s x y width height screen = do
AlphaBoxCache c <- get AlphaBoxCache c <- get
(surfaces, c') <- liftIO $ flip runStateT c $ render w s x y width height screen (surfaces, c') <- liftIO $ flip runStateT c $ render w s x y width height screen

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

@ -43,7 +43,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 Clock ClockState) where instance Widget Clock ClockState (RenderCache Clock ClockState) where
initWidget (Clock _) phi _ = do initWidget (Clock _) phi _ _ = do
forkIO $ forever $ do forkIO $ forever $ do
time <- getZonedTime time <- getZonedTime
sendMessage phi $ UpdateTime time sendMessage phi $ UpdateTime time

33
lib/Phi/Widgets/Systray.hs
View file

@ -49,11 +49,11 @@ data SystrayMessage = AddIcon !Window !Window | RemoveIcon !Window | RenderIcon
instance Widget Systray SystrayState (RenderCache Systray SystrayState) where instance Widget Systray SystrayState (RenderCache Systray SystrayState) where
initWidget (Systray) phi dispvar = do initWidget (Systray) phi dispvar screens = do
phi' <- dupPhi phi phi' <- dupPhi phi
forkIO $ systrayRunner phi' dispvar forkIO $ systrayRunner phi' dispvar $ snd . head $ screens
return $ SystrayState phi (head . getScreens $ dispvar) 0 [] return $ SystrayState phi (fst . head $ screens) 0 []
initCache _ = createRenderCache $ \Systray (SystrayState phi systrayScreen reset icons) x y w h screen -> do initCache _ = createRenderCache $ \Systray (SystrayState phi systrayScreen reset icons) x y w h screen -> do
when (screen == systrayScreen) $ do when (screen == systrayScreen) $ do
@ -77,12 +77,14 @@ instance Widget Systray SystrayState (RenderCache Systray SystrayState) where
Just (AddIcon midParent window) -> SystrayState phi screen reset ((SystrayIconState midParent window):icons) Just (AddIcon midParent window) -> SystrayState phi screen reset ((SystrayIconState midParent window):icons)
Just (RemoveIcon window) -> SystrayState phi screen reset $ filter (\(SystrayIconState _ stateWindow) -> stateWindow /= window) icons Just (RemoveIcon window) -> SystrayState phi screen reset $ filter (\(SystrayIconState _ stateWindow) -> stateWindow /= window) icons
_ -> case (fromMessage m) of _ -> case (fromMessage m) of
Just ResetBackground -> SystrayState phi screen (reset+1) icons Just (UpdateScreens screens) -> SystrayState phi (fst . head $ screens) reset icons
_ -> priv _ -> case (fromMessage m) of
Just ResetBackground -> SystrayState phi screen (reset+1) icons
_ -> priv
systrayRunner :: Phi -> Display -> IO () systrayRunner :: Phi -> Display -> Window -> IO ()
systrayRunner phi dispvar = do systrayRunner phi dispvar panelWindow = do
let atoms = getAtoms dispvar let atoms = getAtoms dispvar
initSuccess <- withDisplay dispvar $ flip initSystray atoms initSuccess <- withDisplay dispvar $ flip initSystray atoms
@ -94,7 +96,7 @@ systrayRunner phi dispvar = do
m <- receiveMessage phi m <- receiveMessage phi
case (fromMessage m) of case (fromMessage m) of
Just event -> Just event ->
handleEvent event phi dispvar xembedWindow handleEvent event phi dispvar panelWindow xembedWindow
_ -> _ ->
case (fromMessage m) of case (fromMessage m) of
Just (RenderIcon midParent window x y w h) -> do Just (RenderIcon midParent window x y w h) -> do
@ -188,16 +190,15 @@ sYSTEM_TRAY_CANCEL_MESSAGE = 2
xEMBED_EMBEDDED_NOTIFY :: CInt xEMBED_EMBEDDED_NOTIFY :: CInt
xEMBED_EMBEDDED_NOTIFY = 0 xEMBED_EMBEDDED_NOTIFY = 0
handleEvent :: Event -> Phi -> Display -> Window -> StateT (M.Map Window Window) IO () handleEvent :: Event -> Phi -> Display -> Window -> Window -> StateT (M.Map Window Window) IO ()
handleEvent message@ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar xembedWindow = do handleEvent message@ClientMessageEvent { ev_message_type = message_type, ev_data = messageData, ev_window = window } phi dispvar panelWindow xembedWindow = do
let atoms = getAtoms dispvar let atoms = getAtoms dispvar
screenWindows = getScreenWindows dispvar
when (window == xembedWindow && message_type == atom_NET_SYSTEM_TRAY_OPCODE atoms) $ do when (window == xembedWindow && message_type == atom_NET_SYSTEM_TRAY_OPCODE atoms) $ do
case messageData of case messageData of
_:opcode:iconID:_ -> do _:opcode:iconID:_ -> do
case True of case True of
_ | opcode == sYSTEM_TRAY_REQUEST_DOCK -> do _ | opcode == sYSTEM_TRAY_REQUEST_DOCK -> do
when (iconID /= 0) $ withDisplay dispvar $ \disp -> addIcon phi disp (getAtoms dispvar) (snd . head $ screenWindows) $ fromIntegral iconID when (iconID /= 0) $ withDisplay dispvar $ \disp -> addIcon phi disp (getAtoms dispvar) panelWindow $ fromIntegral iconID
| opcode == sYSTEM_TRAY_BEGIN_MESSAGE || opcode == sYSTEM_TRAY_CANCEL_MESSAGE -> | opcode == sYSTEM_TRAY_BEGIN_MESSAGE || opcode == sYSTEM_TRAY_CANCEL_MESSAGE ->
return () return ()
@ -210,13 +211,13 @@ handleEvent message@ClientMessageEvent { ev_message_type = message_type, ev_data
_ -> _ ->
return () return ()
handleEvent message@UnmapEvent { ev_window = window } phi dispvar xembedWindow = handleEvent message@UnmapEvent { ev_window = window } phi dispvar panelWindow xembedWindow =
withDisplay dispvar $ \disp -> removeIcon phi disp True window withDisplay dispvar $ \disp -> removeIcon phi disp True window
handleEvent message@DestroyWindowEvent { ev_window = window } phi dispvar xembedWindow = handleEvent message@DestroyWindowEvent { ev_window = window } phi dispvar panelWindow xembedWindow =
withDisplay dispvar $ \disp -> removeIcon phi disp False window withDisplay dispvar $ \disp -> removeIcon phi disp False window
handleEvent message@AnyEvent { ev_window = window } phi dispvar xembedWindow | ev_event_type message == reparentNotify = do handleEvent message@AnyEvent { ev_window = window } phi dispvar panelWindow xembedWindow | ev_event_type message == reparentNotify = do
parent <- liftIO $ alloca $ \rootPtr -> alloca $ \parentPtr -> alloca $ \childrenPtrPtr -> alloca $ \nChildrenPtr -> do parent <- liftIO $ alloca $ \rootPtr -> alloca $ \parentPtr -> alloca $ \childrenPtrPtr -> alloca $ \nChildrenPtr -> do
status <- withDisplay dispvar $ \disp -> xQueryTree disp window rootPtr parentPtr childrenPtrPtr nChildrenPtr status <- withDisplay dispvar $ \disp -> xQueryTree disp window rootPtr parentPtr childrenPtrPtr nChildrenPtr
case status of case status of
@ -232,7 +233,7 @@ handleEvent message@AnyEvent { ev_window = window } phi dispvar xembedWindow | e
withDisplay dispvar $ \disp -> removeIcon phi disp False window withDisplay dispvar $ \disp -> removeIcon phi disp False window
return () return ()
handleEvent _ _ _ _ = return () handleEvent _ _ _ _ _ = return ()
addIcon :: Phi -> Xlib.Display -> Atoms -> Window -> Window -> StateT (M.Map Window Window) IO () addIcon :: Phi -> Xlib.Display -> Atoms -> Window -> Window -> StateT (M.Map Window Window) IO ()

69
lib/Phi/Widgets/Taskbar.hs
View file

@ -137,7 +137,8 @@ defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 200
data Taskbar = Taskbar TaskbarConfig data Taskbar = Taskbar TaskbarConfig
data TaskbarState = TaskbarState { taskbarActiveWindow :: !Window data TaskbarState = TaskbarState { taskbarScreens :: ![Xlib.Rectangle]
, taskbarActiveWindow :: !Window
, taskbarDesktopCount :: !Int , taskbarDesktopCount :: !Int
, taskbarCurrentDesktop :: !Int , taskbarCurrentDesktop :: !Int
, taskbarWindows :: ![Window] , taskbarWindows :: ![Window]
@ -154,11 +155,11 @@ createIcon size surface = do
return $ Icon id size surface return $ Icon id size surface
data WindowState = WindowState { windowTitle :: !String data WindowState = WindowState { windowTitle :: !String
, windowDesktop :: !Int , windowDesktop :: !Int
, windowVisible :: !Bool , windowVisible :: !Bool
, windowIcons :: ![Icon] , windowIcons :: ![Icon]
, windowScreen :: !Xlib.Rectangle , windowGeometry :: !Xlib.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))
@ -205,24 +206,26 @@ data TaskbarMessage = WindowListUpdate ![Xlib.Window] !(M.Map Window WindowState
deriving (Typeable, Show) deriving (Typeable, Show)
instance Widget Taskbar TaskbarState (M.Map Window WindowCache) where instance Widget Taskbar TaskbarState (M.Map Window WindowCache) where
initWidget (Taskbar _) phi dispvar = do initWidget (Taskbar _) phi dispvar screens = do
phi' <- dupPhi phi phi' <- dupPhi phi
forkIO $ taskbarRunner phi' dispvar forkIO $ taskbarRunner phi' dispvar
return $ TaskbarState 0 0 (-1) [] M.empty return $ TaskbarState (map fst screens) 0 0 (-1) [] M.empty
initCache _ = M.empty initCache _ = M.empty
minSize _ _ _ _ = 0 minSize _ _ _ _ = 0
weight _ = 1 weight _ = 1
render (Taskbar config) TaskbarState { taskbarActiveWindow = activeWindow render (Taskbar config) TaskbarState { taskbarScreens = screens
, taskbarActiveWindow = activeWindow
, taskbarDesktopCount = desktopCount , taskbarDesktopCount = desktopCount
, taskbarCurrentDesktop = currentDesktop , taskbarCurrentDesktop = currentDesktop
, taskbarWindows = windows , taskbarWindows = windows
, taskbarWindowStates = windowStates , taskbarWindowStates = windowStates
} _ _ w h screen = do } _ _ w h screen = do
let screenWindows = filter ((== Just screen) . fmap windowScreen . flip M.lookup windowStates) windows let windowScreen w = maximumBy (compare `on` unionArea (windowGeometry w)) screens
screenWindows = filter ((== Just screen) . fmap windowScreen . flip M.lookup windowStates) windows
desktopNumbers = take desktopCount [0..] desktopNumbers = take desktopCount [0..]
desktops = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop desktop) . flip M.lookup windowStates) screenWindows)) desktopNumbers desktops = map (\desktop -> (desktop, filter (fromMaybe False . fmap (windowOnDesktop desktop) . flip M.lookup windowStates) screenWindows)) desktopNumbers
@ -301,7 +304,9 @@ instance Widget Taskbar TaskbarState (M.Map Window WindowCache) where
Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count} Just (DesktopCountUpdate count) -> priv {taskbarDesktopCount = count}
Just (CurrentDesktopUpdate current) -> priv {taskbarCurrentDesktop = current} Just (CurrentDesktopUpdate current) -> priv {taskbarCurrentDesktop = current}
Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window} Just (ActiveWindowUpdate window) -> priv {taskbarActiveWindow = window}
_ -> priv _ -> case (fromMessage m) of
Just (UpdateScreens screens) -> priv {taskbarScreens = map fst screens}
_ -> priv
renderText :: String -> Int -> Int -> Int -> Int -> String -> Render () renderText :: String -> Int -> Int -> Int -> Int -> String -> Render ()
@ -390,9 +395,8 @@ windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDeskt
taskbarRunner :: Phi -> Display -> IO () taskbarRunner :: Phi -> Display -> IO ()
taskbarRunner phi dispvar = do taskbarRunner phi dispvar = do
let screens = getScreens dispvar
(windows, states) <- liftIO $ withDisplay dispvar $ \disp -> do (windows, states) <- liftIO $ withDisplay dispvar $ \disp -> do
(windows, states) <- getWindowStates disp screens (getAtoms dispvar) M.empty (windows, states) <- getWindowStates disp (getAtoms dispvar) M.empty
desktopCount <- getDesktopCount disp (getAtoms dispvar) desktopCount <- getDesktopCount disp (getAtoms dispvar)
current <- getCurrentDesktop disp (getAtoms dispvar) current <- getCurrentDesktop disp (getAtoms dispvar)
activeWindow <- getActiveWindow disp (getAtoms dispvar) activeWindow <- getActiveWindow disp (getAtoms dispvar)
@ -414,7 +418,6 @@ taskbarRunner phi dispvar = do
handleEvent :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState) IO () handleEvent :: Phi -> Display -> XExtras.Event -> StateT ([Window], M.Map Window WindowState) IO ()
handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.ev_window = window} = do
let atoms = getAtoms dispvar let atoms = getAtoms dispvar
let screens = getScreens dispvar
when (elem atom $ Xlib.wM_NAME : map ($ atoms) [ atom_NET_ACTIVE_WINDOW when (elem atom $ Xlib.wM_NAME : map ($ atoms) [ atom_NET_ACTIVE_WINDOW
, atom_NET_NUMBER_OF_DESKTOPS , atom_NET_NUMBER_OF_DESKTOPS
@ -442,7 +445,7 @@ handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.e
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 disp screens atoms windowStates (windows', windowStates') <- liftIO $ getWindowStates disp atoms windowStates
when (windows /= windows') $ do when (windows /= windows') $ do
sendMessage phi $ WindowListUpdate windows' windowStates' sendMessage phi $ WindowListUpdate windows' windowStates'
@ -476,14 +479,12 @@ handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.e
return () return ()
handleEvent phi dispvar XExtras.ConfigureEvent {XExtras.ev_window = window} = do handleEvent phi dispvar XExtras.ConfigureEvent {XExtras.ev_window = window} = do
let screens = getScreens dispvar
(windows, windowStates) <- get (windows, windowStates) <- get
when (elem window windows) $ withDisplay dispvar $ \disp -> do when (elem window windows) $ withDisplay dispvar $ \disp -> do
let screen = fmap windowScreen . M.lookup window $ windowStates let geom = fmap windowGeometry . M.lookup window $ windowStates
screen' <- liftIO $ getWindowScreen disp screens window geom' <- liftIO $ getWindowGeometry disp window
when (screen /= (Just screen')) $ do when (geom /= (Just geom')) $ do
let windowStates' = M.update (\state -> Just state {windowScreen = screen'}) window windowStates let windowStates' = M.update (\state -> Just state {windowGeometry = geom'}) window windowStates
sendMessage phi $ WindowListUpdate windows windowStates' sendMessage phi $ WindowListUpdate windows windowStates'
sendMessage phi Repaint sendMessage phi Repaint
put (windows, windowStates') put (windows, windowStates')
@ -504,8 +505,8 @@ getActiveWindow :: Xlib.Display -> Atoms -> IO Window
getActiveWindow disp atoms = getActiveWindow disp atoms =
liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_ACTIVE_WINDOW atoms) $ Xlib.defaultRootWindow disp liftM (fromIntegral . fromMaybe 0 . join . fmap listToMaybe) $ XExtras.getWindowProperty32 disp (atom_NET_ACTIVE_WINDOW atoms) $ Xlib.defaultRootWindow disp
getWindowStates :: Xlib.Display -> [Xlib.Rectangle] -> Atoms -> M.Map Window WindowState -> IO ([Window], M.Map Window WindowState) getWindowStates :: Xlib.Display -> Atoms -> M.Map Window WindowState -> IO ([Window], M.Map Window WindowState)
getWindowStates disp screens atoms windowStates = do getWindowStates disp atoms windowStates = do
windows <- getWindowList disp atoms windows <- getWindowList disp atoms
let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows let windowStates' = map (\w -> (w, M.lookup w windowStates)) windows
@ -517,20 +518,20 @@ getWindowStates disp screens atoms windowStates = do
getWindowState' (window, Just windowState) = return (window, windowState) getWindowState' (window, Just windowState) = return (window, windowState)
getWindowState' (window, Nothing) = do getWindowState' (window, Nothing) = do
Xlib.selectInput disp window $ Xlib.propertyChangeMask .|. Xlib.structureNotifyMask Xlib.selectInput disp window $ Xlib.propertyChangeMask .|. Xlib.structureNotifyMask
windowState <- getWindowState disp screens atoms window windowState <- getWindowState disp atoms window
return (window, windowState) return (window, windowState)
getWindowState :: Xlib.Display -> [Xlib.Rectangle] -> Atoms -> Window -> IO WindowState getWindowState :: Xlib.Display -> Atoms -> Window -> IO WindowState
getWindowState disp screens atoms window = do getWindowState disp atoms window = do
(name, workspace, visible) <- getWindowInfo disp atoms window (name, workspace, visible) <- getWindowInfo disp atoms window
icons <- getWindowIcons disp atoms window icons <- getWindowIcons disp atoms window
screen <- getWindowScreen disp screens window geom <- getWindowGeometry disp window
return $ WindowState { windowTitle = name return $ WindowState { windowTitle = name
, windowDesktop = workspace , windowDesktop = workspace
, windowVisible = visible , windowVisible = visible
, windowIcons = icons , windowIcons = icons
, windowScreen = screen , windowGeometry = geom
} }
getWindowInfo :: Xlib.Display -> Atoms -> Window -> IO (String, Int, Bool) getWindowInfo :: Xlib.Display -> Atoms -> Window -> IO (String, Int, Bool)
@ -581,18 +582,12 @@ premultiply c = a .|. r .|. g .|. b
b = pm bmask b = pm bmask
getWindowScreen :: Xlib.Display -> [Xlib.Rectangle] -> Window -> IO Xlib.Rectangle getWindowGeometry :: Xlib.Display -> Window -> IO Xlib.Rectangle
getWindowScreen disp screens window = flip catch (\_ -> return $ head screens) $ do getWindowGeometry disp window = flip catch (\_ -> return $ Xlib.Rectangle 0 0 0 0) $ do
(_, _, _, width, height, _, _) <- Xlib.getGeometry disp window (_, _, _, width, height, _, _) <- Xlib.getGeometry disp window
(ret, x, y, _) <- Xlib.translateCoordinates disp window (Xlib.defaultRootWindow disp) 0 0 (ret, x, y, _) <- Xlib.translateCoordinates disp window (Xlib.defaultRootWindow disp) 0 0
case ret of return $ if ret then Xlib.Rectangle x y width height else Xlib.Rectangle 0 0 0 0
True -> do
let windowRect = Xlib.Rectangle x y width height
screen = maximumBy (compare `on` unionArea windowRect) screens
return screen
False ->
return $ head screens
showWindow :: Xlib.Display -> Atoms -> Window -> IO Bool showWindow :: Xlib.Display -> Atoms -> Window -> IO Bool

115
lib/Phi/X11.hs
View file

@ -43,33 +43,33 @@ data PhiState w s c = (Widget.Widget w s c) => PhiState { phiRootImage :: !Su
, phiRepaint :: !Bool , phiRepaint :: !Bool
, phiShutdown :: !Bool , phiShutdown :: !Bool
, phiShutdownHold :: !Int , phiShutdownHold :: !Int
, phiWidgetState :: !s
} }
data PanelState w s c = (Widget.Widget w s c) => PanelState { panelWindow :: !Window data PanelState w s c = (Widget.Widget w s c) => PanelState { panelWindow :: !Window
, panelPixmap :: !Pixmap , panelPixmap :: !Pixmap
, panelArea :: !Rectangle , panelArea :: !Rectangle
, panelScreenArea :: !Rectangle , panelScreenArea :: !Rectangle
, panelWidget :: !w
, panelWidgetState :: !s
, panelWidgetCache :: !c , panelWidgetCache :: !c
} }
data PhiConfig = PhiConfig { phiPhi :: !Phi data PhiConfig w s c = PhiConfig { phiPhi :: !Phi
, phiPanelConfig :: !Panel.PanelConfig , phiPanelConfig :: !Panel.PanelConfig
, phiXConfig :: !XConfig , phiXConfig :: !XConfig
, phiAtoms :: !Atoms , phiAtoms :: !Atoms
} , phiWidget :: !w
}
newtype PhiReader a = PhiReader (ReaderT PhiConfig IO a) newtype PhiReader w s c a = PhiReader (ReaderT (PhiConfig w s c) IO a)
deriving (Monad, MonadReader PhiConfig, MonadIO) deriving (Monad, MonadReader (PhiConfig w s c), MonadIO)
runPhiReader :: PhiConfig -> PhiReader a -> IO a runPhiReader :: PhiConfig w s c -> PhiReader w s c a -> IO a
runPhiReader config (PhiReader a) = runReaderT a config runPhiReader config (PhiReader a) = runReaderT a config
newtype PhiX w s c a = PhiX (StateT (PhiState w s c) PhiReader a) newtype PhiX w s c a = PhiX (StateT (PhiState w s c) (PhiReader w s c) a)
deriving (Monad, MonadState (PhiState w s c), MonadReader PhiConfig, MonadIO) deriving (Monad, MonadState (PhiState w s c), MonadReader (PhiConfig w s c), MonadIO)
runPhiX :: PhiConfig -> PhiState w s c -> PhiX w s c a -> IO (a, PhiState w s c) runPhiX :: PhiConfig w s c -> PhiState w s c -> PhiX w s c a -> IO (a, PhiState w s c)
runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st
defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
@ -91,30 +91,34 @@ runPhi xconfig config widget = do
selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask
bg <- createImageSurface FormatRGB24 1 1 bg <- createImageSurface FormatRGB24 1 1
runPhiX PhiConfig { phiPhi = phi
, phiXConfig = xconfig dispmvar <- newMVar disp
, phiPanelConfig = config screens <- liftIO $ phiXScreenInfo xconfig disp
, phiAtoms = atoms panelWindows <- mapM (createPanelWindow disp config) screens
} PhiState { phiRootImage = bg let dispvar = Widget.Display dispmvar atoms
, phiPanels = [] widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1)
, phiRepaint = True screenPanels = zip screens panelWindows
, phiShutdown = False
, phiShutdownHold = 0 initialState <- Widget.initWidget widget' phi dispvar screenPanels
} $ do
runPhiX
PhiConfig { phiPhi = phi
, phiXConfig = xconfig
, phiPanelConfig = config
, phiAtoms = atoms
, phiWidget = widget'
}
PhiState { phiRootImage = bg
, phiPanels = []
, phiRepaint = True
, phiShutdown = False
, phiShutdownHold = 0
, phiWidgetState = initialState
} $ do
updateRootImage disp updateRootImage disp
screens <- liftIO $ phiXScreenInfo xconfig disp
panelWindows <- mapM (createPanelWindow disp) screens
dispmvar <- liftIO $ newMVar disp
let screenPanels = zip screens panelWindows
dispvar = Widget.Display dispmvar atoms screenPanels
widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1)
widgetState <- liftIO $ Widget.initWidget widget' phi dispvar
Widget.withDisplay dispvar $ \disp -> do Widget.withDisplay dispvar $ \disp -> do
panels <- mapM (\(screen, window) -> createPanel disp window widget' widgetState screen) screenPanels panels <- mapM (\(screen, window) -> createPanel disp window screen) screenPanels
forM_ panels $ \panel -> do forM_ panels $ \panel -> do
setPanelProperties disp panel setPanelProperties disp panel
@ -158,14 +162,10 @@ termHandler :: Phi -> Handler
termHandler phi = Catch $ sendMessage phi Shutdown termHandler phi = Catch $ sendMessage phi Shutdown
handlePanel :: Message -> PanelState w s c -> PanelState w s c handleMessage :: (Widget w s c) => Widget.Display -> Message -> PhiX w s c ()
handlePanel message panel@PanelState {panelWidget = widget, panelWidgetState = state} = panel {panelWidgetState = state'}
where
state' = Widget.handleMessage widget state message
handleMessage :: Widget.Display -> Message -> PhiX w s c ()
handleMessage dispvar m = do handleMessage dispvar m = do
modify $ \state@PhiState {phiPanels = panels} -> state {phiPanels = map (handlePanel m) panels} w <- asks phiWidget
modify $ \state -> state {phiWidgetState = Widget.handleMessage w (phiWidgetState state) m}
case (fromMessage m) of case (fromMessage m) of
Just Repaint -> Just Repaint ->
@ -193,10 +193,13 @@ receiveEvents phi dispvar = do
return True return True
else return False else return False
when (not handled) $ threadWaitRead connection --when (not handled) $ threadWaitRead connection
when (not handled) $ threadDelay 40000
updatePanels :: (Widget w s c) => Widget.Display -> PhiX w s c () updatePanels :: (Widget w s c) => Widget.Display -> PhiX w s c ()
updatePanels dispvar = do updatePanels dispvar = do
w <- asks phiWidget
s <- gets phiWidgetState
rootImage <- gets phiRootImage rootImage <- gets phiRootImage
panels <- gets phiPanels panels <- gets phiPanels
@ -204,9 +207,8 @@ updatePanels dispvar = do
let pixmap = panelPixmap panel let pixmap = panelPixmap panel
area = panelArea panel area = panelArea panel
let layoutedWidget = (withDimension area $ Widget.layout (panelWidget panel) (panelWidgetState panel)) $ panelScreenArea panel
(panelSurfaces, cache') <- liftIO $ flip runStateT (panelWidgetCache panel) $ (panelSurfaces, cache') <- liftIO $ flip runStateT (panelWidgetCache panel) $
(withDimension area $ Widget.render (panelWidget panel) layoutedWidget 0 0) (panelScreenArea panel) (withDimension area $ Widget.render w s 0 0) (panelScreenArea panel)
Widget.withDisplay dispvar $ \disp -> do Widget.withDisplay dispvar $ \disp -> do
let screen = defaultScreen disp let screen = defaultScreen disp
@ -237,14 +239,13 @@ updatePanels dispvar = do
surfaceFinish xbuffer surfaceFinish xbuffer
-- copy buffer to window -- update window
liftIO $ do liftIO $ do
(withDimension area $ clearArea disp (panelWindow panel) 0 0) True (withDimension area $ clearArea disp (panelWindow panel) 0 0) True
--(withDimension area $ copyArea disp (panelPixmap panel) (panelWindow panel) (defaultGC disp $ defaultScreen disp) 0 0) 0 0 --(withDimension area $ copyArea disp (panelPixmap panel) (panelWindow panel) (defaultGC disp $ defaultScreen disp) 0 0) 0 0
sync disp False sync disp False
return $ panel { panelWidgetState = layoutedWidget, panelWidgetCache = cache' } return $ panel { panelWidgetCache = cache' }
modify $ \state -> state { phiPanels = panels' } modify $ \state -> state { phiPanels = panels' }
@ -271,7 +272,11 @@ updateRootImage disp = do
pixmap <- liftM (fromIntegral . fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $ pixmap <- liftM (fromIntegral . fromMaybe 0 . listToMaybe . join . catMaybes) $ forM [atom_XROOTPMAP_ID atoms, atom_XROOTMAP_ID atoms] $
\atom -> liftIO $ getWindowProperty32 disp atom rootwin \atom -> liftIO $ getWindowProperty32 disp atom rootwin
(_, _, _, pixmapWidth, pixmapHeight, _, _) <- liftIO $ getGeometry disp pixmap (pixmapWidth, pixmapHeight) <- case pixmap of
0 -> return (1, 1)
_ -> do
(_, _, _, pixmapWidth, pixmapHeight, _, _) <- liftIO $ getGeometry disp pixmap
return (pixmapWidth, pixmapHeight)
-- update surface size -- update surface size
oldBg <- gets phiRootImage oldBg <- gets phiRootImage
@ -299,11 +304,12 @@ updateRootImage disp = do
surfaceFinish rootSurface surfaceFinish rootSurface
createPanel :: (Widget w s c) => Display -> Window -> w -> s -> Rectangle -> PhiX w s c (PanelState w s c) createPanel :: (Widget w s c) => Display -> Window -> Rectangle -> PhiX w s c (PanelState w s c)
createPanel disp win w s screenRect = do createPanel disp win screenRect = do
config <- asks phiPanelConfig config <- asks phiPanelConfig
w <- asks phiWidget
let rect = panelBounds config screenRect let rect = panelBounds config screenRect
let screen = defaultScreen disp screen = defaultScreen disp
depth = defaultDepth disp screen depth = defaultDepth disp screen
pixmap <- liftIO $ (withDimension rect $ createPixmap disp win) depth pixmap <- liftIO $ (withDimension rect $ createPixmap disp win) depth
@ -313,14 +319,11 @@ createPanel disp win w s screenRect = do
, panelPixmap = pixmap , panelPixmap = pixmap
, panelArea = rect , panelArea = rect
, panelScreenArea = screenRect , panelScreenArea = screenRect
, panelWidget = w
, panelWidgetState = s
, panelWidgetCache = initCache w , panelWidgetCache = initCache w
} }
createPanelWindow :: Display -> Rectangle -> PhiX w s c Window createPanelWindow :: Display -> Panel.PanelConfig -> Rectangle -> IO Window
createPanelWindow disp screenRect = do createPanelWindow disp config screenRect = do
config <- asks phiPanelConfig
let rect = panelBounds config screenRect let rect = panelBounds config screenRect
screen = defaultScreen disp screen = defaultScreen disp
depth = defaultDepth disp screen depth = defaultDepth disp screen