diff options
Diffstat (limited to 'lib/Phi')
| -rw-r--r-- | lib/Phi/Phi.hs | 16 | ||||
| -rw-r--r-- | lib/Phi/X11.hs | 36 |
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 |