{-# LANGUAGE CPP #-}
module Xmobar.X11.Loop (x11Loop) where
import Prelude hiding (lookup)
import Control.Concurrent as Concurrent
import Control.Concurrent.STM as STM
import Control.Monad as MR
import Control.Monad.Reader as MR
import Data.Bits (Bits((.|.)))
import Data.List.NonEmpty (NonEmpty((:|)))
import qualified Data.List.NonEmpty as NE
import qualified Data.Map as Map
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.Config.Template as CT
import qualified Xmobar.Run.Actions as A
import qualified Xmobar.Run.Loop as L
import qualified Xmobar.System.Utils as U
import qualified Xmobar.System.Signal as S
import qualified Xmobar.Draw.Types as D
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 qualified Xmobar.X11.Events as E
#endif
runX :: T.XConf -> T.X a -> IO a
runX :: forall a. XConf -> X a -> IO a
runX XConf
xc X a
f = X a -> XConf -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
MR.runReaderT X a
f XConf
xc
x11Loop :: C.Config -> IO ()
x11Loop :: Config -> IO ()
x11Loop Config
conf = do
IO Status
X11.initThreads
Display
d <- String -> IO Display
X11.openDisplay String
""
XFont
fs <- Display -> String -> IO XFont
Text.initFont Display
d (Config -> String
C.font Config
conf)
[XFont]
fl <- (String -> IO XFont) -> [String] -> IO [XFont]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Display -> String -> IO XFont
Text.initFont Display
d) (Config -> [String]
C.additionalFonts Config
conf)
(Rectangle
r,Window
w) <- Display -> XFont -> Config -> IO (Rectangle, Window)
W.createWin Display
d XFont
fs Config
conf
Config -> LoopFunction -> IO ()
L.loop Config
conf (XConf -> LoopFunction
startLoop (Display
-> Rectangle
-> Window
-> NonEmpty XFont
-> BitmapCache
-> Config
-> XConf
T.XConf Display
d Rectangle
r Window
w (XFont
fs XFont -> [XFont] -> NonEmpty XFont
forall a. a -> [a] -> NonEmpty a
:| [XFont]
fl) BitmapCache
forall k a. Map k a
Map.empty Config
conf))
startLoop :: T.XConf -> STM.TMVar S.SignalType -> STM.TVar [String] -> IO ()
startLoop :: XConf -> LoopFunction
startLoop XConf
xcfg TMVar SignalType
sig TVar [String]
tv = do
String -> IO () -> IO ()
U.forkThread String
"X event handler" (Display -> Window -> TMVar SignalType -> IO ()
eventLoop (XConf -> Display
T.display XConf
xcfg) (XConf -> Window
T.window XConf
xcfg) TMVar SignalType
sig)
XConf -> Actions -> LoopFunction
signalLoop XConf
xcfg [] TMVar SignalType
sig TVar [String]
tv
eventLoop :: X11.Display -> X11.Window -> STM.TMVar S.SignalType -> IO ()
eventLoop :: Display -> Window -> TMVar SignalType -> IO ()
eventLoop Display
dpy Window
w TMVar SignalType
signalv =
(XEventPtr -> IO ()) -> IO ()
forall a. (XEventPtr -> IO a) -> IO a
X11.allocaXEvent ((XEventPtr -> IO ()) -> IO ()) -> (XEventPtr -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \XEventPtr
e -> do
let root :: Window
root = Display -> Window
X11.defaultRootWindow Display
dpy
m :: Window
m = Window
X11.exposureMask Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
X11.structureNotifyMask Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
X11.buttonPressMask
Display -> Window -> Window -> IO ()
Xrandr.xrrSelectInput Display
dpy Window
root Window
X11.rrScreenChangeNotifyMask
Display -> Window -> Window -> IO ()
X11.selectInput Display
dpy Window
w Window
m
IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
MR.forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
#ifdef THREADED_RUNTIME
X11.nextEvent dpy e
#else
Display -> XEventPtr -> IO ()
E.nextEvent' Display
dpy XEventPtr
e
#endif
Event
ev <- XEventPtr -> IO Event
X11x.getEvent XEventPtr
e
let send :: SignalType -> IO ()
send = STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (STM () -> IO ()) -> (SignalType -> STM ()) -> SignalType -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
STM.putTMVar TMVar SignalType
signalv
case Event
ev of
X11x.ConfigureEvent {} -> SignalType -> IO ()
send SignalType
S.Reposition
X11x.RRScreenChangeNotifyEvent {} -> SignalType -> IO ()
send SignalType
S.Reposition
X11x.ExposeEvent {} -> SignalType -> IO ()
send SignalType
S.Wakeup
X11x.ButtonEvent {} -> SignalType -> IO ()
send (Button -> Position -> SignalType
S.Action Button
b Position
p)
where (Button
b, Position
p) = (Event -> Button
X11x.ev_button Event
ev, Status -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Status -> Position) -> Status -> Position
forall a b. (a -> b) -> a -> b
$ Event -> Status
X11x.ev_x Event
ev)
Event
_ -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
signalLoop ::
T.XConf -> D.Actions -> STM.TMVar S.SignalType -> STM.TVar [String] -> IO ()
signalLoop :: XConf -> Actions -> LoopFunction
signalLoop xc :: XConf
xc@(T.XConf Display
d Rectangle
r Window
w NonEmpty XFont
fs BitmapCache
is Config
cfg) Actions
actions TMVar SignalType
signalv TVar [String]
strs = do
SignalType
typ <- STM SignalType -> IO SignalType
forall a. STM a -> IO a
STM.atomically (STM SignalType -> IO SignalType)
-> STM SignalType -> IO SignalType
forall a b. (a -> b) -> a -> b
$ TMVar SignalType -> STM SignalType
forall a. TMVar a -> STM a
STM.takeTMVar TMVar SignalType
signalv
case SignalType
typ of
SignalType
S.Wakeup -> IO ()
wakeup
S.Action Button
button Position
x -> Actions -> Button -> Position -> IO ()
runActions Actions
actions Button
button Position
x IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loopOn
SignalType
S.Reposition -> Config -> IO ()
reposWindow Config
cfg
SignalType
S.ChangeScreen -> Display -> Config -> IO Config
updateConfigPosition Display
d Config
cfg IO Config -> (Config -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config -> IO ()
reposWindow
S.Hide Int
t -> Int -> (Int -> SignalType) -> (Display -> Window -> IO ()) -> IO ()
forall {t}.
Num t =>
Int -> (t -> SignalType) -> (Display -> Window -> IO ()) -> IO ()
hiderev Int
t Int -> SignalType
S.Hide Display -> Window -> IO ()
W.hideWindow
S.Reveal Int
t -> Int -> (Int -> SignalType) -> (Display -> Window -> IO ()) -> IO ()
forall {t}.
Num t =>
Int -> (t -> SignalType) -> (Display -> Window -> IO ()) -> IO ()
hiderev Int
t Int -> SignalType
S.Reveal (Rectangle -> Config -> Display -> Window -> IO ()
W.showWindow Rectangle
r Config
cfg)
S.Toggle Int
t -> Int -> IO ()
toggle Int
t
SignalType
S.TogglePersistent -> Config -> IO ()
updateCfg (Config -> IO ()) -> Config -> IO ()
forall a b. (a -> b) -> a -> b
$ Config
cfg {C.persistent = not $ C.persistent cfg}
S.SetAlpha Int
a -> Config -> IO ()
updateCfg (Config -> IO ()) -> Config -> IO ()
forall a b. (a -> b) -> a -> b
$ Config
cfg {C.alpha = a}
where
loopOn' :: XConf -> IO ()
loopOn' XConf
xc' = XConf -> Actions -> LoopFunction
signalLoop XConf
xc' Actions
actions TMVar SignalType
signalv TVar [String]
strs
loopOn :: IO ()
loopOn = XConf -> IO ()
loopOn' XConf
xc
updateCfg :: Config -> IO ()
updateCfg Config
cfg' = XConf -> IO ()
loopOn' (XConf
xc {T.config = cfg'})
wakeup :: IO ()
wakeup = do
[[Segment]]
segs <- Config -> TVar [String] -> IO [[Segment]]
parseSegments Config
cfg TVar [String]
strs
XConf
xc' <- XConf -> [[Segment]] -> IO XConf
updateIconCache XConf
xc [[Segment]]
segs
Actions
actions' <- XConf -> X Actions -> IO Actions
forall a. XConf -> X a -> IO a
runX XConf
xc' ([[Segment]] -> X Actions
Draw.draw [[Segment]]
segs)
XConf -> Actions -> LoopFunction
signalLoop XConf
xc' Actions
actions' TMVar SignalType
signalv TVar [String]
strs
hiderev :: Int -> (t -> SignalType) -> (Display -> Window -> IO ()) -> IO ()
hiderev Int
t t -> SignalType
sign Display -> Window -> IO ()
op
| Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
MR.unless (Config -> Bool
C.persistent Config
cfg) (Display -> Window -> IO ()
op Display
d Window
w) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loopOn
| Bool
otherwise = do
IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
MR.void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
Concurrent.forkIO
(IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
Concurrent.threadDelay (Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
100Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1000) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
STM.putTMVar TMVar SignalType
signalv (SignalType -> STM ()) -> SignalType -> STM ()
forall a b. (a -> b) -> a -> b
$ t -> SignalType
sign t
0)
IO ()
loopOn
toggle :: Int -> IO ()
toggle Int
t = do
Bool
ismapped <- Display -> Window -> IO Bool
W.isMapped Display
d Window
w
let s :: SignalType
s = if Bool
ismapped then Int -> SignalType
S.Hide Int
t else Int -> SignalType
S.Reveal Int
t
STM () -> IO ()
forall a. STM a -> IO a
STM.atomically (TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
STM.putTMVar TMVar SignalType
signalv SignalType
s)
IO ()
loopOn
reposWindow :: Config -> IO ()
reposWindow Config
rcfg = do
Rectangle
r' <- Display -> Window -> XFont -> Config -> IO Rectangle
W.repositionWin Display
d Window
w (NonEmpty XFont -> XFont
forall a. NonEmpty a -> a
NE.head NonEmpty XFont
fs) Config
rcfg
XConf -> Actions -> LoopFunction
signalLoop (Display
-> Rectangle
-> Window
-> NonEmpty XFont
-> BitmapCache
-> Config
-> XConf
T.XConf Display
d Rectangle
r' Window
w NonEmpty XFont
fs BitmapCache
is Config
rcfg) Actions
actions TMVar SignalType
signalv TVar [String]
strs
parseSegments :: C.Config -> STM.TVar [String] -> IO [[C.Segment]]
parseSegments :: Config -> TVar [String] -> IO [[Segment]]
parseSegments Config
conf TVar [String]
v = do
[String]
s <- TVar [String] -> IO [String]
forall a. TVar a -> IO a
STM.readTVarIO TVar [String]
v
[[Segment]] -> IO [[Segment]]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([[Segment]] -> IO [[Segment]]) -> [[Segment]] -> IO [[Segment]]
forall a b. (a -> b) -> a -> b
$ (String -> [Segment]) -> [String] -> [[Segment]]
forall a b. (a -> b) -> [a] -> [b]
map (Config -> String -> [Segment]
CT.parseString Config
conf) (Int -> [String] -> [String]
forall a. Int -> [a] -> [a]
take Int
3 ([String] -> [String]) -> [String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String]
s [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
forall a. a -> [a]
repeat String
"")
updateIconCache :: T.XConf -> [[C.Segment]] -> IO T.XConf
updateIconCache :: XConf -> [[Segment]] -> IO XConf
updateIconCache xc :: XConf
xc@(T.XConf Display
d Rectangle
_ Window
w NonEmpty XFont
_ BitmapCache
c Config
cfg) [[Segment]]
segs = do
let paths :: [String]
paths = [String
p | (C.Icon String
p, TextRenderInfo
_, Int
_, Maybe [Action]
_) <- [[Segment]] -> [Segment]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Segment]]
segs]
BitmapCache
c' <- Display
-> Window -> BitmapCache -> String -> [String] -> IO BitmapCache
Bitmap.updateCache Display
d Window
w BitmapCache
c (Config -> String
C.iconRoot Config
cfg) [String]
paths
XConf -> IO XConf
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (XConf -> IO XConf) -> XConf -> IO XConf
forall a b. (a -> b) -> a -> b
$ XConf
xc {T.iconCache = c'}
updateConfigPosition :: X11.Display -> C.Config -> IO C.Config
updateConfigPosition :: Display -> Config -> IO Config
updateConfigPosition Display
disp Config
cfg =
case Config -> XPosition
C.position Config
cfg of
C.OnScreen Int
n XPosition
o -> do
[Rectangle]
srs <- Display -> IO [Rectangle]
Xinerama.getScreenInfo Display
disp
Config -> IO Config
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (if Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== [Rectangle] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Rectangle]
srs
then (Config
cfg {C.position = C.OnScreen 1 o})
else (Config
cfg {C.position = C.OnScreen (n+1) o}))
XPosition
o -> Config -> IO Config
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Config
cfg {C.position = C.OnScreen 1 o})
runActions :: D.Actions -> A.Button -> X11.Position -> IO ()
runActions :: Actions -> Button -> Position -> IO ()
runActions Actions
actions Button
button Position
pos =
(Action -> IO ()) -> [Action] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Action -> IO ()
A.runAction ([Action] -> IO ()) -> [Action] -> IO ()
forall a b. (a -> b) -> a -> b
$
(Action -> Bool) -> [Action] -> [Action]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(A.Spawn [Button]
b String
_) -> Button
button Button -> [Button] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Button]
b) ([Action] -> [Action]) -> [Action] -> [Action]
forall a b. (a -> b) -> a -> b
$
(([Action], Position, Position) -> [Action]) -> Actions -> [Action]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\([Action]
a,Position
_,Position
_) -> [Action]
a) (Actions -> [Action]) -> Actions -> [Action]
forall a b. (a -> b) -> a -> b
$
(([Action], Position, Position) -> Bool) -> Actions -> Actions
forall a. (a -> Bool) -> [a] -> [a]
filter (\([Action]
_, Position
from, Position
to) -> Position
pos' Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
>= Position
from Bool -> Bool -> Bool
&& Position
pos' Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<= Position
to) Actions
actions
where pos' :: Position
pos' = Position -> Position
forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
pos