Allow font bg to be taller (or smaller)

Implemented only for XFT fonts.
Adds a new "part" in the fc tag.
> Example: <fc=white,gray:0>foo bar</fc> will make the font background
as tall as the bar (absolute offset, here set to 0 for both top &
bottom)
Changes ColorString to ColorInfo, containing both top and bottom
offsets. The "colors string" is still in only one string.

4 files changed, 56 insertions, 37 deletions

diff --git a/src/Xmobar/App/EventLoop.hs b/src/Xmobar/App/EventLoop.hs
index e6232cd..2b33768 100644
--- a/src/Xmobar/App/EventLoop.hs
+++ b/src/Xmobar/App/EventLoop.hs
@@ -250,17 +250,17 @@ startCommand sig (com,s,ss)
     where is = s ++ "Updating..." ++ ss
 
 updateString :: Config -> TVar [String]
-                -> IO [[(Widget, String, Int, Maybe [Action])]]
+                -> IO [[(Widget, ColorInfo, Int, Maybe [Action])]]
 updateString conf v = do
   s <- readTVarIO v
   let l:c:r:_ = s ++ repeat ""
   liftIO $ mapM (parseString conf) [l, c, r]
 
-updateActions :: XConf -> Rectangle -> [[(Widget, String, Int, Maybe [Action])]]
+updateActions :: XConf -> Rectangle -> [[(Widget, ColorInfo, Int, Maybe [Action])]]
                  -> IO [([Action], Position, Position)]
 updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do
   let (d,fs) = (display &&& fontListS) conf
-      strLn :: [(Widget, String, Int, Maybe [Action])] -> IO [(Maybe [Action], Position, Position)]
+      strLn :: [(Widget, ColorInfo, Int, Maybe [Action])] -> IO [(Maybe [Action], Position, Position)]
       strLn  = liftIO . mapM getCoords
       iconW i = maybe 0 Bitmap.width (lookup i $ iconS conf)
       getCoords (Text s,_,i,a) = textWidth d (safeIndex fs i) s >>= \tw -> return (a, 0, fi tw)
diff --git a/src/Xmobar/X11/Bitmap.hs b/src/Xmobar/X11/Bitmap.hs
index e323606..e764384 100644
--- a/src/Xmobar/X11/Bitmap.hs
+++ b/src/Xmobar/X11/Bitmap.hs
@@ -24,7 +24,7 @@ import System.Directory (doesFileExist)
 import System.FilePath ((</>))
 import System.Mem.Weak ( addFinalizer )
 import Xmobar.X11.ColorCache
-import Xmobar.X11.Parsers (Widget(..))
+import Xmobar.X11.Parsers (ColorInfo(..), Widget(..))
 import Xmobar.X11.Actions (Action)
 
 #ifdef XPM
@@ -54,7 +54,7 @@ data Bitmap = Bitmap { width  :: Dimension
                      }
 
 updateCache :: Display -> Window -> Map FilePath Bitmap -> FilePath ->
-               [[(Widget, String, Int, Maybe [Action])]] -> IO (Map FilePath Bitmap)
+               [[(Widget, ColorInfo, Int, Maybe [Action])]] -> IO (Map FilePath Bitmap)
 updateCache dpy win cache iconRoot ps = do
   let paths = map (\(Icon p, _, _, _) -> p) . concatMap (filter icons) $ ps
       icons (Icon _, _, _, _) = True
diff --git a/src/Xmobar/X11/Draw.hs b/src/Xmobar/X11/Draw.hs
index ab7c6df..003f579 100644
--- a/src/Xmobar/X11/Draw.hs
+++ b/src/Xmobar/X11/Draw.hs
@@ -36,7 +36,7 @@ import Xmobar.X11.Types
 import Xmobar.X11.Text
 import Xmobar.X11.ColorCache
 import Xmobar.X11.Window (drawBorder)
-import Xmobar.X11.Parsers (Widget(..))
+import Xmobar.X11.Parsers (ColorInfo(..), Widget(..))
 import Xmobar.System.Utils (safeIndex)
 
 #ifdef XFT
@@ -48,7 +48,7 @@ fi :: (Integral a, Num b) => a -> b
 fi = fromIntegral
 
 -- | Draws in and updates the window
-drawInWin :: Rectangle -> [[(Widget, String, Int, Maybe [Action])]] -> X ()
+drawInWin :: Rectangle -> [[(Widget, ColorInfo, Int, Maybe [Action])]] -> X ()
 drawInWin wr@(Rectangle _ _ wid ht) ~[left,center,right] = do
   r <- ask
   let (c,d) = (config &&& display) r
@@ -102,33 +102,35 @@ verticalOffset ht (Icon _) _ _ conf
   | otherwise = return $ fi (ht `div` 2) - 1
 
 printString :: Display -> Drawable -> XFont -> GC -> String -> String
-            -> Position -> Position -> String -> Int -> IO ()
-printString d p (Core fs) gc fc bc x y s a = do
+            -> Position -> Position -> Position -> Position -> String -> Int -> IO ()
+printString d p (Core fs) gc fc bc x y ay ht s a = do
     setFont d gc $ fontFromFontStruct fs
     withColors d [fc, bc] $ \[fc', bc'] -> do
       setForeground d gc fc'
       when (a == 255) (setBackground d gc bc')
       drawImageString d p gc x y s
 
-printString d p (Utf8 fs) gc fc bc x y s a =
+printString d p (Utf8 fs) gc fc bc x y ay ht s a =
     withColors d [fc, bc] $ \[fc', bc'] -> do
       setForeground d gc fc'
       when (a == 255) (setBackground d gc bc')
       liftIO $ wcDrawImageString d p fs gc x y s
 
 #ifdef XFT
-printString dpy drw fs@(Xft fonts) _ fc bc x y s al =
+printString dpy drw fs@(Xft fonts) _ fc bc x y ay ht s al =
   withDrawingColors dpy drw fc bc $ \draw fc' bc' -> do
     when (al == 255) $ do
       (a,d)  <- textExtents fs s
       gi <- xftTxtExtents' dpy fonts s
-      drawXftRect draw bc' x (y - a) (1 + xglyphinfo_xOff gi) (a + d + 2)
+      if ay < 0
+        then drawXftRect draw bc' x (y - a) (1 + xglyphinfo_xOff gi) (a + d + 2)
+        else drawXftRect draw bc' x ay (1 + xglyphinfo_xOff gi) ht
     drawXftString' draw fc' fonts (toInteger x) (toInteger y) s
 #endif
 
 -- | An easy way to print the stuff we need to print
 printStrings :: Drawable -> GC -> NE.NonEmpty XFont -> [Int] -> Position
-             -> Align -> [(Widget, String, Int, Position)] -> X ()
+             -> Align -> [(Widget, ColorInfo, Int, Position)] -> X ()
 printStrings _ _ _ _ _ _ [] = return ()
 printStrings dr gc fontlist voffs offs a sl@((s,c,i,l):xs) = do
   r <- ask
@@ -142,12 +144,16 @@ printStrings dr gc fontlist voffs offs a sl@((s,c,i,l):xs) = do
                  C -> (remWidth + offs) `div` 2
                  R -> remWidth
                  L -> offs
-      (fc,bc) = case break (==',') c of
+      (fc,bc) = case break (==',') (colorsString c) of
                  (f,',':b) -> (f, b           )
                  (f,    _) -> (f, bgColor conf)
   valign <- verticalOffset ht s (NE.head fontlist) (voffs !! i) conf
+  let (ht',ay) = case (bgTopOffset c, bgBottomOffset c) of
+                   (-1,_)  -> (0, -1)
+                   (_,-1)  -> (0, -1)
+                   (ot,ob) -> ((fromIntegral ht) - ot - ob, ob)
   case s of
-    (Text t) -> liftIO $ printString d dr fontst gc fc bc offset valign t alph
+    (Text t) -> liftIO $ printString d dr fontst gc fc bc offset valign ay ht' t alph
     (Icon p) -> liftIO $ maybe (return ())
                            (B.drawBitmap d dr gc fc bc offset valign)
                            (lookup p (iconS r))
diff --git a/src/Xmobar/X11/Parsers.hs b/src/Xmobar/X11/Parsers.hs
index 1d486d9..175de8c 100644
--- a/src/Xmobar/X11/Parsers.hs
+++ b/src/Xmobar/X11/Parsers.hs
@@ -14,37 +14,44 @@
 --
 -----------------------------------------------------------------------------
 
-module Xmobar.X11.Parsers (parseString, Widget(..)) where
+module Xmobar.X11.Parsers (parseString, ColorInfo(..), Widget(..)) where
 
 import Xmobar.Config.Types
 import Xmobar.X11.Actions
 
 import Control.Monad (guard, mzero)
 import Data.Maybe (fromMaybe)
+import Data.Int (Int32)
 import Text.ParserCombinators.Parsec
 import Text.Read (readMaybe)
 import Graphics.X11.Types (Button)
 
 data Widget = Icon String | Text String
 
-type ColorString = String
+type AbsBgOffset = Int32
+data ColorInfo   =
+       ColorInfo { colorsString   :: String
+                 , bgTopOffset    :: AbsBgOffset
+                 , bgBottomOffset :: AbsBgOffset
+                 } deriving Show
 type FontIndex   = Int
 
 -- | Runs the string parser
 parseString :: Config -> String
-               -> IO [(Widget, ColorString, FontIndex, Maybe [Action])]
+               -> IO [(Widget, ColorInfo, FontIndex, Maybe [Action])]
 parseString c s =
-    case parse (stringParser (fgColor c) 0 Nothing) "" s of
+    case parse (stringParser ci 0 Nothing) "" s of
       Left  _ -> return [(Text $ "Could not parse string: " ++ s
-                          , fgColor c
+                          , ci
                           , 0
                           , Nothing)]
       Right x -> return (concat x)
+    where ci = ColorInfo (fgColor c) 0 0
 
-allParsers :: ColorString
+allParsers :: ColorInfo
            -> FontIndex
            -> Maybe [Action]
-           -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]
+           -> Parser [(Widget, ColorInfo, FontIndex, Maybe [Action])]
 allParsers c f a =  textParser c f a
                 <|> try (iconParser c f a)
                 <|> try (rawParser c f a)
@@ -53,13 +60,13 @@ allParsers c f a =  textParser c f a
                 <|> colorParser f a
 
 -- | Gets the string and combines the needed parsers
-stringParser :: String -> FontIndex -> Maybe [Action]
-                -> Parser [[(Widget, ColorString, FontIndex, Maybe [Action])]]
+stringParser :: ColorInfo -> FontIndex -> Maybe [Action]
+                -> Parser [[(Widget, ColorInfo, FontIndex, Maybe [Action])]]
 stringParser c f a = manyTill (allParsers c f a) eof
 
 -- | Parses a maximal string without markup.
-textParser :: String -> FontIndex -> Maybe [Action]
-              -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]
+textParser :: ColorInfo -> FontIndex -> Maybe [Action]
+              -> Parser [(Widget, ColorInfo, FontIndex, Maybe [Action])]
 textParser c f a = do s <- many1 $
                             noneOf "<" <|>
                               try (notFollowedBy' (char '<')
@@ -78,10 +85,10 @@ textParser c f a = do s <- many1 $
 -- string of digits (base 10) denoting the length of the raw string,
 -- a literal ":" as digit-string-terminator, the raw string itself, and
 -- then a literal "/>".
-rawParser :: ColorString
+rawParser :: ColorInfo
           -> FontIndex
           -> Maybe [Action]
-          -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]
+          -> Parser [(Widget, ColorInfo, FontIndex, Maybe [Action])]
 rawParser c f a = do
   string "<raw="
   lenstr <- many1 digit
@@ -102,15 +109,15 @@ notFollowedBy' p e = do x <- p
                         notFollowedBy $ try (e >> return '*')
                         return x
 
-iconParser :: String -> FontIndex -> Maybe [Action]
-              -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]
+iconParser :: ColorInfo -> FontIndex -> Maybe [Action]
+              -> Parser [(Widget, ColorInfo, FontIndex, Maybe [Action])]
 iconParser c f a = do
   string "<icon="
   i <- manyTill (noneOf ">") (try (string "/>"))
   return [(Icon i, c, f, a)]
 
-actionParser :: String -> FontIndex -> Maybe [Action]
-                -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]
+actionParser :: ColorInfo -> FontIndex -> Maybe [Action]
+                -> Parser [(Widget, ColorInfo, FontIndex, Maybe [Action])]
 actionParser c f act = do
   string "<action="
   command <- choice [between (char '`') (char '`') (many1 (noneOf "`")),
@@ -129,15 +136,21 @@ toButtons = map (\x -> read [x])
 
 -- | Parsers a string wrapped in a color specification.
 colorParser :: FontIndex -> Maybe [Action]
-               -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]
+               -> Parser [(Widget, ColorInfo, FontIndex, Maybe [Action])]
 colorParser f a = do
   c <- between (string "<fc=") (string ">") colors
-  s <- manyTill (allParsers c f a) (try $ string "</fc>")
+  let colorParts = break (==':') c
+  let (ot,ob) = case break (==',') (Prelude.drop 1 $ snd colorParts) of
+             (top,',':btm) -> (top, btm)
+             (top,      _) -> (top, top)
+  s <- manyTill
+       (allParsers (ColorInfo (fst colorParts) (fromMaybe (-1) $ readMaybe ot) (fromMaybe (-1) $ readMaybe ob)) f a)
+       (try $ string "</fc>")
   return (concat s)
 
 -- | Parsers a string wrapped in a font specification.
-fontParser :: ColorString -> Maybe [Action]
-              -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]
+fontParser :: ColorInfo -> Maybe [Action]
+              -> Parser [(Widget, ColorInfo, FontIndex, Maybe [Action])]
 fontParser c a = do
   f <- between (string "<fn=") (string ">") colors
   s <- manyTill (allParsers c (fromMaybe 0 $ readMaybe f) a) (try $ string "</fn>")
@@ -145,4 +158,4 @@ fontParser c a = do
 
 -- | Parses a color specification (hex or named)
 colors :: Parser String
-colors = many1 (alphaNum <|> char ',' <|> char '#')
+colors = many1 (alphaNum <|> char ',' <|> char ':' <|> char '#')