diff options
| -rw-r--r-- | lib/Phi/Phi.hs | 13 | ||||
| -rw-r--r-- | lib/Phi/Widget.hs | 3 | ||||
| -rw-r--r-- | lib/Phi/X11.hs | 118 | ||||
| -rw-r--r-- | src/Phi.hs | 3 |
4 files changed, 84 insertions, 53 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 @@ -10,8 +10,9 @@ import Data.Monoid main :: IO () main = do phi <- initPhi - initPhiX phi defaultXConfig defaultPanelConfig { panelPosition = Bottom, panelSize = 48 } + initPhiX phi defaultXConfig defaultPanelConfig { panelPosition = Bottom } [border border1 [border border3 [], border border3 []], border border2 []] + runPhi phi where border1 = BorderConfig (simpleBorderWidth 1) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.25, 0.25, 0.25, 0.5) 7 2 border2 = BorderConfig (simpleBorderWidth 1) 1 (simpleBorderWidth 2) (1, 1, 1, 0.5) (0.5, 0.0, 0.25, 0.5) 7 1 |