132 lines
3.6 KiB
Haskell
132 lines
3.6 KiB
Haskell
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 $
|
|
bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $
|
|
displayMaybe' cb f
|
|
|
|
-- | 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.
|
|
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
|
|
withDBusClientConnection cb n logfile $ \c -> mapRIO (PluginEnv c s dpy cb) f
|