Add the <box> tag to set borders around text

2 files changed, 99 insertions, 20 deletions

diff --git a/src/Xmobar/X11/Draw.hs b/src/Xmobar/X11/Draw.hs
index cd74872..8906da2 100644
--- a/src/Xmobar/X11/Draw.hs
+++ b/src/Xmobar/X11/Draw.hs
@@ -23,7 +23,8 @@ import Prelude hiding (lookup)
 import Control.Monad.IO.Class
 import Control.Monad.Reader
 import Control.Arrow ((&&&))
-import Data.Map hiding (foldr, map, filter)
+import Data.Map hiding ((\\), foldr, map, filter)
+import Data.List ((\\))
 import qualified Data.List.NonEmpty as NE
 
 import Graphics.X11.Xlib hiding (textExtents, textWidth)
@@ -36,7 +37,7 @@ import Xmobar.X11.Types
 import Xmobar.X11.Text
 import Xmobar.X11.ColorCache
 import Xmobar.X11.Window (drawBorder)
-import Xmobar.X11.Parsers (TextRenderInfo(..), Widget(..))
+import Xmobar.X11.Parsers hiding (parseString)
 import Xmobar.System.Utils (safeIndex)
 
 #ifdef XFT
@@ -76,9 +77,9 @@ drawInWin wr@(Rectangle _ _ wid ht) ~[left,center,right] = do
       liftIO $ setForeground d gc bgcolor
       liftIO $ fillRectangle d p gc 0 0 wid ht
     -- write to the pixmap the new string
-    printStrings p gc fs vs 1 L =<< strLn left
-    printStrings p gc fs vs 1 R =<< strLn right
-    printStrings p gc fs vs 1 C =<< strLn center
+    printStrings p gc fs vs 1 L [] =<< strLn left
+    printStrings p gc fs vs 1 R [] =<< strLn right
+    printStrings p gc fs vs 1 C [] =<< strLn center
     -- draw border if requested
     liftIO $ drawBorder (border c) (borderWidth c) d p gc bdcolor wid ht
     -- copy the pixmap with the new string to the window
@@ -130,9 +131,9 @@ printString dpy drw fs@(Xft fonts) _ fc bc x y ay ht s al =
 
 -- | An easy way to print the stuff we need to print
 printStrings :: Drawable -> GC -> NE.NonEmpty XFont -> [Int] -> Position
-             -> Align -> [(Widget, TextRenderInfo, Int, Position)] -> X ()
-printStrings _ _ _ _ _ _ [] = return ()
-printStrings dr gc fontlist voffs offs a sl@((s,c,i,l):xs) = do
+             -> Align -> [((Position, Position), Box)] -> [(Widget, TextRenderInfo, Int, Position)] -> X ()
+printStrings _ _ _ _ _ _ _ [] = return ()
+printStrings dr gc fontlist voffs offs a boxes sl@((s,c,i,l):xs) = do
   r <- ask
   let (conf,d) = (config &&& display) r
       alph = alpha conf
@@ -157,4 +158,46 @@ printStrings dr gc fontlist voffs offs a sl@((s,c,i,l):xs) = do
     (Icon p) -> liftIO $ maybe (return ())
                            (B.drawBitmap d dr gc fc bc offset valign)
                            (lookup p (iconS r))
-  printStrings dr gc fontlist voffs (offs + l) a xs
+  let x2 = offset + l - 1
+  let triBoxes = tBoxes c
+      dropBoxes = filter (\(_,b) -> not(b `elem` triBoxes)) boxes
+      boxes' = map (\((x1,_),b) -> ((x1, x2), b)) (filter (\(_,b) -> b `elem` triBoxes) boxes)
+            ++ map (\b -> ((offset - 1, x2), b)) (triBoxes \\ (map snd boxes))
+  if Prelude.null xs
+    then liftIO $ drawBoxes d dr gc (fromIntegral ht) (dropBoxes ++ boxes')
+    else liftIO $ drawBoxes d dr gc (fromIntegral ht) dropBoxes
+  printStrings dr gc fontlist voffs (offs + l) a boxes' xs
+
+drawBoxes :: Display -> Drawable -> GC -> Position -> [((Position, Position), Box)] -> IO ()
+drawBoxes _ _ _ _ [] = return ()
+drawBoxes d dr gc ht (b:bs) = do
+  let (xx, Box pos alg offset lineWidth fc) = b
+  withColors d [fc] $ \[fc'] -> do
+    setForeground d gc fc'
+    setLineAttributes d gc lineWidth lineSolid capNotLast joinMiter
+    case pos of
+      BBVBoth -> do
+        drawBoxBorder d dr gc BBTop    alg offset ht xx
+        drawBoxBorder d dr gc BBBottom alg offset ht xx
+      BBHBoth -> do
+        drawBoxBorder d dr gc BBLeft   alg offset ht xx
+        drawBoxBorder d dr gc BBRight  alg offset ht xx
+      BBFull  -> do
+        drawBoxBorder d dr gc BBTop    alg offset ht xx
+        drawBoxBorder d dr gc BBBottom alg offset ht xx
+        drawBoxBorder d dr gc BBLeft   alg offset ht xx
+        drawBoxBorder d dr gc BBRight  alg offset ht xx
+      _ -> drawBoxBorder d dr gc pos   alg offset ht xx
+  drawBoxes d dr gc ht bs
+
+drawBoxBorder :: Display -> Drawable -> GC -> BoxBorder -> Align -> Position -> Position -> (Position, Position) -> IO ()
+drawBoxBorder d dr gc pos alg offset ht (x1,x2) = do
+  let (p1,p2) = case alg of
+                 L -> (0,      (-offset))
+                 C -> (offset, (-offset))
+                 R -> (offset, 0        )
+  case pos of
+    BBTop    -> drawLine d dr gc (x1 + p1) 0  (x2 + p2) 0
+    BBBottom -> drawLine d dr gc (x1 + p1) (ht - 1) (x2 + p2) (ht - 1)
+    BBLeft   -> drawLine d dr gc x1 p1 x1 (ht + p2)
+    BBRight  -> drawLine d dr gc x2 p1 x2 (ht + p2)
diff --git a/src/Xmobar/X11/Parsers.hs b/src/Xmobar/X11/Parsers.hs
index fded3b3..c25715c 100644
--- a/src/Xmobar/X11/Parsers.hs
+++ b/src/Xmobar/X11/Parsers.hs
@@ -14,7 +14,7 @@
 --
 -----------------------------------------------------------------------------
 
-module Xmobar.X11.Parsers (parseString, TextRenderInfo(..), Widget(..)) where
+module Xmobar.X11.Parsers (parseString, Box(..), BoxBorder(..), TextRenderInfo(..), Widget(..)) where
 
 import Xmobar.Config.Types
 import Xmobar.X11.Actions
@@ -25,15 +25,37 @@ import Data.Int (Int32)
 import Text.ParserCombinators.Parsec
 import Text.Read (readMaybe)
 import Graphics.X11.Types (Button)
+import Foreign.C.Types (CInt)
 
 data Widget = Icon String | Text String
 
-type AbsBgOffset    = Int32
+data BoxBorder = BBTop
+               | BBBottom
+               | BBVBoth
+               | BBLeft
+               | BBRight
+               | BBHBoth
+               | BBFull
+                 deriving ( Read, Eq )
+data Box = Box BoxBorder Align Int32 CInt String deriving ( Eq )
+instance Read Box where
+  readsPrec _ input = do
+    let b = case (words input) of
+             [pos]               -> Just $ Box (read pos) C 0 1 "white"
+             [pos,alg]           -> Just $ Box (read pos) (read alg) 0 1 "white"
+             [pos,alg,off]       -> Just $ Box (read pos) (read alg) (read off) 1 "white"
+             [pos,alg,off,wdh]   -> Just $ Box (read pos) (read alg) (read off) (read wdh) "white"
+             [pos,alg,off,wdh,c] -> Just $ Box (read pos) (read alg) (read off) (read wdh) c
+             _ -> Nothing
+    case b of
+      Just b' -> [(b', "")]
+      _ -> []
 data TextRenderInfo =
-     TextRenderInfo { tColorsString   :: String
-                    , tBgTopOffset    :: AbsBgOffset
-                    , tBgBottomOffset :: AbsBgOffset
-                    } deriving Show
+    TextRenderInfo { tColorsString   :: String
+                   , tBgTopOffset    :: Int32
+                   , tBgBottomOffset :: Int32
+                   , tBoxes          :: [Box]
+                   }
 type FontIndex   = Int
 
 -- | Runs the string parser
@@ -46,7 +68,7 @@ parseString c s =
                           , 0
                           , Nothing)]
       Right x -> return (concat x)
-    where ci = TextRenderInfo (fgColor c) 0 0
+    where ci = TextRenderInfo (fgColor c) 0 0 []
 
 allParsers :: TextRenderInfo
            -> FontIndex
@@ -57,7 +79,8 @@ allParsers c f a =  textParser c f a
                 <|> try (rawParser c f a)
                 <|> try (actionParser c f a)
                 <|> try (fontParser c a)
-                <|> colorParser f a
+                <|> try (boxParser c f a)
+                <|> colorParser c f a
 
 -- | Gets the string and combines the needed parsers
 stringParser :: TextRenderInfo -> FontIndex -> Maybe [Action]
@@ -71,12 +94,14 @@ textParser c f a = do s <- many1 $
                             noneOf "<" <|>
                               try (notFollowedBy' (char '<')
                                     (try (string "fc=")  <|>
+                                     try (string "box=")  <|>
                                      try (string "fn=")  <|>
                                      try (string "action=") <|>
                                      try (string "/action>") <|>
                                      try (string "icon=") <|>
                                      try (string "raw=") <|>
                                      try (string "/fn>") <|>
+                                     try (string "/box>") <|>
                                      string "/fc>"))
                       return [(Text s, c, f, a)]
 
@@ -135,19 +160,30 @@ toButtons :: String -> [Button]
 toButtons = map (\x -> read [x])
 
 -- | Parsers a string wrapped in a color specification.
-colorParser :: FontIndex -> Maybe [Action]
+colorParser :: TextRenderInfo -> FontIndex -> Maybe [Action]
                -> Parser [(Widget, TextRenderInfo, FontIndex, Maybe [Action])]
-colorParser f a = do
+colorParser (TextRenderInfo _ _ _ bs) f a = do
   c <- between (string "<fc=") (string ">") colors
   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 (TextRenderInfo (fst colorParts) (fromMaybe (-1) $ readMaybe ot) (fromMaybe (-1) $ readMaybe ob)) f a)
+       (allParsers (TextRenderInfo (fst colorParts) (fromMaybe (-1) $ readMaybe ot) (fromMaybe (-1) $ readMaybe ob) bs) f a)
        (try $ string "</fc>")
   return (concat s)
 
+-- | Parses a string wrapped in a box specification.
+boxParser :: TextRenderInfo -> FontIndex -> Maybe [Action]
+              -> Parser [(Widget, TextRenderInfo, FontIndex, Maybe [Action])]
+boxParser (TextRenderInfo cs ot ob bs) f a = do
+  c <- between (string "<box=") (string ">") (many1 (alphaNum <|> char ' ' <|> char '#'))
+  let b = fromMaybe (Box BBFull C 0 1 "white") $ readMaybe c
+  s <- manyTill
+       (allParsers (TextRenderInfo cs ot ob (b : bs)) f a)
+       (try $ string "</box>")
+  return (concat s)
+ 
 -- | Parsers a string wrapped in a font specification.
 fontParser :: TextRenderInfo -> Maybe [Action]
               -> Parser [(Widget, TextRenderInfo, FontIndex, Maybe [Action])]