{-# LANGUAGE CPP #-}

------------------------------------------------------------------------------
-- |
-- Module: Xmobar.App.X11EventLoop
-- Copyright: (c) 2018, 2020, 2022 Jose Antonio Ortega Ruiz
-- License: BSD3-style (see LICENSE)
--
-- Maintainer: jao@gnu.org
-- Stability: unstable
-- Portability: portable
-- Created: Sat Nov 24, 2018 19:40
--
--
-- Event loop
--
------------------------------------------------------------------------------

module Xmobar.X11.Loop (x11Loop) where

import Prelude hiding (lookup)

import Control.Concurrent as Concurrent
import Control.Concurrent.STM as STM
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 = forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
MR.runReaderT X a
f XConf
xc

-- | Starts the main event loop thread
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 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Display -> String -> IO XFont
Text.initFont Display
d) (Config -> [String]
C.additionalFonts Config
conf)
  (Rectangle
r,Button
w) <- Display -> XFont -> Config -> IO (Rectangle, Button)
W.createWin Display
d XFont
fs Config
conf
  Config -> LoopFunction -> IO ()
L.loop Config
conf (XConf -> LoopFunction
startLoop (Display
-> Rectangle
-> Button
-> NonEmpty XFont
-> BitmapCache
-> Config
-> XConf
T.XConf Display
d Rectangle
r Button
w (XFont
fs forall a. a -> [a] -> NonEmpty a
:| [XFont]
fl) 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 -> Button -> TMVar SignalType -> IO ()
eventLoop (XConf -> Display
T.display XConf
xcfg) (XConf -> Button
T.window XConf
xcfg) TMVar SignalType
sig)
  XConf -> Actions -> LoopFunction
signalLoop XConf
xcfg [] TMVar SignalType
sig TVar [String]
tv

-- | Translates X11 events received by w to signals handled by signalLoop
eventLoop :: X11.Display -> X11.Window -> STM.TMVar S.SignalType -> IO ()
eventLoop :: Display -> Button -> TMVar SignalType -> IO ()
eventLoop Display
dpy Button
w TMVar SignalType
signalv =
  forall a. (XEventPtr -> IO a) -> IO a
X11.allocaXEvent forall a b. (a -> b) -> a -> b
$ \XEventPtr
e -> do
    let root :: Button
root = Display -> Button
X11.defaultRootWindow Display
dpy
        m :: Button
m = Button
X11.exposureMask forall a. Bits a => a -> a -> a
.|. Button
X11.structureNotifyMask forall a. Bits a => a -> a -> a
.|. Button
X11.buttonPressMask
    Display -> Button -> Button -> IO ()
Xrandr.xrrSelectInput Display
dpy Button
root Button
X11.rrScreenChangeNotifyMask
    Display -> Button -> Button -> IO ()
X11.selectInput Display
dpy Button
w Button
m

    forall (f :: * -> *) a b. Applicative f => f a -> f b
MR.forever 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 = forall a. STM a -> IO a
STM.atomically forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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, forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Event -> Status
X11x.ev_x Event
ev)
        Event
_ -> forall (m :: * -> *) a. Monad m => a -> m a
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 ::
  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 Button
w NonEmpty XFont
fs BitmapCache
is Config
cfg) Actions
actions TMVar SignalType
signalv TVar [String]
strs = do
    SignalType
typ <- forall a. STM a -> IO a
STM.atomically forall a b. (a -> b) -> a -> b
$ 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 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 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config -> IO ()
reposWindow
      S.Hide Int
t           -> forall {t}.
Num t =>
Int -> (t -> SignalType) -> (Display -> Button -> IO ()) -> IO ()
hiderev Int
t Int -> SignalType
S.Hide Display -> Button -> IO ()
W.hideWindow
      S.Reveal Int
t         -> forall {t}.
Num t =>
Int -> (t -> SignalType) -> (Display -> Button -> IO ()) -> IO ()
hiderev Int
t Int -> SignalType
S.Reveal (Rectangle -> Config -> Display -> Button -> IO ()
W.showWindow Rectangle
r Config
cfg)
      S.Toggle Int
t         -> Int -> IO ()
toggle Int
t
      SignalType
S.TogglePersistent -> Config -> IO ()
updateCfg forall a b. (a -> b) -> a -> b
$ Config
cfg {persistent :: Bool
C.persistent = Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Config -> Bool
C.persistent Config
cfg}
      S.SetAlpha Int
a       -> Config -> IO ()
updateCfg forall a b. (a -> b) -> a -> b
$ Config
cfg {alpha :: Int
C.alpha = Int
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 {config :: Config
T.config = 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' <- 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 -> Button -> IO ()) -> IO ()
hiderev Int
t t -> SignalType
sign Display -> Button -> IO ()
op
            | Int
t forall a. Eq a => a -> a -> Bool
== Int
0 = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
MR.unless (Config -> Bool
C.persistent Config
cfg) (Display -> Button -> IO ()
op Display
d Button
w) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loopOn
            | Bool
otherwise = do
                forall (f :: * -> *) a. Functor f => f a -> f ()
MR.void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
Concurrent.forkIO
                     forall a b. (a -> b) -> a -> b
$ Int -> IO ()
Concurrent.threadDelay (Int
tforall a. Num a => a -> a -> a
*Int
100forall a. Num a => a -> a -> a
*Int
1000) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
                       forall a. STM a -> IO a
STM.atomically (forall a. TMVar a -> a -> STM ()
STM.putTMVar TMVar SignalType
signalv forall a b. (a -> b) -> a -> b
$ t -> SignalType
sign t
0)
                IO ()
loopOn

        toggle :: Int -> IO ()
toggle Int
t = do
          Bool
ismapped <- Display -> Button -> IO Bool
W.isMapped Display
d Button
w
          let s :: SignalType
s = if Bool
ismapped then Int -> SignalType
S.Hide Int
t else Int -> SignalType
S.Reveal Int
t
          forall a. STM a -> IO a
STM.atomically (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 -> Button -> XFont -> Config -> IO Rectangle
W.repositionWin Display
d Button
w (forall a. NonEmpty a -> a
NE.head NonEmpty XFont
fs) Config
rcfg
          XConf -> Actions -> LoopFunction
signalLoop (Display
-> Rectangle
-> Button
-> NonEmpty XFont
-> BitmapCache
-> Config
-> XConf
T.XConf Display
d Rectangle
r' Button
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 <- forall a. TVar a -> IO a
STM.readTVarIO TVar [String]
v
  let String
l:String
c:String
r:[String]
_ = [String]
s forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat String
""
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (Config -> String -> [Segment]
CT.parseString Config
conf) [String
l, String
c, String
r]

updateIconCache :: T.XConf -> [[C.Segment]] -> IO T.XConf
updateIconCache :: XConf -> [[Segment]] -> IO XConf
updateIconCache xc :: XConf
xc@(T.XConf Display
d Rectangle
_ Button
w NonEmpty XFont
_ BitmapCache
c Config
cfg) [[Segment]]
segs = do
  let paths :: [String]
paths = [String
p | (C.Icon String
p, TextRenderInfo
_, Int
_, Maybe [Action]
_) <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Segment]]
segs]
  BitmapCache
c' <- Display
-> Button -> BitmapCache -> String -> [String] -> IO BitmapCache
Bitmap.updateCache Display
d Button
w BitmapCache
c (Config -> String
C.iconRoot Config
cfg) [String]
paths
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ XConf
xc {iconCache :: BitmapCache
T.iconCache = BitmapCache
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
      forall (m :: * -> *) a. Monad m => a -> m a
return (if Int
n forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length [Rectangle]
srs
              then (Config
cfg {position :: XPosition
C.position = Int -> XPosition -> XPosition
C.OnScreen Int
1 XPosition
o})
              else (Config
cfg {position :: XPosition
C.position = Int -> XPosition -> XPosition
C.OnScreen (Int
nforall a. Num a => a -> a -> a
+Int
1) XPosition
o}))
    XPosition
o -> forall (m :: * -> *) a. Monad m => a -> m a
return (Config
cfg {position :: XPosition
C.position = Int -> XPosition -> XPosition
C.OnScreen Int
1 XPosition
o})

runActions :: D.Actions -> A.Button -> X11.Position -> IO ()
runActions :: Actions -> Button -> Position -> IO ()
runActions Actions
actions Button
button Position
pos =
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Action -> IO ()
A.runAction forall a b. (a -> b) -> a -> b
$
   forall a. (a -> Bool) -> [a] -> [a]
filter (\(A.Spawn [Button]
b String
_) -> Button
button forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Button]
b) forall a b. (a -> b) -> a -> b
$
   forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\([Action]
a,Position
_,Position
_) -> [Action]
a) forall a b. (a -> b) -> a -> b
$
   forall a. (a -> Bool) -> [a] -> [a]
filter (\([Action]
_, Position
from, Position
to) -> Position
pos' forall a. Ord a => a -> a -> Bool
>= Position
from Bool -> Bool -> Bool
&& Position
pos' forall a. Ord a => a -> a -> Bool
<= Position
to) Actions
actions
  where pos' :: Position
pos' = forall a b. (Integral a, Num b) => a -> b
fromIntegral Position
pos