{-# LANGUAGE CPP #-}
module Xmobar.App.EventLoop (startLoop, startCommand) where
import Prelude hiding (lookup)
import Graphics.X11.Xlib hiding (textExtents, textWidth)
import Graphics.X11.Xlib.Extras
import Graphics.X11.Xinerama
import Graphics.X11.Xrandr
import Control.Arrow ((&&&))
import Control.Applicative ((<$>))
import Control.Monad.Reader
import Control.Concurrent
import Control.Concurrent.Async (Async, async)
import Control.Concurrent.STM
import Control.Exception (handle, SomeException(..))
import Data.Bits
import Data.Map hiding (foldr, map, filter)
import Data.Maybe (fromJust, isJust)
import Xmobar.System.Signal
import Xmobar.Config.Types
import Xmobar.Run.Exec
import Xmobar.Run.Runnable
import Xmobar.X11.Actions
import Xmobar.X11.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.X11.Events(nextEvent')
#ifdef XFT
import Graphics.X11.Xft
#endif
#ifdef DBUS
import Xmobar.System.DBus
#endif
runX :: XConf -> X () -> IO ()
runX xc f = runReaderT f xc
startLoop :: XConf -> TMVar SignalType -> [[([Async ()], TVar String)]]
-> IO ()
startLoop xcfg@(XConf _ _ w _ _ _ _) sig vs = do
#ifdef XFT
xftInitFtLibrary
#endif
tv <- atomically $ newTVar []
_ <- forkIO (handle (handler "checker") (checker tv [] vs sig))
#ifdef THREADED_RUNTIME
_ <- forkOS (handle (handler "eventer") (eventer sig))
#else
_ <- forkIO (handle (handler "eventer") (eventer sig))
#endif
#ifdef DBUS
runIPC sig
#endif
eventLoop tv xcfg [] sig
where
handler thing (SomeException e) =
void $ putStrLn ("Thread " ++ thing ++ " failed: " ++ show e)
eventer signal =
allocaXEvent $ \e -> do
dpy <- openDisplay ""
xrrSelectInput dpy (defaultRootWindow dpy) rrScreenChangeNotifyMask
selectInput dpy w (exposureMask .|. structureNotifyMask .|. buttonPressMask)
forever $ do
#ifdef THREADED_RUNTIME
nextEvent dpy e
#else
nextEvent' dpy e
#endif
ev <- getEvent e
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))
_ -> return ()
checker :: TVar [String]
-> [String]
-> [[([Async ()], TVar String)]]
-> TMVar SignalType
-> IO ()
checker tvar ov vs signal = do
nval <- atomically $ do
nv <- mapM concatV vs
guard (nv /= ov)
writeTVar tvar nv
return nv
atomically $ putTMVar signal Wakeup
checker tvar nval vs signal
where
concatV = fmap concat . mapM (readTVar . snd)
eventLoop :: TVar [String]
-> XConf
-> [([Action], Position, Position)]
-> TMVar SignalType
-> IO ()
eventLoop tv xc@(XConf d r w fs vos is cfg) as signal = do
typ <- atomically $ takeTMVar signal
case typ of
Wakeup -> do
str <- updateString cfg tv
xc' <- updateCache d w is (iconRoot cfg) str >>=
\c -> return xc { iconS = c }
as' <- updateActions xc r str
runX xc' $ drawInWin r str
eventLoop tv xc' as' signal
Reposition ->
reposWindow cfg
ChangeScreen -> do
ncfg <- updateConfigPosition cfg
reposWindow ncfg
Hide t -> hide (t*100*1000)
Reveal t -> reveal (t*100*1000)
Toggle t -> toggle t
TogglePersistent -> eventLoop
tv xc { config = cfg { persistent = not $ persistent cfg } } as signal
Action but x -> action but x
where
isPersistent = not $ persistent cfg
hide t
| t == 0 =
when isPersistent (hideWindow d w) >> eventLoop tv xc as signal
| otherwise = do
void $ forkIO
$ threadDelay t >> atomically (putTMVar signal $ Hide 0)
eventLoop tv xc as signal
reveal t
| t == 0 = do
when isPersistent (showWindow r cfg d w)
eventLoop tv xc as signal
| otherwise = do
void $ forkIO
$ threadDelay t >> atomically (putTMVar signal $ Reveal 0)
eventLoop tv xc as signal
toggle t = do
ismapped <- isMapped d w
atomically (putTMVar signal $ if ismapped then Hide t else Reveal t)
eventLoop tv xc as signal
reposWindow rcfg = do
r' <- repositionWin d w (head fs) rcfg
eventLoop tv (XConf d r' w fs vos is rcfg) as signal
updateConfigPosition ocfg =
case position ocfg of
OnScreen n o -> do
srs <- getScreenInfo d
return (if n == length srs
then
(ocfg {position = OnScreen 1 o})
else
(ocfg {position = OnScreen (n+1) o}))
o -> return (ocfg {position = OnScreen 1 o})
action button x = do
mapM_ runAction $
filter (\(Spawn b _) -> button `elem` b) $
concatMap (\(a,_,_) -> a) $
filter (\(_, from, to) -> x >= from && x <= to) as
eventLoop tv xc as signal
startCommand :: TMVar SignalType
-> (Runnable,String,String)
-> IO ([Async ()], TVar String)
startCommand sig (com,s,ss)
| alias com == "" = do var <- atomically $ newTVar is
atomically $ writeTVar var (s ++ ss)
return ([], var)
| otherwise = do var <- atomically $ newTVar is
let cb str = atomically $ writeTVar var (s ++ str ++ ss)
a1 <- async $ start com cb
a2 <- async $ trigger com $ maybe (return ())
(atomically . putTMVar sig)
return ([a1, a2], var)
where is = s ++ "Updating..." ++ ss
updateString :: Config -> TVar [String]
-> IO [[(Widget, String, Int, Maybe [Action])]]
updateString conf v = do
s <- readTVarIO v
let l:c:r:_ = s ++ repeat ""
liftIO $ mapM (parseString conf) [l, c, r]
updateActions :: XConf -> Rectangle -> [[(Widget, String, Int, Maybe [Action])]]
-> IO [([Action], Position, Position)]
updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do
let (d,fs) = (display &&& fontListS) conf
strLn :: [(Widget, String, Int, Maybe [Action])] -> IO [(Maybe [Action], Position, Position)]
strLn = liftIO . mapM getCoords
iconW i = maybe 0 Bitmap.width (lookup i $ iconS conf)
getCoords (Text s,_,i,a) = textWidth d (fs!!i) s >>= \tw -> return (a, 0, fi tw)
getCoords (Icon s,_,_,a) = return (a, 0, fi $ iconW s)
partCoord off xs = map (\(a, x, x') -> (fromJust a, x, x')) $
filter (\(a, _,_) -> isJust a) $
scanl (\(_,_,x') (a,_,w') -> (a, x', x' + w'))
(Nothing, 0, off)
xs
totSLen = foldr (\(_,_,len) -> (+) len) 0
remWidth xs = fi wid - totSLen xs
offs = 1
offset a xs = case a of
C -> (remWidth xs + offs) `div` 2
R -> remWidth xs
L -> offs
fmap concat $ mapM (\(a,xs) ->
(\xs' -> partCoord (offset a xs') xs') <$> strLn xs) $
zip [L,C,R] [left,center,right]