diff options
Diffstat (limited to 'src/Xmobar/X11/Loop.hs')
| -rw-r--r-- | src/Xmobar/X11/Loop.hs | 211 |
1 files changed, 105 insertions, 106 deletions
diff --git a/src/Xmobar/X11/Loop.hs b/src/Xmobar/X11/Loop.hs index aeaf38a..3c1a25c 100644 --- a/src/Xmobar/X11/Loop.hs +++ b/src/Xmobar/X11/Loop.hs @@ -19,159 +19,158 @@ module Xmobar.X11.Loop (x11Loop) where import Prelude hiding (lookup) -import Graphics.X11.Xlib hiding (textExtents, textWidth, Segment, Button) -import Graphics.X11.Xlib.Extras -import Graphics.X11.Xinerama -import Graphics.X11.Xrandr -import Control.Monad.Reader -import Control.Concurrent -import Control.Concurrent.STM +import Control.Concurrent as Concurrent +import Control.Concurrent.STM as STM +import Control.Monad.Reader as MR -import Data.Bits +import Data.Bits (Bits((.|.))) import qualified Data.Map as Map -import Data.List.NonEmpty (NonEmpty(..)) +import Data.List.NonEmpty (NonEmpty((:|))) import qualified Data.List.NonEmpty as NE -import Xmobar.System.Signal -import Xmobar.Config.Types ( persistent - , alpha - , font - , additionalFonts - , position - , iconRoot - , Config - , XPosition(..)) - -import Xmobar.Run.Actions -import Xmobar.Run.Parsers -import Xmobar.X11.Window -import Xmobar.X11.Text -import Xmobar.X11.Draw -import Xmobar.X11.Bitmap as Bitmap -import Xmobar.X11.Types -import Xmobar.System.Utils (forkThread) - -import Xmobar.Run.Loop (loop) +import qualified Graphics.X11.Xlib as X11 +import qualified Graphics.X11.Xlib.Extras as X11x +import qualified Graphics.X11.Xinerama as Xinerama +import qualified Graphics.X11.Xrandr as Xrandr + +import qualified Xmobar.Config.Types as C + +import qualified Xmobar.Run.Actions as A +import qualified Xmobar.Run.Loop as L +import qualified Xmobar.Run.Parsers as P + +import qualified Xmobar.System.Utils as U +import qualified Xmobar.System.Signal as S + +import qualified Xmobar.X11.Types as T +import qualified Xmobar.X11.Text as Text +import qualified Xmobar.X11.Draw as Draw +import qualified Xmobar.X11.Bitmap as Bitmap +import qualified Xmobar.X11.Window as W #ifndef THREADED_RUNTIME -import Xmobar.X11.Events(nextEvent') +import qualified Xmobar.X11.Events as E #endif -runX :: XConf -> X a -> IO a -runX xc f = runReaderT f xc +runX :: T.XConf -> T.X a -> IO a +runX xc f = MR.runReaderT f xc --- | Starts the main event loop and threads -x11Loop :: Config -> IO () +-- | Starts the main event loop thread +x11Loop :: C.Config -> IO () x11Loop conf = do - initThreads - d <- openDisplay "" - fs <- initFont d (font conf) - fl <- mapM (initFont d) (additionalFonts conf) - (r,w) <- createWin d fs conf - loop conf (startLoop (XConf d r w (fs :| fl) Map.empty conf)) - -startLoop :: XConf -> TMVar SignalType -> TVar [String] -> IO () -startLoop xcfg@(XConf _ _ w _ _ _) sig tv = do - forkThread "X event handler" (x11EventLoop w sig) - signalLoop xcfg [] sig tv + X11.initThreads + d <- X11.openDisplay "" + fs <- Text.initFont d (C.font conf) + fl <- mapM (Text.initFont d) (C.additionalFonts conf) + (r,w) <- W.createWin d fs conf + L.loop conf (startLoop (T.XConf d r w (fs :| fl) Map.empty conf)) + +startLoop :: T.XConf -> STM.TMVar S.SignalType -> STM.TVar [String] -> IO () +startLoop xcfg sig tv = do + U.forkThread "X event handler" (eventLoop (T.display xcfg) (T.window xcfg) sig) + signalLoop xcfg [] sig tv -- | Translates X11 events received by w to signals handled by signalLoop -x11EventLoop :: Window -> TMVar SignalType -> IO () -x11EventLoop w signal = - allocaXEvent $ \e -> do - dpy <- openDisplay "" - xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask - selectInput dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask) - - forever $ do +eventLoop :: X11.Display -> X11.Window -> STM.TMVar S.SignalType -> IO () +eventLoop dpy w signalv = + X11.allocaXEvent $ \e -> do + let root = X11.defaultRootWindow dpy + m = X11.exposureMask .|. X11.structureNotifyMask .|. X11.buttonPressMask + Xrandr.xrrSelectInput dpy root X11.rrScreenChangeNotifyMask + X11.selectInput dpy w m + + MR.forever $ do #ifdef THREADED_RUNTIME - nextEvent dpy e + X11.nextEvent dpy e #else - nextEvent' dpy e + E.nextEvent' dpy e #endif - ev <- getEvent e + ev <- X11x.getEvent e + let send s = STM.atomically (STM.putTMVar signalv s) case ev of - ConfigureEvent {} -> atomically $ putTMVar signal Reposition - ExposeEvent {} -> atomically $ putTMVar signal Wakeup - RRScreenChangeNotifyEvent {} -> atomically $ putTMVar signal Reposition - ButtonEvent {} -> atomically $ - putTMVar signal (Action (ev_button ev) (fi $ ev_x ev)) + X11x.ConfigureEvent {} -> send S.Reposition + X11x.RRScreenChangeNotifyEvent {} -> send S.Reposition + X11x.ExposeEvent {} -> send S.Wakeup + X11x.ButtonEvent {} -> send (S.Action b p) + where (b, p) = (X11x.ev_button ev, fromIntegral $ X11x.ev_x ev) _ -> return () -- | Continuously wait for a signal from a thread or an interrupt handler. -- The list of actions provides the positions of clickable rectangles, -- and there is a mutable variable for received signals and the list -- of strings updated by running monitors. -signalLoop :: XConf - -> [([Action], Position, Position)] - -> TMVar SignalType - -> TVar [String] +signalLoop :: T.XConf + -> [([A.Action], X11.Position, X11.Position)] + -> STM.TMVar S.SignalType + -> STM.TVar [String] -> IO () -signalLoop xc@(XConf d r w fs is cfg) actions signal strs = do - typ <- atomically $ takeTMVar signal +signalLoop xc@(T.XConf d r w fs is cfg) actions signalv strs = do + typ <- STM.atomically $ STM.takeTMVar signalv case typ of - Wakeup -> wakeup - Action button x -> runActions actions button x >> loopOn - Reposition -> reposWindow cfg - ChangeScreen -> updateConfigPosition d cfg >>= reposWindow - Hide t -> hiderev t Hide hideWindow - Reveal t -> hiderev t Reveal (showWindow r cfg) - Toggle t -> toggle t - TogglePersistent -> updateCfg $ cfg {persistent = not $ persistent cfg} - SetAlpha a -> updateCfg $ cfg {alpha = a} + S.Wakeup -> wakeup + S.Action button x -> runActions actions button x >> loopOn + S.Reposition -> reposWindow cfg + S.ChangeScreen -> updateConfigPosition d cfg >>= reposWindow + S.Hide t -> hiderev t S.Hide W.hideWindow + S.Reveal t -> hiderev t S.Reveal (W.showWindow r cfg) + S.Toggle t -> toggle t + S.TogglePersistent -> updateCfg $ cfg {C.persistent = not $ C.persistent cfg} + S.SetAlpha a -> updateCfg $ cfg {C.alpha = a} where - loopOn' xc' = signalLoop xc' actions signal strs + loopOn' xc' = signalLoop xc' actions signalv strs loopOn = loopOn' xc - updateCfg cfg' = loopOn' (xc {config = cfg'}) + updateCfg cfg' = loopOn' (xc {T.config = cfg'}) wakeup = do segs <- parseSegments cfg strs xc' <- updateIconCache xc segs - actions' <- runX xc' $ drawInWin segs - signalLoop xc' actions' signal strs + actions' <- runX xc' $ Draw.drawInWin segs + signalLoop xc' actions' signalv strs hiderev t sign op - | t == 0 = unless (persistent cfg) (op d w) >> loopOn + | t == 0 = MR.unless (C.persistent cfg) (op d w) >> loopOn | otherwise = do - void $ forkIO - $ threadDelay (t*100*1000) >> - atomically (putTMVar signal $ sign 0) + MR.void $ Concurrent.forkIO + $ Concurrent.threadDelay (t*100*1000) >> + STM.atomically (STM.putTMVar signalv $ sign 0) loopOn toggle t = do - ismapped <- isMapped d w - atomically (putTMVar signal $ if ismapped then Hide t else Reveal t) - loopOn + ismapped <- W.isMapped d w + let s = if ismapped then S.Hide t else S.Reveal t + STM.atomically (STM.putTMVar signalv s) + loopOn reposWindow rcfg = do - r' <- repositionWin d w (NE.head fs) rcfg - signalLoop (XConf d r' w fs is rcfg) actions signal strs + r' <- W.repositionWin d w (NE.head fs) rcfg + signalLoop (T.XConf d r' w fs is rcfg) actions signalv strs -parseSegments :: Config -> TVar [String] -> IO [[Segment]] +parseSegments :: C.Config -> STM.TVar [String] -> IO [[P.Segment]] parseSegments conf v = do - s <- readTVarIO v + s <- STM.readTVarIO v let l:c:r:_ = s ++ repeat "" - liftIO $ mapM (parseString conf) [l, c, r] + MR.liftIO $ mapM (P.parseString conf) [l, c, r] -updateIconCache :: XConf -> [[Segment]] -> IO XConf -updateIconCache xc@(XConf d _ w _ c cfg) segs = do - c' <- updateCache d w c (iconRoot cfg) [p | (Icon p, _, _, _) <- concat segs] - return $ xc {iconCache = c'} +updateIconCache :: T.XConf -> [[P.Segment]] -> IO T.XConf +updateIconCache xc@(T.XConf d _ w _ c cfg) segs = do + let paths = [p | (P.Icon p, _, _, _) <- concat segs] + c' <- Bitmap.updateCache d w c (C.iconRoot cfg) paths + return $ xc {T.iconCache = c'} -updateConfigPosition :: Display -> Config -> IO Config +updateConfigPosition :: X11.Display -> C.Config -> IO C.Config updateConfigPosition disp cfg = - case position cfg of - OnScreen n o -> do - srs <- getScreenInfo disp + case C.position cfg of + C.OnScreen n o -> do + srs <- Xinerama.getScreenInfo disp return (if n == length srs - then (cfg {position = OnScreen 1 o}) - else (cfg {position = OnScreen (n+1) o})) - o -> return (cfg {position = OnScreen 1 o}) + then (cfg {C.position = C.OnScreen 1 o}) + else (cfg {C.position = C.OnScreen (n+1) o})) + o -> return (cfg {C.position = C.OnScreen 1 o}) -runActions :: [ActionPos] -> Button -> Position -> IO () +runActions :: [T.ActionPos] -> A.Button -> X11.Position -> IO () runActions actions button pos = - mapM_ runAction $ - filter (\(Spawn b _) -> button `elem` b) $ + mapM_ A.runAction $ + filter (\(A.Spawn b _) -> button `elem` b) $ concatMap (\(a,_,_) -> a) $ filter (\(_, from, to) -> pos >= from && pos <= to) actions |