xmonad-config/lib/Xmobar/Plugins/Common.hs

module Xmobar.Plugins.Common
  ( colorText
  , startListener
  , procSignalMatch
  , na
  , fromSingletonVariant
  , withNestedDBusClientConnection
  , withDBusClientConnection
  , Callback
  , Colors (..)
  , displayMaybe
  , displayMaybe'
  , xmobarFGColor
  , PluginEnv (..)
  , PluginIO
  , pluginDisplay
  )
where

import DBus
import DBus.Client
import Data.Internal.DBus
import Data.Internal.XIO
import RIO
import qualified RIO.Text as T
import XMonad.Hooks.DynamicLog (xmobarColor)

data PluginEnv s c = PluginEnv
  { plugClient :: !(NamedConnection c)
  , plugState :: !(MVar s)
  , plugDisplay :: !(Callback -> PluginIO s c ())
  , plugCallback :: !Callback
  , plugEnv :: !SimpleApp
  }

pluginDisplay :: PluginIO s c ()
pluginDisplay = do
  cb <- asks plugCallback
  dpy <- asks plugDisplay
  dpy cb

type PluginIO s c = RIO (PluginEnv s c)

instance HasClient (PluginEnv s) where
  clientL = lens plugClient (\x y -> x {plugClient = y})

instance HasLogFunc (PluginEnv s c) where
  logFuncL = lens plugEnv (\x y -> x {plugEnv = y}) . logFuncL

-- use string here since all the callbacks in xmobar use strings :(
type Callback = String -> IO ()

data Colors = Colors
  { colorsOn :: T.Text
  , colorsOff :: T.Text
  }
  deriving (Eq, Show, Read)

startListener
  :: ( HasClient env
     , MonadReader (env c) m
     , MonadUnliftIO m
     , SafeClient c
     , IsVariant a
     )
  => MatchRule
  -> m [Variant]
  -> ([Variant] -> SignalMatch a)
  -> (a -> m T.Text)
  -> Callback
  -> m ()
startListener rule getProp fromSignal toColor cb = do
  reply <- getProp
  displayMaybe cb toColor $ fromSingletonVariant reply
  void $ addMatchCallback rule (procMatch . fromSignal)
  where
    procMatch = procSignalMatch cb toColor

procSignalMatch
  :: MonadUnliftIO m => Callback -> (a -> m T.Text) -> SignalMatch a -> m ()
procSignalMatch cb f = withSignalMatch (displayMaybe cb f)

colorText :: Colors -> Bool -> T.Text -> T.Text
colorText Colors {colorsOn = c} True = xmobarFGColor c
colorText Colors {colorsOff = c} False = xmobarFGColor c

xmobarFGColor :: T.Text -> T.Text -> T.Text
xmobarFGColor c = T.pack . xmobarColor (T.unpack c) "" . T.unpack

na :: T.Text
na = "N/A"

displayMaybe :: MonadUnliftIO m => Callback -> (a -> m T.Text) -> Maybe a -> m ()
displayMaybe cb f = (liftIO . cb . T.unpack) <=< maybe (return na) f

displayMaybe' :: MonadUnliftIO m => Callback -> (a -> m ()) -> Maybe a -> m ()
displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)

withDBusClientConnection
  :: (MonadUnliftIO m, SafeClient c)
  => Callback
  -> Maybe BusName
  -> Maybe FilePath
  -> (NamedConnection c -> RIO SimpleApp ())
  -> m ()
withDBusClientConnection cb n logfile f =
  maybe (run stderr) (`withLogFile` run) logfile
  where
    run h = do
      logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle h False
      withLogFunc logOpts $ \lf -> do
        env <- mkSimpleApp lf Nothing
        runRIO env $ displayMaybe' cb f =<< getDBusClient n

-- | Run a plugin action with a new DBus client and logfile path. This is
-- necessary for DBus callbacks which run in separate threads, which will
-- usually fire when the parent thread already exited and killed off its DBus
-- connection and closed its logfile. NOTE: unlike 'withDBusClientConnection'
-- this function will open and new logfile and client connection and close both
-- on completion. 'withDBusClientConnection' will only close the log file but
-- keep the client connection active upon termination; this client will only be
-- killed when the entire process is killed. This distinction is important
-- because callbacks only need ephemeral connections, while listeners (started
-- with 'withDBusClientConnection') need long-lasting connections.
withNestedDBusClientConnection
  :: (MonadUnliftIO m, SafeClient c, MonadReader (PluginEnv s c) m)
  => Maybe BusName
  -> Maybe FilePath
  -> PluginIO s c ()
  -> m ()
withNestedDBusClientConnection n logfile f = do
  dpy <- asks plugDisplay
  s <- asks plugState
  cb <- asks plugCallback
  let run h = do
        logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle h False
        withLogFunc logOpts $ \lf -> do
          env <- mkSimpleApp lf Nothing
          runRIO env $ withDBusClient_ n $ \cl -> mapRIO (PluginEnv cl s dpy cb) f
  maybe (run stderr) (`withLogFile` run) logfile