{-# LANGUAGE CPP #-}

------------------------------------------------------------------------------
-- |
-- Module: Xmobar.X11.EventLoop
-- Copyright: (c) 2018, 2020 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.App.EventLoop
    ( startLoop
    , startCommand
    , newRefreshLock
    , refreshLock
    ) 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.Monad.Reader
import Control.Concurrent
import Control.Concurrent.Async (Async, async)
import Control.Concurrent.STM
import Control.Exception (bracket_, handle, SomeException(..))
import Data.Bits
import Data.Map hiding (foldr, map, filter)
import Data.Maybe (fromJust, isJust)
import qualified Data.List.NonEmpty as NE

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.System.Utils (safeIndex)

#ifndef THREADED_RUNTIME
import Xmobar.X11.Events(nextEvent')
#endif

#ifdef XFT
import Graphics.X11.Xft
#endif

#ifdef DBUS
import Xmobar.System.DBus
#endif

runX :: XConf -> X () -> IO ()
runX :: XConf -> X () -> IO ()
runX XConf
xc X ()
f = X () -> XConf -> IO ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT X ()
f XConf
xc

newRefreshLock :: IO (TMVar ())
newRefreshLock :: IO (TMVar ())
newRefreshLock = () -> IO (TMVar ())
forall a. a -> IO (TMVar a)
newTMVarIO ()

refreshLock :: TMVar () -> IO a -> IO a
refreshLock :: TMVar () -> IO a -> IO a
refreshLock TMVar ()
var = IO () -> IO () -> IO a -> IO a
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ IO ()
lock IO ()
unlock
    where
        lock :: IO ()
lock = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar TMVar ()
var
        unlock :: IO ()
unlock = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
var ()

refreshLockT :: TMVar () -> STM a -> STM a
refreshLockT :: TMVar () -> STM a -> STM a
refreshLockT TMVar ()
var STM a
action = do
    TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar TMVar ()
var
    a
r <- STM a
action
    TMVar () -> () -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar ()
var ()
    a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return a
r

-- | Starts the main event loop and threads
startLoop :: XConf
          -> TMVar SignalType
          -> TMVar ()
          -> [[([Async ()], TVar String)]]
          -> IO ()
startLoop :: XConf
-> TMVar SignalType
-> TMVar ()
-> [[([Async ()], TVar String)]]
-> IO ()
startLoop xcfg :: XConf
xcfg@(XConf Display
_ Rectangle
_ Window
w NonEmpty XFont
_ NonEmpty Int
_ Map String Bitmap
_ Config
_) TMVar SignalType
sig TMVar ()
pauser [[([Async ()], TVar String)]]
vs = do
#ifdef XFT
    xftInitFtLibrary
#endif
    TVar [String]
tv <- [String] -> IO (TVar [String])
forall a. a -> IO (TVar a)
newTVarIO []
    ThreadId
_ <- IO () -> IO ThreadId
forkIO ((SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (String -> SomeException -> IO ()
handler String
"checker") (TVar [String]
-> [String]
-> [[([Async ()], TVar String)]]
-> TMVar SignalType
-> TMVar ()
-> IO ()
checker TVar [String]
tv [] [[([Async ()], TVar String)]]
vs TMVar SignalType
sig TMVar ()
pauser))
#ifdef THREADED_RUNTIME
    _ <- forkOS (handle (handler "eventer") (eventer sig))
#else
    ThreadId
_ <- IO () -> IO ThreadId
forkIO ((SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (String -> SomeException -> IO ()
handler String
"eventer") (TMVar SignalType -> IO ()
forall a. TMVar SignalType -> IO a
eventer TMVar SignalType
sig))
#endif
#ifdef DBUS
    runIPC sig
#endif
    TVar [String]
-> XConf
-> [([Action], Position, Position)]
-> TMVar SignalType
-> IO ()
eventLoop TVar [String]
tv XConf
xcfg [] TMVar SignalType
sig
  where
    handler :: String -> SomeException -> IO ()
handler String
thing (SomeException e
e) =
      IO () -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> IO ()
putStrLn (String
"Thread " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
thing String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" failed: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ e -> String
forall a. Show a => a -> String
show e
e)
    -- Reacts on events from X
    eventer :: TMVar SignalType -> IO a
eventer TMVar SignalType
signal =
      (XEventPtr -> IO a) -> IO a
forall a. (XEventPtr -> IO a) -> IO a
allocaXEvent ((XEventPtr -> IO a) -> IO a) -> (XEventPtr -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \XEventPtr
e -> do
        Display
dpy <- String -> IO Display
openDisplay String
""
        Display -> Window -> Window -> IO ()
xrrSelectInput Display
dpy (Display -> Window
defaultRootWindow Display
dpy) Window
rrScreenChangeNotifyMask
        Display -> Window -> Window -> IO ()
selectInput Display
dpy Window
w (Window
exposureMask Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
structureNotifyMask Window -> Window -> Window
forall a. Bits a => a -> a -> a
.|. Window
buttonPressMask)

        IO () -> IO a
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO a) -> IO () -> IO a
forall a b. (a -> b) -> a -> b
$ do
#ifdef THREADED_RUNTIME
          nextEvent dpy e
#else
          Display -> XEventPtr -> IO ()
nextEvent' Display
dpy XEventPtr
e
#endif
          Event
ev <- XEventPtr -> IO Event
getEvent XEventPtr
e
          case Event
ev of
            ConfigureEvent {} -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar SignalType
signal SignalType
Reposition
            ExposeEvent {} -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar SignalType
signal SignalType
Wakeup
            RRScreenChangeNotifyEvent {} -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar SignalType
signal SignalType
Reposition
            ButtonEvent {} -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$
                   TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar SignalType
signal (Button -> Position -> SignalType
Action (Event -> Button
ev_button Event
ev) (CInt -> Position
forall a b. (Integral a, Num b) => a -> b
fi (CInt -> Position) -> CInt -> Position
forall a b. (a -> b) -> a -> b
$ Event -> CInt
ev_x Event
ev))
            Event
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Send signal to eventLoop every time a var is updated
checker :: TVar [String]
           -> [String]
           -> [[([Async ()], TVar String)]]
           -> TMVar SignalType
           -> TMVar ()
           -> IO ()
checker :: TVar [String]
-> [String]
-> [[([Async ()], TVar String)]]
-> TMVar SignalType
-> TMVar ()
-> IO ()
checker TVar [String]
tvar [String]
ov [[([Async ()], TVar String)]]
vs TMVar SignalType
signal TMVar ()
pauser = do
      [String]
nval <- STM [String] -> IO [String]
forall a. STM a -> IO a
atomically (STM [String] -> IO [String]) -> STM [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ TMVar () -> STM [String] -> STM [String]
forall a. TMVar () -> STM a -> STM a
refreshLockT TMVar ()
pauser (STM [String] -> STM [String]) -> STM [String] -> STM [String]
forall a b. (a -> b) -> a -> b
$ do
              [String]
nv <- ([([Async ()], TVar String)] -> STM String)
-> [[([Async ()], TVar String)]] -> STM [String]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM [([Async ()], TVar String)] -> STM String
forall a a. [(a, TVar [a])] -> STM [a]
concatV [[([Async ()], TVar String)]]
vs
              Bool -> STM ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard ([String]
nv [String] -> [String] -> Bool
forall a. Eq a => a -> a -> Bool
/= [String]
ov)
              TVar [String] -> [String] -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar [String]
tvar [String]
nv
              [String] -> STM [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String]
nv
      STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar SignalType
signal SignalType
Wakeup
      TVar [String]
-> [String]
-> [[([Async ()], TVar String)]]
-> TMVar SignalType
-> TMVar ()
-> IO ()
checker TVar [String]
tvar [String]
nval [[([Async ()], TVar String)]]
vs TMVar SignalType
signal TMVar ()
pauser
    where
      concatV :: [(a, TVar [a])] -> STM [a]
concatV = ([[a]] -> [a]) -> STM [[a]] -> STM [a]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[a]] -> [a]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (STM [[a]] -> STM [a])
-> ([(a, TVar [a])] -> STM [[a]]) -> [(a, TVar [a])] -> STM [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a, TVar [a]) -> STM [a]) -> [(a, TVar [a])] -> STM [[a]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (TVar [a] -> STM [a]
forall a. TVar a -> STM a
readTVar (TVar [a] -> STM [a])
-> ((a, TVar [a]) -> TVar [a]) -> (a, TVar [a]) -> STM [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, TVar [a]) -> TVar [a]
forall a b. (a, b) -> b
snd)


-- | Continuously wait for a signal from a thread or a interrupt handler
eventLoop :: TVar [String]
             -> XConf
             -> [([Action], Position, Position)]
             -> TMVar SignalType
             -> IO ()
eventLoop :: TVar [String]
-> XConf
-> [([Action], Position, Position)]
-> TMVar SignalType
-> IO ()
eventLoop TVar [String]
tv xc :: XConf
xc@(XConf Display
d Rectangle
r Window
w NonEmpty XFont
fs NonEmpty Int
vos Map String Bitmap
is Config
cfg) [([Action], Position, Position)]
as TMVar SignalType
signal = do
      SignalType
typ <- STM SignalType -> IO SignalType
forall a. STM a -> IO a
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
takeTMVar TMVar SignalType
signal
      case SignalType
typ of
         SignalType
Wakeup -> do
            [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
str <- Config
-> TVar [String]
-> IO [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
updateString Config
cfg TVar [String]
tv
            XConf
xc' <- Display
-> Window
-> Map String Bitmap
-> String
-> [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
-> IO (Map String Bitmap)
updateCache Display
d Window
w Map String Bitmap
is (Config -> String
iconRoot Config
cfg) [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
str IO (Map String Bitmap)
-> (Map String Bitmap -> IO XConf) -> IO XConf
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
                     \Map String Bitmap
c -> XConf -> IO XConf
forall (m :: * -> *) a. Monad m => a -> m a
return XConf
xc { iconS :: Map String Bitmap
iconS = Map String Bitmap
c }
            [([Action], Position, Position)]
as' <- XConf
-> Rectangle
-> [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
-> IO [([Action], Position, Position)]
updateActions XConf
xc Rectangle
r [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
str
            XConf -> X () -> IO ()
runX XConf
xc' (X () -> IO ()) -> X () -> IO ()
forall a b. (a -> b) -> a -> b
$ Rectangle
-> [[(Widget, TextRenderInfo, Int, Maybe [Action])]] -> X ()
drawInWin Rectangle
r [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
str
            TVar [String]
-> XConf
-> [([Action], Position, Position)]
-> TMVar SignalType
-> IO ()
eventLoop TVar [String]
tv XConf
xc' [([Action], Position, Position)]
as' TMVar SignalType
signal

         SignalType
Reposition ->
            Config -> IO ()
reposWindow Config
cfg

         SignalType
ChangeScreen -> do
            Config
ncfg <- Config -> IO Config
updateConfigPosition Config
cfg
            Config -> IO ()
reposWindow Config
ncfg

         Hide   Int
t -> Int -> IO ()
hide   (Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
100Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1000)
         Reveal Int
t -> Int -> IO ()
reveal (Int
tInt -> Int -> Int
forall a. Num a => a -> a -> a
*Int
100Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1000)
         Toggle Int
t -> Int -> IO ()
toggle Int
t

         SignalType
TogglePersistent -> TVar [String]
-> XConf
-> [([Action], Position, Position)]
-> TMVar SignalType
-> IO ()
eventLoop
            TVar [String]
tv XConf
xc { config :: Config
config = Config
cfg { persistent :: Bool
persistent = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Config -> Bool
persistent Config
cfg } } [([Action], Position, Position)]
as TMVar SignalType
signal

         Action Button
but Position
x -> Button -> Position -> IO ()
action Button
but Position
x

    where
        isPersistent :: Bool
isPersistent = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Config -> Bool
persistent Config
cfg

        hide :: Int -> IO ()
hide Int
t
            | Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 =
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isPersistent (Display -> Window -> IO ()
hideWindow Display
d Window
w) IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> TVar [String]
-> XConf
-> [([Action], Position, Position)]
-> TMVar SignalType
-> IO ()
eventLoop TVar [String]
tv XConf
xc [([Action], Position, Position)]
as TMVar SignalType
signal
            | Bool
otherwise = do
                IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO
                     (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
t IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> STM () -> IO ()
forall a. STM a -> IO a
atomically (TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar SignalType
signal (SignalType -> STM ()) -> SignalType -> STM ()
forall a b. (a -> b) -> a -> b
$ Int -> SignalType
Hide Int
0)
                TVar [String]
-> XConf
-> [([Action], Position, Position)]
-> TMVar SignalType
-> IO ()
eventLoop TVar [String]
tv XConf
xc [([Action], Position, Position)]
as TMVar SignalType
signal

        reveal :: Int -> IO ()
reveal Int
t
            | Int
t Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = do
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isPersistent (Rectangle -> Config -> Display -> Window -> IO ()
showWindow Rectangle
r Config
cfg Display
d Window
w)
                TVar [String]
-> XConf
-> [([Action], Position, Position)]
-> TMVar SignalType
-> IO ()
eventLoop TVar [String]
tv XConf
xc [([Action], Position, Position)]
as TMVar SignalType
signal
            | Bool
otherwise = do
                IO ThreadId -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO ThreadId -> IO ()) -> IO ThreadId -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO
                     (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
t IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> STM () -> IO ()
forall a. STM a -> IO a
atomically (TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar SignalType
signal (SignalType -> STM ()) -> SignalType -> STM ()
forall a b. (a -> b) -> a -> b
$ Int -> SignalType
Reveal Int
0)
                TVar [String]
-> XConf
-> [([Action], Position, Position)]
-> TMVar SignalType
-> IO ()
eventLoop TVar [String]
tv XConf
xc [([Action], Position, Position)]
as TMVar SignalType
signal

        toggle :: Int -> IO ()
toggle Int
t = do
            Bool
ismapped <- Display -> Window -> IO Bool
isMapped Display
d Window
w
            STM () -> IO ()
forall a. STM a -> IO a
atomically (TMVar SignalType -> SignalType -> STM ()
forall a. TMVar a -> a -> STM ()
putTMVar TMVar SignalType
signal (SignalType -> STM ()) -> SignalType -> STM ()
forall a b. (a -> b) -> a -> b
$ if Bool
ismapped then Int -> SignalType
Hide Int
t else Int -> SignalType
Reveal Int
t)
            TVar [String]
-> XConf
-> [([Action], Position, Position)]
-> TMVar SignalType
-> IO ()
eventLoop TVar [String]
tv XConf
xc [([Action], Position, Position)]
as TMVar SignalType
signal

        reposWindow :: Config -> IO ()
reposWindow Config
rcfg = do
          Rectangle
r' <- Display -> Window -> XFont -> Config -> IO Rectangle
repositionWin Display
d Window
w (NonEmpty XFont -> XFont
forall a. NonEmpty a -> a
NE.head NonEmpty XFont
fs) Config
rcfg
          TVar [String]
-> XConf
-> [([Action], Position, Position)]
-> TMVar SignalType
-> IO ()
eventLoop TVar [String]
tv (Display
-> Rectangle
-> Window
-> NonEmpty XFont
-> NonEmpty Int
-> Map String Bitmap
-> Config
-> XConf
XConf Display
d Rectangle
r' Window
w NonEmpty XFont
fs NonEmpty Int
vos Map String Bitmap
is Config
rcfg) [([Action], Position, Position)]
as TMVar SignalType
signal

        updateConfigPosition :: Config -> IO Config
updateConfigPosition Config
ocfg =
          case Config -> XPosition
position Config
ocfg of
            OnScreen Int
n XPosition
o -> do
              [Rectangle]
srs <- Display -> IO [Rectangle]
getScreenInfo Display
d
              Config -> IO Config
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 (t :: * -> *) a. Foldable t => t a -> Int
length [Rectangle]
srs
                       then
                        (Config
ocfg {position :: XPosition
position = Int -> XPosition -> XPosition
OnScreen Int
1 XPosition
o})
                       else
                        (Config
ocfg {position :: XPosition
position = Int -> XPosition -> XPosition
OnScreen (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1) XPosition
o}))
            XPosition
o -> Config -> IO Config
forall (m :: * -> *) a. Monad m => a -> m a
return (Config
ocfg {position :: XPosition
position = Int -> XPosition -> XPosition
OnScreen Int
1 XPosition
o})

        action :: Button -> Position -> IO ()
action Button
button Position
x = do
          (Action -> IO ()) -> [Action] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Action -> IO ()
runAction ([Action] -> IO ()) -> [Action] -> IO ()
forall a b. (a -> b) -> a -> b
$
            (Action -> Bool) -> [Action] -> [Action]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Spawn [Button]
b String
_) -> Button
button Button -> [Button] -> 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])
-> [([Action], Position, Position)] -> [Action]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\([Action]
a,Position
_,Position
_) -> [Action]
a) ([([Action], Position, Position)] -> [Action])
-> [([Action], Position, Position)] -> [Action]
forall a b. (a -> b) -> a -> b
$
            (([Action], Position, Position) -> Bool)
-> [([Action], Position, Position)]
-> [([Action], Position, Position)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\([Action]
_, Position
from, Position
to) -> Position
x Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
>= Position
from Bool -> Bool -> Bool
&& Position
x Position -> Position -> Bool
forall a. Ord a => a -> a -> Bool
<= Position
to) [([Action], Position, Position)]
as
          TVar [String]
-> XConf
-> [([Action], Position, Position)]
-> TMVar SignalType
-> IO ()
eventLoop TVar [String]
tv XConf
xc [([Action], Position, Position)]
as TMVar SignalType
signal

-- $command

-- | Runs a command as an independent thread and returns its Async handles
-- and the TVar the command will be writing to.
startCommand :: TMVar SignalType
             -> (Runnable,String,String)
             -> IO ([Async ()], TVar String)
startCommand :: TMVar SignalType
-> (Runnable, String, String) -> IO ([Async ()], TVar String)
startCommand TMVar SignalType
sig (Runnable
com,String
s,String
ss)
    | Runnable -> String
forall e. Exec e => e -> String
alias Runnable
com String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"" = do TVar String
var <- String -> IO (TVar String)
forall a. a -> IO (TVar a)
newTVarIO String
is
                           STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar String -> String -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar String
var (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ss)
                           ([Async ()], TVar String) -> IO ([Async ()], TVar String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([], TVar String
var)
    | Bool
otherwise = do TVar String
var <- String -> IO (TVar String)
forall a. a -> IO (TVar a)
newTVarIO String
is
                     let cb :: String -> IO ()
cb String
str = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar String -> String -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar String
var (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ss)
                     Async ()
a1 <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Runnable -> (String -> IO ()) -> IO ()
forall e. Exec e => e -> (String -> IO ()) -> IO ()
start Runnable
com String -> IO ()
cb
                     Async ()
a2 <- IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (IO () -> IO (Async ())) -> IO () -> IO (Async ())
forall a b. (a -> b) -> a -> b
$ Runnable -> (Maybe SignalType -> IO ()) -> IO ()
forall e. Exec e => e -> (Maybe SignalType -> IO ()) -> IO ()
trigger Runnable
com ((Maybe SignalType -> IO ()) -> IO ())
-> (Maybe SignalType -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ IO () -> (SignalType -> IO ()) -> Maybe SignalType -> IO ()
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (() -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
                                                 (STM () -> IO ()
forall a. STM a -> IO a
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 ()
putTMVar TMVar SignalType
sig)
                     ([Async ()], TVar String) -> IO ([Async ()], TVar String)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Async ()
a1, Async ()
a2], TVar String
var)
    where is :: String
is = String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"Updating..." String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
ss

updateString :: Config -> TVar [String]
                -> IO [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
updateString :: Config
-> TVar [String]
-> IO [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
updateString Config
conf TVar [String]
v = do
  [String]
s <- TVar [String] -> IO [String]
forall a. TVar a -> IO a
readTVarIO TVar [String]
v
  let String
l:String
c:String
r:[String]
_ = [String]
s [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ String -> [String]
forall a. a -> [a]
repeat String
""
  IO [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
-> IO [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
 -> IO [[(Widget, TextRenderInfo, Int, Maybe [Action])]])
-> IO [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
-> IO [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
forall a b. (a -> b) -> a -> b
$ (String -> IO [(Widget, TextRenderInfo, Int, Maybe [Action])])
-> [String] -> IO [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Config
-> String -> IO [(Widget, TextRenderInfo, Int, Maybe [Action])]
parseString Config
conf) [String
l, String
c, String
r]

updateActions :: XConf -> Rectangle -> [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
                 -> IO [([Action], Position, Position)]
updateActions :: XConf
-> Rectangle
-> [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
-> IO [([Action], Position, Position)]
updateActions XConf
conf (Rectangle Position
_ Position
_ Button
wid Button
_) ~[[(Widget, TextRenderInfo, Int, Maybe [Action])]
left,[(Widget, TextRenderInfo, Int, Maybe [Action])]
center,[(Widget, TextRenderInfo, Int, Maybe [Action])]
right] = do
  let (Display
d,NonEmpty XFont
fs) = (XConf -> Display
display (XConf -> Display)
-> (XConf -> NonEmpty XFont) -> XConf -> (Display, NonEmpty XFont)
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& XConf -> NonEmpty XFont
fontListS) XConf
conf
      strLn :: [(Widget, TextRenderInfo, Int, Maybe [Action])] -> IO [(Maybe [Action], Position, Position)]
      strLn :: [(Widget, TextRenderInfo, Int, Maybe [Action])]
-> IO [(Maybe [Action], Position, Position)]
strLn  = IO [(Maybe [Action], Position, Position)]
-> IO [(Maybe [Action], Position, Position)]
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [(Maybe [Action], Position, Position)]
 -> IO [(Maybe [Action], Position, Position)])
-> ([(Widget, TextRenderInfo, Int, Maybe [Action])]
    -> IO [(Maybe [Action], Position, Position)])
-> [(Widget, TextRenderInfo, Int, Maybe [Action])]
-> IO [(Maybe [Action], Position, Position)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Widget, TextRenderInfo, Int, Maybe [Action])
 -> IO (Maybe [Action], Position, Position))
-> [(Widget, TextRenderInfo, Int, Maybe [Action])]
-> IO [(Maybe [Action], Position, Position)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Widget, TextRenderInfo, Int, Maybe [Action])
-> IO (Maybe [Action], Position, Position)
forall b c b a.
(Num b, Num c) =>
(Widget, b, Int, a) -> IO (a, b, c)
getCoords
      iconW :: String -> Button
iconW String
i = Button -> (Bitmap -> Button) -> Maybe Bitmap -> Button
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Button
0 Bitmap -> Button
Bitmap.width (String -> Map String Bitmap -> Maybe Bitmap
forall k a. Ord k => k -> Map k a -> Maybe a
lookup String
i (Map String Bitmap -> Maybe Bitmap)
-> Map String Bitmap -> Maybe Bitmap
forall a b. (a -> b) -> a -> b
$ XConf -> Map String Bitmap
iconS XConf
conf)
      getCoords :: (Widget, b, Int, a) -> IO (a, b, c)
getCoords (Text String
s,b
_,Int
i,a
a) = Display -> XFont -> String -> IO Int
textWidth Display
d (NonEmpty XFont -> Int -> XFont
forall a. NonEmpty a -> Int -> a
safeIndex NonEmpty XFont
fs Int
i) String
s IO Int -> (Int -> IO (a, b, c)) -> IO (a, b, c)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
tw -> (a, b, c) -> IO (a, b, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
0, Int -> c
forall a b. (Integral a, Num b) => a -> b
fi Int
tw)
      getCoords (Icon String
s,b
_,Int
_,a
a) = (a, b, c) -> IO (a, b, c)
forall (m :: * -> *) a. Monad m => a -> m a
return (a
a, b
0, Button -> c
forall a b. (Integral a, Num b) => a -> b
fi (Button -> c) -> Button -> c
forall a b. (a -> b) -> a -> b
$ String -> Button
iconW String
s)
      partCoord :: c -> [(Maybe a, b, c)] -> [(a, c, c)]
partCoord c
off [(Maybe a, b, c)]
xs = ((Maybe a, c, c) -> (a, c, c)) -> [(Maybe a, c, c)] -> [(a, c, c)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Maybe a
a, c
x, c
x') -> (Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust Maybe a
a, c
x, c
x')) ([(Maybe a, c, c)] -> [(a, c, c)])
-> [(Maybe a, c, c)] -> [(a, c, c)]
forall a b. (a -> b) -> a -> b
$
                         ((Maybe a, c, c) -> Bool) -> [(Maybe a, c, c)] -> [(Maybe a, c, c)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Maybe a
a, c
_,c
_) -> Maybe a -> Bool
forall a. Maybe a -> Bool
isJust Maybe a
a) ([(Maybe a, c, c)] -> [(Maybe a, c, c)])
-> [(Maybe a, c, c)] -> [(Maybe a, c, c)]
forall a b. (a -> b) -> a -> b
$
                         ((Maybe a, c, c) -> (Maybe a, b, c) -> (Maybe a, c, c))
-> (Maybe a, c, c) -> [(Maybe a, b, c)] -> [(Maybe a, c, c)]
forall b a. (b -> a -> b) -> b -> [a] -> [b]
scanl (\(Maybe a
_,c
_,c
x') (Maybe a
a,b
_,c
w') -> (Maybe a
a, c
x', c
x' c -> c -> c
forall a. Num a => a -> a -> a
+ c
w'))
                               (Maybe a
forall a. Maybe a
Nothing, c
0, c
off)
                               [(Maybe a, b, c)]
xs
      totSLen :: [(a, b, Position)] -> Position
totSLen = ((a, b, Position) -> Position -> Position)
-> Position -> [(a, b, Position)] -> Position
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(a
_,b
_,Position
len) -> Position -> Position -> Position
forall a. Num a => a -> a -> a
(+) Position
len) Position
0
      remWidth :: [(a, b, Position)] -> Position
remWidth [(a, b, Position)]
xs = Button -> Position
forall a b. (Integral a, Num b) => a -> b
fi Button
wid Position -> Position -> Position
forall a. Num a => a -> a -> a
- [(a, b, Position)] -> Position
forall a b. [(a, b, Position)] -> Position
totSLen [(a, b, Position)]
xs
      offs :: Position
offs = Position
1
      offset :: Align -> [(a, b, Position)] -> Position
offset Align
a [(a, b, Position)]
xs = case Align
a of
                     Align
C -> ([(a, b, Position)] -> Position
forall a b. [(a, b, Position)] -> Position
remWidth [(a, b, Position)]
xs Position -> Position -> Position
forall a. Num a => a -> a -> a
+ Position
offs) Position -> Position -> Position
forall a. Integral a => a -> a -> a
`div` Position
2
                     Align
R -> [(a, b, Position)] -> Position
forall a b. [(a, b, Position)] -> Position
remWidth [(a, b, Position)]
xs
                     Align
L -> Position
offs
  ([[([Action], Position, Position)]]
 -> [([Action], Position, Position)])
-> IO [[([Action], Position, Position)]]
-> IO [([Action], Position, Position)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[([Action], Position, Position)]]
-> [([Action], Position, Position)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (IO [[([Action], Position, Position)]]
 -> IO [([Action], Position, Position)])
-> IO [[([Action], Position, Position)]]
-> IO [([Action], Position, Position)]
forall a b. (a -> b) -> a -> b
$ ((Align, [(Widget, TextRenderInfo, Int, Maybe [Action])])
 -> IO [([Action], Position, Position)])
-> [(Align, [(Widget, TextRenderInfo, Int, Maybe [Action])])]
-> IO [[([Action], Position, Position)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\(Align
a,[(Widget, TextRenderInfo, Int, Maybe [Action])]
xs) ->
                       (\[(Maybe [Action], Position, Position)]
xs' -> Position
-> [(Maybe [Action], Position, Position)]
-> [([Action], Position, Position)]
forall c a b. Num c => c -> [(Maybe a, b, c)] -> [(a, c, c)]
partCoord (Align -> [(Maybe [Action], Position, Position)] -> Position
forall a b. Align -> [(a, b, Position)] -> Position
offset Align
a [(Maybe [Action], Position, Position)]
xs') [(Maybe [Action], Position, Position)]
xs') ([(Maybe [Action], Position, Position)]
 -> [([Action], Position, Position)])
-> IO [(Maybe [Action], Position, Position)]
-> IO [([Action], Position, Position)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Widget, TextRenderInfo, Int, Maybe [Action])]
-> IO [(Maybe [Action], Position, Position)]
strLn [(Widget, TextRenderInfo, Int, Maybe [Action])]
xs) ([(Align, [(Widget, TextRenderInfo, Int, Maybe [Action])])]
 -> IO [[([Action], Position, Position)]])
-> [(Align, [(Widget, TextRenderInfo, Int, Maybe [Action])])]
-> IO [[([Action], Position, Position)]]
forall a b. (a -> b) -> a -> b
$
                     [Align]
-> [[(Widget, TextRenderInfo, Int, Maybe [Action])]]
-> [(Align, [(Widget, TextRenderInfo, Int, Maybe [Action])])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Align
L,Align
C,Align
R] [[(Widget, TextRenderInfo, Int, Maybe [Action])]
left,[(Widget, TextRenderInfo, Int, Maybe [Action])]
center,[(Widget, TextRenderInfo, Int, Maybe [Action])]
right]