module System.Taffybar.XMonadLog (
xmonadLogNew,
dbusLog,
dbusLogWithPP,
taffybarPP,
taffybarDefaultPP,
taffybarColor,
taffybarEscape
) where
import Codec.Binary.UTF8.String ( decodeString )
import DBus ( toVariant, fromVariant, Signal(..), signal )
import DBus.Client ( listen, matchAny, MatchRule(..), connectSession, emit, Client )
import Graphics.UI.Gtk hiding ( Signal )
import XMonad
import XMonad.Hooks.DynamicLog
dbusLogWithPP :: Client -> PP -> X ()
dbusLogWithPP client pp = dynamicLogWithPP pp { ppOutput = outputThroughDBus client }
dbusLog :: Client -> X ()
dbusLog client = dbusLogWithPP client taffybarDefaultPP
taffybarColor :: String -> String -> String -> String
taffybarColor fg bg = wrap t "</span>" . taffybarEscape
where
t = concat ["<span fgcolor=\"", fg, if null bg then "" else "\" bgcolor=\"" ++ bg , "\">"]
taffybarEscape :: String -> String
taffybarEscape = escapeMarkup
taffybarDefaultPP :: PP
taffybarDefaultPP =
#if MIN_VERSION_xmonad_contrib(0, 12, 0)
def {
#else
defaultPP {
#endif
ppCurrent = taffybarEscape . wrap "[" "]"
, ppVisible = taffybarEscape . wrap "<" ">"
, ppHidden = taffybarEscape
, ppHiddenNoWindows = taffybarEscape
, ppUrgent = taffybarEscape
, ppTitle = taffybarEscape . shorten 80
, ppLayout = taffybarEscape
}
taffybarPP :: PP
taffybarPP = taffybarDefaultPP { ppCurrent = taffybarColor "yellow" "" . wrap "[" "]"
, ppTitle = taffybarColor "green" "" . shorten 40
, ppVisible = wrap "(" ")"
, ppUrgent = taffybarColor "red" "yellow"
}
outputThroughDBus :: Client -> String -> IO ()
outputThroughDBus client str = do
let str' = decodeString str
emit client (signal "/org/xmonad/Log" "org.xmonad.Log" "Update") { signalBody = [ toVariant str' ] }
setupDbus :: Label -> IO ()
setupDbus w = do
let matcher = matchAny { matchSender = Nothing
, matchDestination = Nothing
, matchPath = Just "/org/xmonad/Log"
, matchInterface = Just "org.xmonad.Log"
, matchMember = Just "Update"
}
client <- connectSession
listen client matcher (callback w)
callback :: Label -> Signal -> IO ()
callback w sig = do
let [bdy] = signalBody sig
status :: String
Just status = fromVariant bdy
postGUIAsync $ labelSetMarkup w status
xmonadLogNew :: IO Widget
xmonadLogNew = do
l <- labelNew (Nothing :: Maybe String)
_ <- on l realize $ setupDbus l
widgetShowAll l
return (toWidget l)