swaybar-protocol: additionalFonts via pango markup

3 files changed, 31 insertions, 9 deletions

diff --git a/src/Xmobar/Run/Parsers.hs b/src/Xmobar/Run/Parsers.hs
index 8a1ba0a..7c5e64c 100644
--- a/src/Xmobar/Run/Parsers.hs
+++ b/src/Xmobar/Run/Parsers.hs
@@ -17,6 +17,7 @@
 module Xmobar.Run.Parsers ( parseString
                           , colorComponents
                           , Segment
+                          , FontIndex
                           , Box(..)
                           , BoxBorder(..)
                           , BoxOffset(..)
diff --git a/src/Xmobar/Text/Pango.hs b/src/Xmobar/Text/Pango.hs
index b8205ef..38d1b5b 100644
--- a/src/Xmobar/Text/Pango.hs
+++ b/src/Xmobar/Text/Pango.hs
@@ -15,9 +15,10 @@
 --
 ------------------------------------------------------------------------------
 
-module Xmobar.Text.Pango (withPangoColor) where
+module Xmobar.Text.Pango (withPangoColor, withPangoFont) where
 
 import Text.Printf (printf)
+import Data.List (isPrefixOf)
 
 replaceAll :: (Eq a) => a -> [a] -> [a] -> [a]
 replaceAll c s = concatMap (\x -> if x == c then s else [x])
@@ -33,3 +34,8 @@ withPangoColor :: (String, String) -> String -> String
 withPangoColor (fg, bg) s =
   printf fmt (xmlEscape fg) (xmlEscape bg) (xmlEscape s)
   where fmt = "<span foreground=\"%s\" background=\"%s\">%s</span>"
+
+withPangoFont :: String -> String -> String
+withPangoFont font txt = printf fmt pfn (xmlEscape txt)
+  where fmt = "<span font=\"%s\">%s</span>"
+        pfn = if "xft:" `isPrefixOf` font then drop 4 font else font
diff --git a/src/Xmobar/Text/Swaybar.hs b/src/Xmobar/Text/Swaybar.hs
index 73ca75c..a2fc585 100644
--- a/src/Xmobar/Text/Swaybar.hs
+++ b/src/Xmobar/Text/Swaybar.hs
@@ -24,17 +24,19 @@ import Data.ByteString.Lazy.UTF8 (toString)
 
 import GHC.Generics
 
-import Xmobar.Config.Types (Config)
+import Xmobar.Config.Types (Config (additionalFonts))
 
 import Xmobar.Run.Parsers ( Segment
                           , Widget(..)
                           , Box(..)
                           , BoxBorder(..)
+                          , FontIndex
                           , tBoxes
                           , tColorsString
                           , colorComponents)
 
 import Xmobar.Text.SwaybarClicks (startHandler)
+import Xmobar.Text.Pango (withPangoFont)
 
 data Preamble =
   Preamble {version :: !Int, click_events :: Bool} deriving (Eq,Show,Generic)
@@ -46,17 +48,18 @@ preamble :: String
 preamble = (asString $ Preamble { version = 1, click_events = True }) ++ "\x0A["
 
 data Block =
-  Block { full_text :: String
-        , name :: String
+  Block { full_text :: !String
+        , name :: !String
         , color :: Maybe String
         , background :: Maybe String
-        , separator :: Bool
-        , separator_block_width :: Int
+        , separator :: !Bool
+        , separator_block_width :: !Int
         , border :: Maybe String
         , border_top :: Maybe Int
         , border_bottom :: Maybe Int
         , border_left :: Maybe Int
         , border_right :: Maybe Int
+        , markup :: Maybe String
         } deriving (Eq,Show,Generic)
 
 
@@ -72,6 +75,7 @@ defaultBlock = Block { full_text = ""
                      , border_bottom = Nothing
                      , border_left = Nothing
                      , border_right = Nothing
+                     , markup = Nothing
                      }
 
 instance ToJSON Block where
@@ -98,10 +102,21 @@ withBox (Box b _ n c _) block =
         bl = block { border_right = j0, border_left = j0
                    , border_bottom = j0, border_top = j0  }
 
+withFont :: Config -> FontIndex -> Block -> Block
+withFont conf idx block =
+  if idx < 1 || idx > length fonts then block
+  else block { markup = Just $ fonts !! (idx - 1) }
+  where fonts = additionalFonts conf
+
+withPango :: Block -> Block
+withPango block = case markup block of
+  Nothing -> block
+  Just fnt -> block { full_text = txt fnt, markup = Just "pango"}
+  where txt fn = withPangoFont fn (full_text block)
 
 formatSwaybar' :: Config -> Segment -> Block
-formatSwaybar' conf (Text txt, info, _, as) =
-  foldr withBox block (tBoxes info)
+formatSwaybar' conf (Text txt, info, idx, as) =
+  foldr withBox (withFont conf idx block) (tBoxes info)
   where (fg, bg) = colorComponents conf (tColorsString info)
         block = defaultBlock { full_text = txt
                              , color = Just fg
@@ -125,7 +140,7 @@ collectSegment config segment blocks =
   where b = formatSwaybar' config segment
 
 formatSwaybar :: Config -> [Segment] -> String
-formatSwaybar conf segs = asString blocks ++ ","
+formatSwaybar conf segs = asString (map withPango blocks) ++ ","
   where blocks = foldr (collectSegment conf) [] segs
 
 prepare :: IO ()