diff options
Diffstat (limited to 'lib')
| -rw-r--r-- | lib/Phi/Border.hs | 13 | ||||
| -rw-r--r-- | lib/Phi/Widget.hs | 54 | ||||
| -rw-r--r-- | lib/Phi/Widgets/AlphaBox.hs | 2 | ||||
| -rw-r--r-- | lib/Phi/Widgets/Clock.hs | 2 | ||||
| -rw-r--r-- | lib/Phi/Widgets/Systray.hs | 33 | ||||
| -rw-r--r-- | lib/Phi/Widgets/Taskbar.hs | 71 | ||||
| -rw-r--r-- | lib/Phi/X11.hs | 115 |
7 files changed, 131 insertions, 159 deletions
diff --git a/lib/Phi/Border.hs b/lib/Phi/Border.hs index 4b32dd3..ca5e515 100644 --- a/lib/Phi/Border.hs +++ b/lib/Phi/Border.hs @@ -79,17 +79,6 @@ instance Eq s => Widget (Border w s c) s (BorderCache w s c) where 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 _ | (width > borderH m - 2*bw - borderH p) -> do 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)] surfacesWidths = zipWith (\(updated, x, surf) (_, x', _) -> (updated, x, x'-x, surf)) surfaces' (tail surfaces' ++ [(False, width, Nothing)]) forM surfacesWidths $ \(updated, x, surfWidth, surf) -> do - surf' <- liftIO $ createImageSurface FormatARGB32 surfWidth height + surf' <- liftIO $ createImageSurface FormatARGB32 surfWidth height renderWith surf' $ do setOperator OperatorClear paint diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs index 68bed1b..791eff1 100644 --- a/lib/Phi/Widget.hs +++ b/lib/Phi/Widget.hs @@ -1,10 +1,9 @@ -{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-} +{-# LANGUAGE ExistentialQuantification, StandaloneDeriving, DeriveDataTypeable, MultiParamTypeClasses, FunctionalDependencies, TypeSynonymInstances, FlexibleInstances #-} module Phi.Widget ( Display(..) , withDisplay , getAtoms - , getScreenWindows - , getScreens + , XMessage(..) , unionArea , SurfaceSlice(..) , Widget(..) @@ -29,6 +28,7 @@ import Control.Monad.State.Strict hiding (lift) import Control.Monad.IO.Class import Data.Maybe +import Data.Typeable import qualified Graphics.X11.Xlib as Xlib import Graphics.Rendering.Cairo @@ -37,23 +37,19 @@ import Phi.Phi 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 (Display dispvar _ _) f = do +withDisplay (Display dispvar _) f = do disp <- liftIO $ takeMVar dispvar a <- f disp liftIO $ putMVar dispvar disp return a getAtoms :: Display -> Atoms -getAtoms (Display _ atoms _) = atoms +getAtoms (Display _ atoms) = atoms -getScreenWindows :: Display -> [(Xlib.Rectangle, Xlib.Window)] -getScreenWindows (Display _ _ screenWindows) = screenWindows - -getScreens :: Display -> [Xlib.Rectangle] -getScreens = map fst . getScreenWindows +data XMessage = UpdateScreens [(Xlib.Rectangle, Xlib.Window)] deriving (Show, Typeable) unionArea :: Xlib.Rectangle -> Xlib.Rectangle -> Int @@ -75,7 +71,7 @@ unionArea a b = fromIntegral $ uw*uh data SurfaceSlice = SurfaceSlice !Int !Surface 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 @@ -84,9 +80,6 @@ class Eq s => Widget w s c | w -> s, w -> c where weight :: w -> Float 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)] 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 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) 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 - 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) - 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 - layout c@(CompoundWidget a b) s@(CompoundState sa sb _) width height screen = CompoundState sa' sb' xb - where - sizesum = minSize c s height screen - wsum = let wsum = weight c - in if wsum > 0 then wsum else 1 + render c@(CompoundWidget a b) s@(CompoundState sa sb) x y w h screen = do + let sizesum = minSize c s h screen + wsum = let wsum = weight c + 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 + (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 put $ CompoundCache ca' cb' 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' = max 0 . weight @@ -172,7 +158,7 @@ a <~> b = CompoundWidget a b data Separator = Separator !Int !Float deriving (Show, Eq) instance Widget Separator () (RenderCache Separator ()) where - initWidget _ _ _ = return () + initWidget _ _ _ _ = return () initCache _ = createRenderCache $ \_ _ _ _ _ _ _ -> do setOperator OperatorClear paint diff --git a/lib/Phi/Widgets/AlphaBox.hs b/lib/Phi/Widgets/AlphaBox.hs index f6b0e74..6f989ea 100644 --- a/lib/Phi/Widgets/AlphaBox.hs +++ b/lib/Phi/Widgets/AlphaBox.hs @@ -25,8 +25,6 @@ instance Eq s => Widget (AlphaBox w s c) s (AlphaBoxCache w s c) where weight (AlphaBox _ w) = weight w - layout (AlphaBox _ w) = layout w - render (AlphaBox alpha w) s x y width height screen = do AlphaBoxCache c <- get (surfaces, c') <- liftIO $ flip runStateT c $ render w s x y width height screen diff --git a/lib/Phi/Widgets/Clock.hs b/lib/Phi/Widgets/Clock.hs index a11ef9e..e232ef5 100644 --- a/lib/Phi/Widgets/Clock.hs +++ b/lib/Phi/Widgets/Clock.hs @@ -43,7 +43,7 @@ data ClockState = ClockState !ZonedTime deriving (Show, Eq) data ClockMessage = UpdateTime !ZonedTime deriving (Show, Typeable) instance Widget Clock ClockState (RenderCache Clock ClockState) where - initWidget (Clock _) phi _ = do + initWidget (Clock _) phi _ _ = do forkIO $ forever $ do time <- getZonedTime sendMessage phi $ UpdateTime time diff --git a/lib/Phi/Widgets/Systray.hs b/lib/Phi/Widgets/Systray.hs index 2aef713..c419426 100644 --- a/lib/Phi/Widgets/Systray.hs +++ b/lib/Phi/Widgets/Systray.hs @@ -49,11 +49,11 @@ data SystrayMessage = AddIcon !Window !Window | RemoveIcon !Window | RenderIcon instance Widget Systray SystrayState (RenderCache Systray SystrayState) where - initWidget (Systray) phi dispvar = do + initWidget (Systray) phi dispvar screens = do 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 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 (RemoveIcon window) -> SystrayState phi screen reset $ filter (\(SystrayIconState _ stateWindow) -> stateWindow /= window) icons _ -> case (fromMessage m) of - Just ResetBackground -> SystrayState phi screen (reset+1) icons - _ -> priv + Just (UpdateScreens screens) -> SystrayState phi (fst . head $ screens) reset icons + _ -> case (fromMessage m) of + Just ResetBackground -> SystrayState phi screen (reset+1) icons + _ -> priv -systrayRunner :: Phi -> Display -> IO () -systrayRunner phi dispvar = do +systrayRunner :: Phi -> Display -> Window -> IO () +systrayRunner phi dispvar panelWindow = do let atoms = getAtoms dispvar initSuccess <- withDisplay dispvar $ flip initSystray atoms @@ -94,7 +96,7 @@ systrayRunner phi dispvar = do m <- receiveMessage phi case (fromMessage m) of Just event -> - handleEvent event phi dispvar xembedWindow + handleEvent event phi dispvar panelWindow xembedWindow _ -> case (fromMessage m) of 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 = 0 -handleEvent :: Event -> Phi -> Display -> 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 :: 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 panelWindow xembedWindow = do let atoms = getAtoms dispvar - screenWindows = getScreenWindows dispvar when (window == xembedWindow && message_type == atom_NET_SYSTEM_TRAY_OPCODE atoms) $ do case messageData of _:opcode:iconID:_ -> do case True of _ | 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 -> return () @@ -210,13 +211,13 @@ handleEvent message@ClientMessageEvent { ev_message_type = message_type, ev_data _ -> 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 -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 -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 status <- withDisplay dispvar $ \disp -> xQueryTree disp window rootPtr parentPtr childrenPtrPtr nChildrenPtr 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 return () -handleEvent _ _ _ _ = return () +handleEvent _ _ _ _ _ = return () addIcon :: Phi -> Xlib.Display -> Atoms -> Window -> Window -> StateT (M.Map Window Window) IO () diff --git a/lib/Phi/Widgets/Taskbar.hs b/lib/Phi/Widgets/Taskbar.hs index da68c27..31d85ff 100644 --- a/lib/Phi/Widgets/Taskbar.hs +++ b/lib/Phi/Widgets/Taskbar.hs @@ -137,7 +137,8 @@ defaultTaskbarConfig = TaskbarConfig { taskMaxSize = 200 data Taskbar = Taskbar TaskbarConfig -data TaskbarState = TaskbarState { taskbarActiveWindow :: !Window +data TaskbarState = TaskbarState { taskbarScreens :: ![Xlib.Rectangle] + , taskbarActiveWindow :: !Window , taskbarDesktopCount :: !Int , taskbarCurrentDesktop :: !Int , taskbarWindows :: ![Window] @@ -154,11 +155,11 @@ createIcon size surface = do return $ Icon id size surface -data WindowState = WindowState { windowTitle :: !String - , windowDesktop :: !Int - , windowVisible :: !Bool - , windowIcons :: ![Icon] - , windowScreen :: !Xlib.Rectangle +data WindowState = WindowState { windowTitle :: !String + , windowDesktop :: !Int + , windowVisible :: !Bool + , windowIcons :: ![Icon] + , windowGeometry :: !Xlib.Rectangle } deriving (Eq, Show) 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) instance Widget Taskbar TaskbarState (M.Map Window WindowCache) where - initWidget (Taskbar _) phi dispvar = do + initWidget (Taskbar _) phi dispvar screens = do phi' <- dupPhi phi forkIO $ taskbarRunner phi' dispvar - return $ TaskbarState 0 0 (-1) [] M.empty + return $ TaskbarState (map fst screens) 0 0 (-1) [] M.empty initCache _ = M.empty minSize _ _ _ _ = 0 weight _ = 1 - render (Taskbar config) TaskbarState { taskbarActiveWindow = activeWindow + render (Taskbar config) TaskbarState { taskbarScreens = screens + , taskbarActiveWindow = activeWindow , taskbarDesktopCount = desktopCount , taskbarCurrentDesktop = currentDesktop , taskbarWindows = windows , taskbarWindowStates = windowStates } _ _ 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..] 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 (CurrentDesktopUpdate current) -> priv {taskbarCurrentDesktop = current} 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 () @@ -390,9 +395,8 @@ windowOnDesktop desktop state = (windowVisible state) && (desktop == windowDeskt taskbarRunner :: Phi -> Display -> IO () taskbarRunner phi dispvar = do - let screens = getScreens dispvar (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) current <- getCurrentDesktop disp (getAtoms dispvar) activeWindow <- getActiveWindow disp (getAtoms dispvar) @@ -406,7 +410,7 @@ taskbarRunner phi dispvar = do flip evalStateT (windows, states) $ forever $ do m <- receiveMessage phi case (fromMessage m) of - Just event -> + Just event -> handleEvent phi dispvar event _ -> return () @@ -414,7 +418,6 @@ taskbarRunner phi dispvar = do 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 let atoms = getAtoms dispvar - let screens = getScreens dispvar when (elem atom $ Xlib.wM_NAME : map ($ atoms) [ atom_NET_ACTIVE_WINDOW , atom_NET_NUMBER_OF_DESKTOPS @@ -442,7 +445,7 @@ handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.e sendMessage phi Repaint when (atom == atom_NET_CLIENT_LIST atoms) $ do (windows, windowStates) <- get - (windows', windowStates') <- liftIO $ getWindowStates disp screens atoms windowStates + (windows', windowStates') <- liftIO $ getWindowStates disp atoms windowStates when (windows /= windows') $ do sendMessage phi $ WindowListUpdate windows' windowStates' @@ -476,14 +479,12 @@ handleEvent phi dispvar XExtras.PropertyEvent {XExtras.ev_atom = atom, XExtras.e return () handleEvent phi dispvar XExtras.ConfigureEvent {XExtras.ev_window = window} = do - let screens = getScreens dispvar - (windows, windowStates) <- get when (elem window windows) $ withDisplay dispvar $ \disp -> do - let screen = fmap windowScreen . M.lookup window $ windowStates - screen' <- liftIO $ getWindowScreen disp screens window - when (screen /= (Just screen')) $ do - let windowStates' = M.update (\state -> Just state {windowScreen = screen'}) window windowStates + let geom = fmap windowGeometry . M.lookup window $ windowStates + geom' <- liftIO $ getWindowGeometry disp window + when (geom /= (Just geom')) $ do + let windowStates' = M.update (\state -> Just state {windowGeometry = geom'}) window windowStates sendMessage phi $ WindowListUpdate windows windowStates' sendMessage phi Repaint put (windows, windowStates') @@ -504,8 +505,8 @@ getActiveWindow :: Xlib.Display -> Atoms -> IO Window getActiveWindow disp atoms = 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 disp screens atoms windowStates = do +getWindowStates :: Xlib.Display -> Atoms -> M.Map Window WindowState -> IO ([Window], M.Map Window WindowState) +getWindowStates disp atoms windowStates = do windows <- getWindowList disp atoms 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, Nothing) = do Xlib.selectInput disp window $ Xlib.propertyChangeMask .|. Xlib.structureNotifyMask - windowState <- getWindowState disp screens atoms window + windowState <- getWindowState disp atoms window return (window, windowState) -getWindowState :: Xlib.Display -> [Xlib.Rectangle] -> Atoms -> Window -> IO WindowState -getWindowState disp screens atoms window = do +getWindowState :: Xlib.Display -> Atoms -> Window -> IO WindowState +getWindowState disp atoms window = do (name, workspace, visible) <- getWindowInfo disp atoms window icons <- getWindowIcons disp atoms window - screen <- getWindowScreen disp screens window + geom <- getWindowGeometry disp window return $ WindowState { windowTitle = name , windowDesktop = workspace , windowVisible = visible , windowIcons = icons - , windowScreen = screen + , windowGeometry = geom } getWindowInfo :: Xlib.Display -> Atoms -> Window -> IO (String, Int, Bool) @@ -581,18 +582,12 @@ premultiply c = a .|. r .|. g .|. b b = pm bmask -getWindowScreen :: Xlib.Display -> [Xlib.Rectangle] -> Window -> IO Xlib.Rectangle -getWindowScreen disp screens window = flip catch (\_ -> return $ head screens) $ do +getWindowGeometry :: Xlib.Display -> Window -> IO Xlib.Rectangle +getWindowGeometry disp window = flip catch (\_ -> return $ Xlib.Rectangle 0 0 0 0) $ do (_, _, _, width, height, _, _) <- Xlib.getGeometry disp window (ret, x, y, _) <- Xlib.translateCoordinates disp window (Xlib.defaultRootWindow disp) 0 0 - case ret of - True -> do - let windowRect = Xlib.Rectangle x y width height - screen = maximumBy (compare `on` unionArea windowRect) screens - return screen - False -> - return $ head screens + return $ if ret then Xlib.Rectangle x y width height else Xlib.Rectangle 0 0 0 0 showWindow :: Xlib.Display -> Atoms -> Window -> IO Bool diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index 971be37..dbaaf28 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -43,33 +43,33 @@ data PhiState w s c = (Widget.Widget w s c) => PhiState { phiRootImage :: !Su , 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 - , panelWidget :: !w - , panelWidgetState :: !s , panelWidgetCache :: !c } -data PhiConfig = PhiConfig { phiPhi :: !Phi - , phiPanelConfig :: !Panel.PanelConfig - , phiXConfig :: !XConfig - , phiAtoms :: !Atoms - } +data PhiConfig w s c = PhiConfig { phiPhi :: !Phi + , phiPanelConfig :: !Panel.PanelConfig + , phiXConfig :: !XConfig + , phiAtoms :: !Atoms + , phiWidget :: !w + } -newtype PhiReader a = PhiReader (ReaderT PhiConfig IO a) - deriving (Monad, MonadReader PhiConfig, MonadIO) +newtype PhiReader w s c a = PhiReader (ReaderT (PhiConfig w s c) IO a) + 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 -newtype PhiX w s c a = PhiX (StateT (PhiState w s c) PhiReader a) - deriving (Monad, MonadState (PhiState w s c), MonadReader PhiConfig, MonadIO) +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 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 defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo @@ -91,30 +91,34 @@ runPhi xconfig config widget = do selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask bg <- createImageSurface FormatRGB24 1 1 - runPhiX PhiConfig { phiPhi = phi - , phiXConfig = xconfig - , phiPanelConfig = config - , phiAtoms = atoms - } PhiState { phiRootImage = bg - , phiPanels = [] - , phiRepaint = True - , phiShutdown = False - , phiShutdownHold = 0 - } $ do + + dispmvar <- newMVar disp + screens <- liftIO $ phiXScreenInfo xconfig disp + panelWindows <- mapM (createPanelWindow disp config) screens + let dispvar = Widget.Display dispmvar atoms + widget' = widget <~> separator 0 (if weight widget > 0 then 0 else 1) + screenPanels = zip screens panelWindows + + initialState <- Widget.initWidget widget' phi dispvar screenPanels + + 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 - 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 - panels <- mapM (\(screen, window) -> createPanel disp window widget' widgetState screen) screenPanels + panels <- mapM (\(screen, window) -> createPanel disp window screen) screenPanels forM_ panels $ \panel -> do setPanelProperties disp panel @@ -158,14 +162,10 @@ termHandler :: Phi -> Handler termHandler phi = Catch $ sendMessage phi Shutdown -handlePanel :: Message -> PanelState w s c -> PanelState 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 :: (Widget w s c) => Widget.Display -> Message -> PhiX w s c () 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 Just Repaint -> @@ -193,10 +193,13 @@ receiveEvents phi dispvar = do return True 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 dispvar = do + w <- asks phiWidget + s <- gets phiWidgetState rootImage <- gets phiRootImage panels <- gets phiPanels @@ -204,9 +207,8 @@ updatePanels dispvar = do let pixmap = panelPixmap panel area = panelArea panel - let layoutedWidget = (withDimension area $ Widget.layout (panelWidget panel) (panelWidgetState panel)) $ panelScreenArea 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 let screen = defaultScreen disp @@ -237,14 +239,13 @@ updatePanels dispvar = do surfaceFinish xbuffer - -- copy buffer to window + -- update window liftIO $ do (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 sync disp False - return $ panel { panelWidgetState = layoutedWidget, panelWidgetCache = cache' } - + return $ panel { panelWidgetCache = cache' } 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] $ \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 oldBg <- gets phiRootImage @@ -299,11 +304,12 @@ updateRootImage disp = do surfaceFinish rootSurface -createPanel :: (Widget w s c) => Display -> Window -> w -> s -> Rectangle -> PhiX w s c (PanelState w s c) -createPanel disp win w s screenRect = do +createPanel :: (Widget w s c) => Display -> Window -> Rectangle -> PhiX w s c (PanelState w s c) +createPanel disp win screenRect = do config <- asks phiPanelConfig + w <- asks phiWidget let rect = panelBounds config screenRect - let screen = defaultScreen disp + screen = defaultScreen disp depth = defaultDepth disp screen pixmap <- liftIO $ (withDimension rect $ createPixmap disp win) depth @@ -313,14 +319,11 @@ createPanel disp win w s screenRect = do , panelPixmap = pixmap , panelArea = rect , panelScreenArea = screenRect - , panelWidget = w - , panelWidgetState = s , panelWidgetCache = initCache w } -createPanelWindow :: Display -> Rectangle -> PhiX w s c Window -createPanelWindow disp screenRect = do - config <- asks phiPanelConfig +createPanelWindow :: Display -> Panel.PanelConfig -> Rectangle -> IO Window +createPanelWindow disp config screenRect = do let rect = panelBounds config screenRect screen = defaultScreen disp depth = defaultDepth disp screen |