Don't redraw when there are still messages pending
This commit is contained in:
parent
b2b35e632a
commit
8854f0aec4
3 changed files with 33 additions and 22 deletions
|
|
@ -8,15 +8,16 @@ module Phi.Phi ( Phi
|
|||
, dupPhi
|
||||
, sendMessage
|
||||
, receiveMessage
|
||||
, messageAvailable
|
||||
) where
|
||||
|
||||
import Control.Concurrent.Chan
|
||||
import Control.Concurrent.STM
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
|
||||
import Data.Typeable
|
||||
|
||||
data Phi = Phi (Chan Message)
|
||||
data Phi = Phi (TChan Message)
|
||||
|
||||
data Message = forall a. (Typeable a, Show a) => Message a
|
||||
deriving instance Show Message
|
||||
|
|
@ -27,13 +28,16 @@ fromMessage :: (Typeable a, Show a) => Message -> Maybe a
|
|||
fromMessage (Message m) = cast m
|
||||
|
||||
initPhi :: MonadIO m => m Phi
|
||||
initPhi = liftM Phi $ liftIO newChan
|
||||
initPhi = liftM Phi $ liftIO $ atomically newTChan
|
||||
|
||||
dupPhi :: MonadIO m => Phi -> m Phi
|
||||
dupPhi (Phi chan) = liftM Phi $ liftIO $ dupChan chan
|
||||
dupPhi (Phi chan) = liftM Phi $ liftIO $ atomically $ dupTChan chan
|
||||
|
||||
sendMessage :: (MonadIO m, Typeable a, Show a) => Phi -> a -> m ()
|
||||
sendMessage (Phi chan) = liftIO . writeChan chan . Message
|
||||
sendMessage (Phi chan) = liftIO . atomically . writeTChan chan . Message
|
||||
|
||||
receiveMessage :: MonadIO m => Phi -> m Message
|
||||
receiveMessage (Phi chan) = liftIO $ readChan chan
|
||||
receiveMessage (Phi chan) = liftIO $ atomically $ readTChan chan
|
||||
|
||||
messageAvailable :: MonadIO m => Phi -> m Bool
|
||||
messageAvailable (Phi chan) = liftIO $ liftM not $ atomically $ isEmptyTChan chan
|
||||
|
|
|
|||
|
|
@ -35,9 +35,9 @@ import qualified Phi.Bindings.Util as Util
|
|||
data XConfig = XConfig { phiXScreenInfo :: !(Display -> IO [Rectangle])
|
||||
}
|
||||
|
||||
data PhiState = PhiState { phiPhi :: !Phi
|
||||
, phiRootImage :: !Surface
|
||||
data PhiState = PhiState { phiRootImage :: !Surface
|
||||
, phiPanels :: ![PanelState]
|
||||
, phiRepaint :: !Bool
|
||||
}
|
||||
|
||||
data PanelState = PanelState { panelWindow :: !Window
|
||||
|
|
@ -47,7 +47,8 @@ data PanelState = PanelState { panelWindow :: !Window
|
|||
, panelWidgetStates :: ![Widget.WidgetState]
|
||||
}
|
||||
|
||||
data PhiConfig = PhiConfig { phiPanelConfig :: !Panel.PanelConfig
|
||||
data PhiConfig = PhiConfig { phiPhi :: !Phi
|
||||
, phiPanelConfig :: !Panel.PanelConfig
|
||||
, phiXConfig :: !XConfig
|
||||
, phiAtoms :: !Atoms
|
||||
}
|
||||
|
|
@ -79,7 +80,7 @@ runPhi xconfig config widgets = do
|
|||
selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask
|
||||
|
||||
bg <- createImageSurface FormatRGB24 1 1
|
||||
runPhiX PhiConfig { phiXConfig = xconfig, phiPanelConfig = config, phiAtoms = atoms } PhiState { phiPhi = phi, phiRootImage = bg, phiPanels = [] } $ do
|
||||
runPhiX PhiConfig { phiPhi = phi, phiXConfig = xconfig, phiPanelConfig = config, phiAtoms = atoms } PhiState { phiRootImage = bg, phiPanels = [], phiRepaint = True } $ do
|
||||
updateRootImage disp
|
||||
|
||||
screens <- liftIO $ phiXScreenInfo xconfig disp
|
||||
|
|
@ -97,11 +98,16 @@ runPhi xconfig config widgets = do
|
|||
|
||||
modify $ \state -> state { phiPanels = panels }
|
||||
|
||||
updatePanels disp True
|
||||
|
||||
liftIO $ forkIO $ receiveEvents phi dispvar
|
||||
|
||||
forever $ do
|
||||
available <- messageAvailable phi
|
||||
unless available $ do
|
||||
repaint <- gets phiRepaint
|
||||
when repaint $ do
|
||||
Widget.withDisplay dispvar $ flip updatePanels True
|
||||
modify $ \state -> state {phiRepaint = False}
|
||||
|
||||
message <- receiveMessage phi
|
||||
handleMessage dispvar message
|
||||
return ()
|
||||
|
|
@ -117,14 +123,14 @@ handleMessage dispvar m = do
|
|||
modify $ \state@PhiState {phiPanels = panels} -> state {phiPanels = map (handlePanel m) panels}
|
||||
|
||||
case (fromMessage m) of
|
||||
Just Repaint -> Widget.withDisplay dispvar $ \disp ->
|
||||
updatePanels disp True
|
||||
Just Repaint ->
|
||||
modify $ \state -> state {phiRepaint = True}
|
||||
_ ->
|
||||
case (fromMessage m) of
|
||||
Just ExposeEvent {} -> Widget.withDisplay dispvar $ \disp ->
|
||||
updatePanels disp False
|
||||
Just event@PropertyEvent {} -> Widget.withDisplay dispvar $ \disp ->
|
||||
handlePropertyUpdate disp event
|
||||
Just ExposeEvent {} ->
|
||||
Widget.withDisplay dispvar $ flip updatePanels False
|
||||
Just event@PropertyEvent {} ->
|
||||
Widget.withDisplay dispvar $ flip handlePropertyUpdate event
|
||||
_ ->
|
||||
return ()
|
||||
|
||||
|
|
@ -187,19 +193,19 @@ updatePanels disp redraw = do
|
|||
|
||||
handlePropertyUpdate :: Display -> Event -> PhiX ()
|
||||
handlePropertyUpdate disp PropertyEvent { ev_atom = atom } = do
|
||||
phi <- asks phiPhi
|
||||
atoms <- asks phiAtoms
|
||||
panels <- gets phiPanels
|
||||
|
||||
when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do
|
||||
updateRootImage disp
|
||||
updatePanels disp True
|
||||
sendMessage phi Repaint
|
||||
|
||||
|
||||
updateRootImage :: Display -> PhiX ()
|
||||
updateRootImage disp = do
|
||||
atoms <- asks phiAtoms
|
||||
|
||||
|
||||
let screen = defaultScreen disp
|
||||
visual = defaultVisual disp screen
|
||||
rootwin = defaultRootWindow disp
|
||||
|
|
@ -228,7 +234,7 @@ updateRootImage disp = do
|
|||
|
||||
createPanel :: Display -> [Widget.WidgetState] -> Rectangle -> PhiX PanelState
|
||||
createPanel disp widgets screenRect = do
|
||||
phi <- gets phiPhi
|
||||
phi <- asks phiPhi
|
||||
config <- asks phiPanelConfig
|
||||
let rect = panelBounds config screenRect
|
||||
|
||||
|
|
|
|||
|
|
@ -11,11 +11,12 @@ maintainer: mschiffer@universe-factory.net
|
|||
build-type: Simple
|
||||
|
||||
library
|
||||
build-depends: base >= 4, template-haskell, array, containers, transformers, mtl, utf8-string, time, old-locale, X11, cairo, pango
|
||||
build-depends: base >= 4, template-haskell, stm, array, containers, transformers, mtl, utf8-string, time, old-locale, X11, cairo, pango
|
||||
exposed-modules: Phi.Types, Phi.Phi, Phi.Panel, Phi.Widget, Phi.Border, Phi.X11,
|
||||
Phi.Widgets.Clock, Phi.Widgets.Taskbar
|
||||
other-modules: Phi.X11.Atoms, Phi.X11.AtomList, Phi.Bindings.Util
|
||||
hs-source-dirs: lib
|
||||
ghc-options: -fspec-constr-count=16
|
||||
|
||||
executable Phi
|
||||
build-depends: base >= 4, phi
|
||||
|
|
|
|||
Reference in a new issue