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

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