diff --git a/src/System/Tianbar/XMonadLog.hs b/src/System/Tianbar/XMonadLog.hs --- a/src/System/Tianbar/XMonadLog.hs +++ b/src/System/Tianbar/XMonadLog.hs @@ -1,69 +1,91 @@ -module System.Tianbar.XMonadLog ( tianbarPP - , dbusLog - , dbusLogWithPP +module System.Tianbar.XMonadLog ( dbusLog + , dbusLogWithMarkup + , dbusLogWithRenderer + , tianbarMarkup + , WindowSpaceInfo(..) + , Renderer + , MarkupRenderer ) where -import Codec.Binary.UTF8.String (decodeString) - -import Data.Char -import Data.List import Data.Maybe import DBus import DBus.Client -import XMonad -import XMonad.Hooks.DynamicLog - -wrapClass :: String -> String -> String -wrapClass cls = wrap ("") "" - -wrapWorkspaceClass :: String -> String -> String -wrapWorkspaceClass cls wid = wrapClass classes wid - where classes = intercalate " " [cls, ws, ws ++ wid] - ws = "workspace" - -escapeHtml :: String -> String -escapeHtml = concatMap escapeChar - where escapeChar '\"' = """ - escapeChar '\'' = "'" - escapeChar '&' = "&" - escapeChar '<' = "<" - escapeChar '>' = ">" - escapeChar c | ord c >= 160 = "&#" ++ show (ord c) ++ ";" - | otherwise = [c] - -tianbarPP :: PP -tianbarPP = defaultPP { ppTitle = escapeHtml - , ppCurrent = wrapWorkspaceClass "current" - , ppVisible = wrapWorkspaceClass "visible" - , ppUrgent = wrapWorkspaceClass "urgent" - , ppHidden = wrapWorkspaceClass "hidden" - , ppHiddenNoWindows = wrapWorkspaceClass "hidden empty" - , ppSep = "" - , ppOrder = zipWith wrapClass [ "workspaces" - , "layout" - , "title" - ] - } +import Text.Blaze +import qualified Text.Blaze.Html5 as H +import qualified Text.Blaze.Html5.Attributes as A +import Text.Blaze.Renderer.String (renderMarkup) -dbusLogWithPP :: Client -> PP -> X () -dbusLogWithPP client pp = dynamicLogWithPP pp { ppOutput = outputThroughDBus client } +import XMonad hiding (title, workspaces) +import XMonad.Hooks.UrgencyHook +import qualified XMonad.StackSet as S +import XMonad.Util.NamedWindows +import XMonad.Util.WorkspaceCompare -- | A DBus-based logger with a default pretty-print configuration dbusLog :: Client -> X () -dbusLog client = dbusLogWithPP client tianbarPP +dbusLog client = dbusLogWithMarkup client tianbarMarkup sig :: Signal sig = signal (fromJust $ parseObjectPath "/org/xmonad/Log") (fromJust $ parseInterfaceName "org.xmonad.Log") (fromJust $ parseMemberName "Update") -outputThroughDBus :: Client -> String -> IO () -outputThroughDBus client str = do - -- The string that we get from XMonad here isn't quite a normal - -- string - each character is actually a byte in a utf8 encoding. - -- We need to decode the string back into a real String before we - -- send it over dbus. - let str' = decodeString str - emit client sig { signalBody = [ toVariant str' ] } +data WindowSpaceInfo = WindowSpaceInfo { wsTag :: String + , wsCurrent :: Bool + , wsHidden :: Bool + , wsUrgent :: Bool + , wsEmpty :: Bool + } + +type Renderer a = String -- ^ layout description + -> String -- ^ window title + -> [WindowSpaceInfo] -- ^ workspaces + -> [Window] -- ^ urgent windows + -> WindowSet -- ^ all windows + -> a + +type MarkupRenderer = Renderer Markup + +dbusLogWithRenderer :: Client -> Renderer String -> X () +dbusLogWithRenderer client renderer = do + winset <- gets windowset + urgents <- readUrgents + let ld = description . S.layout . S.workspace . S.current $ winset + wt <- maybe (return "") (fmap show . getName) . S.peek $ winset + + sort_ <- mkWsSort getWsCompare + let ws = sort_ $ map S.workspace (S.current winset : S.visible winset) + ++ S.hidden winset + let visibles = map (S.tag . S.workspace) (S.visible winset) + let wsinfo w = WindowSpaceInfo tag_ current_ hidden_ urgent_ empty_ + where tag_ = S.tag w + current_ = tag_ == S.currentTag winset + hidden_ = tag_ `notElem` visibles + urgent_ = any (\x -> maybe False (== tag_) (S.findTag x winset)) urgents + empty_ = isNothing (S.stack w) + + let html = renderer ld wt (map wsinfo ws) urgents winset + liftIO $ emit client sig { signalBody = [ toVariant html ] } + +dbusLogWithMarkup :: Client -> MarkupRenderer -> X () +dbusLogWithMarkup client renderer = dbusLogWithRenderer client renderer' + where renderer' ld wt wksp urgent winset = + renderMarkup $ renderer ld wt wksp urgent winset + +tianbarMarkup :: MarkupRenderer +tianbarMarkup layout title workspaces _ _ = do + H.span ! A.class_ (toValue "workspaces") $ + mapM_ wsHtml $ workspaces + H.span ! A.class_ (toValue "layout") $ toMarkup layout + H.span ! A.class_ (toValue "title") $ toMarkup title + where + wsHtml w = H.span ! A.class_ (toValue $ unwords classes) $ + toMarkup $ wsTag w + where classes = + ["workspace"] ++ + ["current" | wsCurrent w] ++ + ["hidden" | wsHidden w] ++ + ["urgent" | wsUrgent w] ++ + ["empty" | wsEmpty w] diff --git a/tianbar.cabal b/tianbar.cabal --- a/tianbar.cabal +++ b/tianbar.cabal @@ -1,5 +1,5 @@ name: tianbar -version: 0.1.3.1 +version: 0.2.0.0 synopsis: A desktop bar based on WebKit description: A desktop bar using WebKit for rendering as much as possible. @@ -8,7 +8,7 @@ license: MIT license-file: LICENSE author: Alexey Kotlyarov -maintainer: koterpillar@gmail.com +maintainer: a@koterpillar.com category: System build-type: Simple cabal-version: >=1.10 @@ -43,6 +43,8 @@ , xmonad , xmonad-contrib , utf8-string ==0.3.* + , blaze-html ==0.5.* + , blaze-markup ==0.5.* hs-source-dirs: src exposed-modules: System.Tianbar.XMonadLog ghc-options: -Wall -rtsopts