summaryrefslogtreecommitdiffstats
path: root/lib/Phi
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Phi')
-rw-r--r--lib/Phi/Phi.hs13
-rw-r--r--lib/Phi/Widget.hs3
-rw-r--r--lib/Phi/X11.hs118
3 files changed, 82 insertions, 52 deletions
diff --git a/lib/Phi/Phi.hs b/lib/Phi/Phi.hs
index 9df36f3..5d14181 100644
--- a/lib/Phi/Phi.hs
+++ b/lib/Phi/Phi.hs
@@ -2,7 +2,8 @@
module Phi.Phi ( Phi
, MessageBus
- , Message(..)
+ , Message
+ , fromMessage
, initPhi
, runPhi
, sendMessage
@@ -12,11 +13,15 @@ module Phi.Phi ( Phi
import Control.Concurrent.Chan
import Control.Monad
+import Data.Typeable
data Phi = Phi (Chan Message)
data MessageBus = MessageBus (Chan Message)
-data Message = forall a. Show a => Message a
+data Message = forall a. (Typeable a, Show a) => Message a
+
+fromMessage :: (Typeable a, Show a) => Message -> Maybe a
+fromMessage (Message m) = cast m
initPhi :: IO Phi
initPhi = liftM Phi newChan
@@ -24,8 +29,8 @@ initPhi = liftM Phi newChan
runPhi :: Phi -> IO ()
runPhi (Phi chan) = forever $ readChan chan
-sendMessage :: Phi -> Message -> IO ()
-sendMessage (Phi chan) = writeChan chan
+sendMessage :: (Typeable a, Show a) => Phi -> a -> IO ()
+sendMessage (Phi chan) = writeChan chan . Message
getMessageBus :: Phi -> IO MessageBus
getMessageBus (Phi chan) = liftM MessageBus $ dupChan chan
diff --git a/lib/Phi/Widget.hs b/lib/Phi/Widget.hs
index 3f00508..f6703a7 100644
--- a/lib/Phi/Widget.hs
+++ b/lib/Phi/Widget.hs
@@ -1,7 +1,6 @@
{-# LANGUAGE ExistentialQuantification, TypeFamilies, StandaloneDeriving, FlexibleContexts #-}
-module Phi.Widget ( Message(..)
- , Widget(..)
+module Phi.Widget ( Widget(..)
, WidgetClass(..)
, WidgetState(..)
, separator
diff --git a/lib/Phi/X11.hs b/lib/Phi/X11.hs
index 548027c..806986d 100644
--- a/lib/Phi/X11.hs
+++ b/lib/Phi/X11.hs
@@ -1,4 +1,4 @@
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving, PatternGuards #-}
module Phi.X11 ( XConfig(..)
, defaultXConfig
@@ -16,10 +16,14 @@ import Data.Maybe
import Data.Bits
import Data.Char
+import Control.Concurrent
+import Control.Concurrent.MVar
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Trans
+import System.Posix.Types
+
import Phi.Phi
import qualified Phi.Types as Phi
import qualified Phi.Panel as Panel
@@ -45,7 +49,6 @@ data PanelState = PanelState { panelWindow :: Window
data PhiConfig = PhiConfig { phiPanelConfig :: Panel.PanelConfig
, phiXConfig :: XConfig
- , phiDisplay :: Display
, phiAtoms :: Atoms
}
@@ -61,14 +64,18 @@ newtype PhiX a = PhiX (StateT PhiState PhiReader a)
runPhiX :: PhiConfig -> PhiState -> PhiX a -> IO (a, PhiState)
runPhiX config st (PhiX a) = runPhiReader config $ runStateT a st
-liftIOContToPhiX :: ((a -> IO (b, PhiState)) -> IO (b, PhiState)) -> (a -> PhiX b) -> PhiX b
-liftIOContToPhiX f c = do
+forkPhiX :: PhiX () -> PhiX ThreadId
+forkPhiX f = do
config <- ask
state <- get
- (a, state') <- liftIO $ f $ runPhiX config state . c
- put state'
- return a
+ liftIO $ forkIO $ (runPhiX config state f >> return ())
+withMVarX :: MVar a -> (a -> PhiX b) -> PhiX b
+withMVarX m f = do
+ a <- liftIO $ takeMVar m
+ b <- f a
+ liftIO $ putMVar m a
+ return b
defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
}
@@ -77,37 +84,61 @@ defaultXConfig = XConfig { phiXScreenInfo = getScreenInfo
initPhiX :: Phi -> XConfig -> Panel.PanelConfig -> [Widget.Widget] -> IO ()
initPhiX phi xconfig config widgets = do
disp <- openDisplay []
+
atoms <- initAtoms disp
selectInput disp (defaultRootWindow disp) $ propertyChangeMask.|.structureNotifyMask
- runPhiX PhiConfig { phiXConfig = xconfig, phiPanelConfig = config, phiDisplay = disp, phiAtoms = atoms } PhiState { phiRootPixmap = 0, phiPanels = [] } $ do
- updateRootPixmap
+ runPhiX PhiConfig { phiXConfig = xconfig, phiPanelConfig = config, phiAtoms = atoms } PhiState { phiRootPixmap = 0, phiPanels = [] } $ do
+ updateRootPixmap disp
screens <- liftIO $ phiXScreenInfo xconfig disp
- panels <- mapM (createPanel widgets) screens
+ panels <- mapM (createPanel disp widgets) screens
forM_ panels $ \panel -> do
- setPanelProperties panel
+ setPanelProperties disp panel
liftIO $ mapWindow disp (panelWindow panel)
modify $ \state -> state { phiPanels = panels }
- updatePanels True
-
- liftIOContToPhiX allocaXEvent $ \xevent -> do
- forever $ do
- liftIO $ nextEvent disp xevent
- event <- liftIO $ getEvent xevent
-
- case event of
- ExposeEvent {} -> updatePanels False
- PropertyEvent {} -> handlePropertyUpdate event
- _ -> return ()
+ updatePanels disp True
+
+ dispvar <- liftIO $ newMVar disp
+ liftIO $ forkIO $ receiveEvents phi dispvar
+
+ messagebus <- liftIO $ getMessageBus phi
+ forkPhiX $ forever $ do
+ message <- liftIO $ receiveMessage messagebus
+ handleMessage dispvar message
return ()
-updatePanels :: Bool -> PhiX ()
-updatePanels redraw = do
- disp <- asks phiDisplay
+handleMessage :: MVar Display -> Message -> PhiX ()
+handleMessage dispvar m
+ | Just ExposeEvent {} <- fromMessage m = withMVarX dispvar $ \disp -> do
+ updatePanels disp False
+ | Just event@PropertyEvent {} <- fromMessage m = withMVarX dispvar $ \disp -> do
+ handlePropertyUpdate disp event
+handleMessage _ _ = return ()
+
+receiveEvents :: Phi -> MVar Display -> IO ()
+receiveEvents phi dispvar = do
+ connection <- withMVar dispvar $ return . Fd . connectionNumber
+
+ forever $ allocaXEvent $ \xevent -> do
+ handled <- withMVar dispvar $ \disp -> do
+ pend <- pending disp
+ if pend /= 0 then
+ do
+ liftIO $ nextEvent disp xevent
+ event <- liftIO $ getEvent xevent
+ sendMessage phi event
+
+ return True
+ else return False
+
+ when (not handled) $ threadWaitRead connection
+
+updatePanels :: Display -> Bool -> PhiX ()
+updatePanels disp redraw = do
rootPixmap <- gets phiRootPixmap
panels <- gets phiPanels
@@ -135,19 +166,18 @@ updatePanels redraw = do
modify $ \state -> state { phiPanels = panels' }
-handlePropertyUpdate :: Event -> PhiX ()
-handlePropertyUpdate PropertyEvent { ev_atom = atom } = do
+handlePropertyUpdate :: Display -> Event -> PhiX ()
+handlePropertyUpdate disp PropertyEvent { ev_atom = atom } = do
atoms <- asks phiAtoms
panels <- gets phiPanels
when (atom == atom_XROOTPMAP_ID atoms || atom == atom_XROOTMAP_ID atoms) $ do
- updateRootPixmap
- updatePanels True
+ updateRootPixmap disp
+ updatePanels disp True
-updateRootPixmap :: PhiX ()
-updateRootPixmap = do
- disp <- asks phiDisplay
+updateRootPixmap :: Display -> PhiX ()
+updateRootPixmap disp = do
atoms <- asks phiAtoms
let screen = defaultScreen disp
rootwin = defaultRootWindow disp
@@ -156,13 +186,12 @@ updateRootPixmap = do
modify $ \state -> state { phiRootPixmap = pixmap }
-createPanel :: [Widget.Widget] -> Rectangle -> PhiX PanelState
-createPanel widgets screenRect = do
+createPanel :: Display -> [Widget.Widget] -> Rectangle -> PhiX PanelState
+createPanel disp widgets screenRect = do
config <- asks phiPanelConfig
- disp <- asks phiDisplay
let rect = panelBounds config screenRect
- win <- createPanelWindow rect
+ win <- createPanelWindow disp rect
gc <- liftIO $ createGC disp win
let screen = defaultScreen disp
@@ -174,9 +203,8 @@ createPanel widgets screenRect = do
return PanelState { panelWindow = win, panelGC = gc, panelPixmap = pixmap, panelSurface = surface, panelArea = rect, panelScreenArea = screenRect, panelWidgetStates = map Widget.createWidgetState widgets }
-createPanelWindow :: Rectangle -> PhiX Window
-createPanelWindow rect = do
- disp <- asks phiDisplay
+createPanelWindow :: Display -> Rectangle -> PhiX Window
+createPanelWindow disp rect = do
let screen = defaultScreen disp
depth = defaultDepth disp screen
visual = defaultVisual disp screen
@@ -192,9 +220,8 @@ createPanelWindow rect = do
withRectangle rect (createWindow disp rootwin) 0 depth inputOutput visual mask attr
-setPanelProperties :: PanelState -> PhiX ()
-setPanelProperties panel = do
- disp <- asks phiDisplay
+setPanelProperties :: Display -> PanelState -> PhiX ()
+setPanelProperties disp panel = do
atoms <- asks phiAtoms
liftIO $ do
storeName disp (panelWindow panel) "Phi"
@@ -221,13 +248,12 @@ setPanelProperties panel = do
Util.setClassHint disp (panelWindow panel) ClassHint { resName = "phi", resClass = "Phi" }
- setStruts panel
+ setStruts disp panel
-setStruts :: PanelState -> PhiX ()
-setStruts panel = do
+setStruts :: Display -> PanelState -> PhiX ()
+setStruts disp panel = do
atoms <- asks phiAtoms
- disp <- asks phiDisplay
config <- asks phiPanelConfig
let rootwin = defaultRootWindow disp
position = Panel.panelPosition config
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 07:58:56 +0100