summaryrefslogtreecommitdiffstats
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Phi/Phi.hs16
-rw-r--r--lib/Phi/X11.hs36
2 files changed, 31 insertions, 21 deletions
diff --git a/lib/Phi/Phi.hs b/lib/Phi/Phi.hs
index 3f4b59b..ab384a0 100644
--- a/lib/Phi/Phi.hs
+++ b/lib/Phi/Phi.hs
@@ -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
diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs
index 3beb47e..709d04a 100644
--- a/lib/Phi/X11.hs
+++ b/lib/Phi/X11.hs
@@ -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