{-# LANGUAGE CPP #-}

------------------------------------------------------------------------------
-- |
-- Module: Xmobar.Run.Loop
-- Copyright: (c) 2022 Jose Antonio Ortega Ruiz
-- License: BSD3-style (see LICENSE)
--
-- Maintainer: jao@gnu.org
-- Stability: unstable
-- Portability: unportable
-- Created: Fri Jan 28, 2022 03:20
--
--
-- Running a thread for each defined Command in a loop
--
------------------------------------------------------------------------------

module Xmobar.Run.Loop (LoopFunction, loop) where

import Control.Concurrent (forkIO)
import Control.Exception (bracket_, bracket, handle, SomeException(..))
import Control.Concurrent.STM
import Control.Concurrent.Async (Async, async, cancel)
import Control.Monad (guard, void, unless)
import Data.Maybe (isJust)
import Data.Foldable (for_)

import Xmobar.System.Signal
import Xmobar.Config.Types
import Xmobar.Run.Runnable (Runnable)
import Xmobar.Run.Exec (start, trigger, alias)
import Xmobar.Run.Template
import Xmobar.Run.Timer (withTimer)

#ifdef DBUS
import Xmobar.System.DBus
#endif

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

type LoopFunction = TMVar SignalType -> TVar [String] -> IO ()

loop :: Config -> LoopFunction -> IO ()
loop :: Config -> LoopFunction -> IO ()
loop Config
conf LoopFunction
looper = IO () -> IO ()
forall a. IO a -> IO a
withDeferSignals (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  [[(Runnable, String, String)]]
cls <- (String -> IO [(Runnable, String, String)])
-> [String] -> IO [[(Runnable, String, String)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([Runnable] -> String -> String -> IO [(Runnable, String, String)]
parseTemplate (Config -> [Runnable]
commands Config
conf) (Config -> String
sepChar Config
conf))
                (String -> String -> [String]
splitTemplate (Config -> String
alignSep Config
conf) (Config -> String
template Config
conf))
  let confSig :: Maybe (TMVar SignalType)
confSig = SignalChan -> Maybe (TMVar SignalType)
unSignalChan (Config -> SignalChan
signal Config
conf)
  TMVar SignalType
sig <- IO (TMVar SignalType)
-> (TMVar SignalType -> IO (TMVar SignalType))
-> Maybe (TMVar SignalType)
-> IO (TMVar SignalType)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO (TMVar SignalType)
forall a. IO (TMVar a)
newEmptyTMVarIO TMVar SignalType -> IO (TMVar SignalType)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TMVar SignalType)
confSig
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe (TMVar SignalType) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (TMVar SignalType)
confSig) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ TMVar SignalType -> IO ()
setupSignalHandler TMVar SignalType
sig
  TMVar ()
refLock <- IO (TMVar ())
newRefreshLock
  (IO () -> IO ()) -> IO () -> IO ()
forall a. (IO () -> IO ()) -> IO a -> IO a
withTimer (TMVar () -> IO () -> IO ()
forall a. TMVar () -> IO a -> IO a
refreshLock TMVar ()
refLock) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    IO [[([Async ()], TVar String)]]
-> ([[([Async ()], TVar String)]] -> IO ())
-> ([[([Async ()], TVar String)]] -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (([(Runnable, String, String)] -> IO [([Async ()], TVar String)])
-> [[(Runnable, String, String)]]
-> IO [[([Async ()], TVar String)]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (((Runnable, String, String) -> IO ([Async ()], TVar String))
-> [(Runnable, String, String)] -> IO [([Async ()], TVar String)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (((Runnable, String, String) -> IO ([Async ()], TVar String))
 -> [(Runnable, String, String)] -> IO [([Async ()], TVar String)])
-> ((Runnable, String, String) -> IO ([Async ()], TVar String))
-> [(Runnable, String, String)]
-> IO [([Async ()], TVar String)]
forall a b. (a -> b) -> a -> b
$ TMVar SignalType
-> (Runnable, String, String) -> IO ([Async ()], TVar String)
startCommand TMVar SignalType
sig) [[(Runnable, String, String)]]
cls)
            [[([Async ()], TVar String)]] -> IO ()
forall a. [[([Async ()], a)]] -> IO ()
cleanupThreads
            (([[([Async ()], TVar String)]] -> IO ()) -> IO ())
-> ([[([Async ()], TVar String)]] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[[([Async ()], TVar String)]]
vars -> do
      TVar [String]
tv <- TMVar SignalType
-> TMVar () -> [[([Async ()], TVar String)]] -> IO (TVar [String])
initLoop TMVar SignalType
sig TMVar ()
refLock [[([Async ()], TVar String)]]
vars
      LoopFunction
looper TMVar SignalType
sig TVar [String]
tv

cleanupThreads :: [[([Async ()], a)]] -> IO ()
cleanupThreads :: [[([Async ()], a)]] -> IO ()
cleanupThreads [[([Async ()], a)]]
vars =
  [([Async ()], a)] -> (([Async ()], a) -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ([[([Async ()], a)]] -> [([Async ()], a)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[([Async ()], a)]]
vars) ((([Async ()], a) -> IO ()) -> IO ())
-> (([Async ()], a) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \([Async ()]
asyncs, a
_) ->
    [Async ()] -> (Async () -> IO ()) -> IO ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [Async ()]
asyncs Async () -> IO ()
forall a. Async a -> IO ()
cancel

-- | Initialises context for an event loop, returning a TVar that
-- will hold the current list of values computed by commands.
initLoop :: TMVar SignalType -> TMVar () -> [[([Async ()], TVar String)]]
         -> IO (TVar [String])
initLoop :: TMVar SignalType
-> TMVar () -> [[([Async ()], TVar String)]] -> IO (TVar [String])
initLoop TMVar SignalType
sig TMVar ()
lock [[([Async ()], TVar String)]]
vs = do
  TVar [String]
tv <- [String] -> IO (TVar [String])
forall a. a -> IO (TVar a)
newTVarIO ([] :: [String])
  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 ()
lock))
#ifdef DBUS
  runIPC sig
#endif
  TVar [String] -> IO (TVar [String])
forall (m :: * -> *) a. Monad m => a -> m a
return TVar [String]
tv
  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)

-- | 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

-- | 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
sig 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
sig SignalType
Wakeup
      TVar [String]
-> [String]
-> [[([Async ()], TVar String)]]
-> TMVar SignalType
-> TMVar ()
-> IO ()
checker TVar [String]
tvar [String]
nval [[([Async ()], TVar String)]]
vs TMVar SignalType
sig 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)