diff options
Diffstat (limited to 'lib/Phi/X11.hs')
| -rw-r--r-- | lib/Phi/X11.hs | 76 |
1 files changed, 40 insertions, 36 deletions
diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs index 3930826..0da8594 100644 --- a/lib/Phi/X11.hs +++ b/lib/Phi/X11.hs @@ -41,7 +41,7 @@ data PhiState = PhiState { phiRootImage :: !Surface } data PanelState = PanelState { panelWindow :: !Window - , panelBuffer :: !Surface + , panelPixmap :: !Pixmap , panelArea :: !Rectangle , panelScreenArea :: !Rectangle , panelWidgetStates :: ![Widget.WidgetState] @@ -85,12 +85,15 @@ runPhi xconfig config widgets = do screens <- liftIO $ phiXScreenInfo xconfig disp + panelWindows <- mapM (createPanelWindow disp) screens + dispmvar <- liftIO $ newMVar disp - let dispvar = Widget.Display dispmvar atoms screens + let screenPanels = zip screens panelWindows + dispvar = Widget.Display dispmvar atoms screenPanels widgetStates <- liftIO $ mapM (Widget.createWidgetState phi dispvar) widgets Widget.withDisplay dispvar $ \disp -> do - panels <- mapM (createPanel disp widgetStates) screens + panels <- mapM (\(screen, window) -> createPanel disp window widgetStates screen) screenPanels forM_ panels $ \panel -> do setPanelProperties disp panel @@ -105,7 +108,7 @@ runPhi xconfig config widgets = do unless available $ do repaint <- gets phiRepaint when repaint $ do - Widget.withDisplay dispvar $ flip updatePanels True + updatePanels dispvar modify $ \state -> state {phiRepaint = False} message <- receiveMessage phi @@ -127,8 +130,6 @@ handleMessage dispvar m = do modify $ \state -> state {phiRepaint = True} _ -> case (fromMessage m) of - Just ExposeEvent {} -> - Widget.withDisplay dispvar $ flip updatePanels False Just event@PropertyEvent {} -> Widget.withDisplay dispvar $ flip handlePropertyUpdate event _ -> @@ -144,7 +145,7 @@ receiveEvents phi dispvar = do if pend /= 0 then do liftIO $ nextEvent disp xevent - event <- liftIO $ getEvent xevent + event <- liftIO $ Util.getEvent disp xevent sendMessage phi event return True @@ -152,18 +153,23 @@ receiveEvents phi dispvar = do when (not handled) $ threadWaitRead connection -updatePanels :: Display -> Bool -> PhiX () -updatePanels disp redraw = do +updatePanels :: Widget.Display -> PhiX () +updatePanels dispvar = do rootImage <- gets phiRootImage panels <- gets phiPanels panels' <- forM panels $ \panel -> do - let buffer = panelBuffer panel + let pixmap = panelPixmap panel area = panelArea panel - newPanel <- if not redraw then return panel else do - let layoutedWidgets = (withDimension area $ Widget.layoutWidgets (panelWidgetStates panel) 0 0) $ panelScreenArea panel - panel' = panel { panelWidgetStates = layoutedWidgets } + let layoutedWidgets = (withDimension area $ Widget.layoutWidgets (panelWidgetStates panel) 0 0) $ panelScreenArea panel + panel' = panel { panelWidgetStates = layoutedWidgets } + + Widget.withDisplay dispvar $ \disp -> do + let screen = defaultScreen disp + visual = defaultVisual disp screen + + buffer <- liftIO $ withDimension area $ Util.createXlibSurface disp pixmap visual renderWith buffer $ do withPatternForSurface rootImage $ \pattern -> do @@ -174,20 +180,16 @@ updatePanels disp redraw = do restore Widget.renderWidgets layoutedWidgets $ panelScreenArea panel - return panel' - - let screen = defaultScreen disp - visual = defaultVisual disp screen - surface <- liftIO $ withDimension area $ Util.createXlibSurface disp (panelWindow newPanel) visual - - -- copy buffer to window - renderWith surface $ withPatternForSurface buffer $ \pattern -> do - setSource pattern - paint - surfaceFinish surface + surfaceFinish buffer + + -- copy buffer to window + liftIO $ do + setWindowBackgroundPixmap disp (panelWindow panel') pixmap + (withDimension area $ clearArea disp (panelWindow panel') 0 0) True + sync disp False - return newPanel - + return panel' + modify $ \state -> state { phiPanels = panels' } @@ -199,6 +201,7 @@ handlePropertyUpdate disp PropertyEvent { ev_atom = atom } = do when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do updateRootImage disp + sendMessage phi ResetBackground sendMessage phi Repaint @@ -232,26 +235,27 @@ updateRootImage disp = do surfaceFinish rootSurface -createPanel :: Display -> [Widget.WidgetState] -> Rectangle -> PhiX PanelState -createPanel disp widgets screenRect = do - phi <- asks phiPhi +createPanel :: Display -> Window -> [Widget.WidgetState] -> Rectangle -> PhiX PanelState +createPanel disp win widgets screenRect = do config <- asks phiPanelConfig let rect = panelBounds config screenRect - - win <- createPanelWindow disp rect - - buffer <- liftIO $ withDimension rect $ createImageSurface FormatRGB24 + let screen = defaultScreen disp + depth = defaultDepth disp screen + + pixmap <- liftIO $ (withDimension rect $ createPixmap disp win) depth return PanelState { panelWindow = win - , panelBuffer = buffer + , panelPixmap = pixmap , panelArea = rect , panelScreenArea = screenRect , panelWidgetStates = widgets } createPanelWindow :: Display -> Rectangle -> PhiX Window -createPanelWindow disp rect = do - let screen = defaultScreen disp +createPanelWindow disp screenRect = do + config <- asks phiPanelConfig + let rect = panelBounds config screenRect + screen = defaultScreen disp depth = defaultDepth disp screen visual = defaultVisual disp screen colormap = defaultColormap disp screen |