{-# 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 :: forall a. 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 :: forall a. TMVar () -> STM a -> STM a
refreshLockT TMVar ()
var STM a
action = do
    TMVar () -> STM ()
forall a. TMVar a -> STM a
takeTMVar TMVar ()
var
    r <- STM a
action
    putTMVar var ()
    return 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
  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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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 = SignalChan -> Maybe (TMVar SignalType)
unSignalChan (Config -> SignalChan
signal Config
conf)
  sig <- maybe newEmptyTMVarIO pure confSig
  unless (isJust confSig) $ setupSignalHandler sig
  refLock <- newRefreshLock
  withTimer (refreshLock refLock) $
    bracket (mapM (mapM $ startCommand sig) cls)
            cleanupThreads
            $ \[[([Async ()], TVar String)]]
vars -> do
      tv <- TMVar SignalType
-> TMVar () -> [[([Async ()], TVar String)]] -> IO (TVar [String])
initLoop TMVar SignalType
sig TMVar ()
refLock [[([Async ()], TVar String)]]
vars
      looper sig tv

cleanupThreads :: [[([Async ()], a)]] -> IO ()
cleanupThreads :: forall a. [[([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
  tv <- [String] -> IO (TVar [String])
forall a. a -> IO (TVar a)
newTVarIO ([] :: [String])
  _ <- forkIO (handle (handler "checker") (checker tv [] vs sig lock))
#ifdef DBUS
  runIPC sig
#endif
  return 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 var <- String -> IO (TVar String)
forall a. a -> IO (TVar a)
newTVarIO String
is
                           atomically $ writeTVar var (s ++ ss)
                           return ([], var)
    | Bool
otherwise = do var <- String -> IO (TVar String)
forall a. a -> IO (TVar a)
newTVarIO String
is
                     let 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)
                     a1 <- async $ start com cb
                     a2 <- async $ trigger com $ maybe (return ())
                                                 (atomically . putTMVar sig)
                     return ([a1, a2], 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
      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
              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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [([Async ()], TVar String)] -> STM String
forall {a} {a}. [(a, TVar [a])] -> STM [a]
concatV [[([Async ()], TVar String)]]
vs
              guard (nv /= ov)
              writeTVar tvar nv
              return nv
      atomically $ putTMVar sig Wakeup
      checker tvar nval vs sig pauser
    where
      concatV :: [(a, TVar [a])] -> STM [a]
concatV = ([[a]] -> [a]) -> STM [[a]] -> STM [a]
forall a b. (a -> b) -> STM a -> STM b
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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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)