better parsing for boxes + add margins

2 files changed, 59 insertions, 38 deletions

diff --git a/src/Xmobar/X11/Draw.hs b/src/Xmobar/X11/Draw.hs
index 0e07573..22b88ae 100644
--- a/src/Xmobar/X11/Draw.hs
+++ b/src/Xmobar/X11/Draw.hs
@@ -105,14 +105,14 @@ verticalOffset ht (Icon _) _ _ conf
 
 printString :: Display -> Drawable -> XFont -> GC -> String -> String
             -> Position -> Position -> Position -> Position -> String -> Int -> IO ()
-printString d p (Core fs) gc fc bc x y ay ht s a = do
+printString d p (Core fs) gc fc bc x y _ _ 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 ay ht s a =
+printString d p (Utf8 fs) gc fc bc x y _ _ s a =
     withColors d [fc, bc] $ \[fc', bc'] -> do
       setForeground d gc fc'
       when (a == 255) (setBackground d gc bc')
@@ -171,38 +171,38 @@ printStrings dr gc fontlist voffs offs a boxes sl@((s,c,i,l):xs) = do
 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
+  let (xx, Box bb offset lineWidth fc mgs) = b
       lw = fromIntegral lineWidth :: Position
   withColors d [fc] $ \[fc'] -> do
     setForeground d gc fc'
     setLineAttributes d gc lineWidth lineSolid capNotLast joinMiter
-    case pos of
+    case bb of
       BBVBoth -> do
-        drawBoxBorder d dr gc BBTop    alg offset ht xx lw
-        drawBoxBorder d dr gc BBBottom alg offset ht xx lw
+        drawBoxBorder d dr gc BBTop    offset ht xx lw mgs
+        drawBoxBorder d dr gc BBBottom offset ht xx lw mgs
       BBHBoth -> do
-        drawBoxBorder d dr gc BBLeft   alg offset ht xx lw
-        drawBoxBorder d dr gc BBRight  alg offset ht xx lw
+        drawBoxBorder d dr gc BBLeft   offset ht xx lw mgs
+        drawBoxBorder d dr gc BBRight  offset ht xx lw mgs
       BBFull  -> do
-        drawBoxBorder d dr gc BBTop    alg offset ht xx lw
-        drawBoxBorder d dr gc BBBottom alg offset ht xx lw
-        drawBoxBorder d dr gc BBLeft   alg offset ht xx lw
-        drawBoxBorder d dr gc BBRight  alg offset ht xx lw
-      _ -> drawBoxBorder d dr gc pos   alg offset ht xx lw
+        drawBoxBorder d dr gc BBTop    offset ht xx lw mgs
+        drawBoxBorder d dr gc BBBottom offset ht xx lw mgs
+        drawBoxBorder d dr gc BBLeft   offset ht xx lw mgs
+        drawBoxBorder d dr gc BBRight  offset ht xx lw mgs
+      _ -> drawBoxBorder d dr gc bb    offset ht xx lw mgs
   drawBoxes d dr gc ht bs
 
-drawBoxBorder :: Display -> Drawable -> GC -> BoxBorder -> Align -> Position -> Position
-                 -> (Position, Position) -> Position -> IO ()
-drawBoxBorder d dr gc pos alg offset ht (x1,x2) lw = do
+drawBoxBorder :: Display -> Drawable -> GC -> BoxBorder -> BoxOffset -> Position
+                 -> (Position, Position) -> Position -> BoxMargins -> IO ()
+drawBoxBorder d dr gc pos (BoxOffset alg offset) ht (x1,x2) lw (BoxMargins mt mr mb ml) = do
   let (p1,p2) = case alg of
                  L -> (0,      -offset)
                  C -> (offset, -offset)
                  R -> (offset, 0      )
       lc = lw `div` 2
   case pos of
-    BBTop    -> drawLine d dr gc (x1 + p1) lc  (x2 + p2) lc
+    BBTop    -> drawLine d dr gc (x1 + p1) (mt + lc) (x2 + p2) (mt + lc)
     BBBottom -> do
-      let lc' = max lc 1
+      let lc' = max lc 1 + mb
       drawLine d dr gc (x1 + p1) (ht - lc') (x2 + p2) (ht - lc')
-    BBLeft   -> drawLine d dr gc (x1 - 1) p1 (x1 - 1) (ht + p2)
-    BBRight  -> drawLine d dr gc (x2 + lc - 1) p1 (x2 + lc - 1) (ht + p2)
+    BBLeft   -> drawLine d dr gc (x1 - 1 + ml) p1 (x1 - 1 + ml) (ht + p2)
+    BBRight  -> drawLine d dr gc (x2 + lc - 1 - mr) p1 (x2 + lc - 1 - mr) (ht + p2)
diff --git a/src/Xmobar/X11/Parsers.hs b/src/Xmobar/X11/Parsers.hs
index 7fa5c00..d35cfa0 100644
--- a/src/Xmobar/X11/Parsers.hs
+++ b/src/Xmobar/X11/Parsers.hs
@@ -14,7 +14,8 @@
 --
 -----------------------------------------------------------------------------
 
-module Xmobar.X11.Parsers (parseString, Box(..), BoxBorder(..), TextRenderInfo(..), Widget(..)) where
+module Xmobar.X11.Parsers (parseString, Box(..), BoxBorder(..), BoxOffset(..),
+  BoxMargins(..), TextRenderInfo(..), Widget(..)) where
 
 import Xmobar.Config.Types
 import Xmobar.X11.Actions
@@ -29,6 +30,9 @@ import Foreign.C.Types (CInt)
 
 data Widget = Icon String | Text String
 
+data BoxOffset = BoxOffset Align Int32 deriving Eq 
+-- margins: Top, Right, Bottom, Left
+data BoxMargins = BoxMargins Int32 Int32 Int32 Int32 deriving Eq
 data BoxBorder = BBTop
                | BBBottom
                | BBVBoth
@@ -37,19 +41,7 @@ data BoxBorder = BBTop
                | 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 Box = Box BoxBorder BoxOffset CInt String BoxMargins deriving Eq
 data TextRenderInfo =
     TextRenderInfo { tColorsString   :: String
                    , tBgTopOffset    :: Int32
@@ -94,7 +86,7 @@ textParser c f a = do s <- many1 $
                             noneOf "<" <|>
                               try (notFollowedBy' (char '<')
                                     (try (string "fc=")  <|>
-                                     try (string "box=")  <|>
+                                     try (string "box")  <|>
                                      try (string "fn=")  <|>
                                      try (string "action=") <|>
                                      try (string "/action>") <|>
@@ -177,13 +169,42 @@ colorParser (TextRenderInfo _ _ _ bs) f a = do
 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
+  c <- between (string "<box") (string ">") (option "" (many1 (alphaNum <|> char '=' <|> char ' ' <|> char '#' <|> char ',')))
+  let b = Box BBFull (BoxOffset C 0) 1 cs (BoxMargins 0 0 0 0)
+  let g = boxReader b (words c)
   s <- manyTill
-       (allParsers (TextRenderInfo cs ot ob (b : bs)) f a)
+       (allParsers (TextRenderInfo cs ot ob (g : bs)) f a)
        (try $ string "</box>")
   return (concat s)
+
+boxReader :: Box -> [String] -> Box
+boxReader b [] = b
+boxReader b (x:xs) = do
+  let (param,val) = case break (=='=') x of
+                 (p,'=':v) -> (p, v)
+                 (p,    _) -> (p, "")
+  boxReader (boxParamReader b param val) xs
  
+boxParamReader :: Box -> String -> String -> Box
+boxParamReader b _ "" = b
+boxParamReader (Box bb off lw fc mgs) "type" val = 
+  Box (fromMaybe bb $ readMaybe ("BB" ++ val)) off lw fc mgs
+boxParamReader (Box bb (BoxOffset alg off) lw fc mgs) "offset" (a:o) =
+  Box bb (BoxOffset (fromMaybe alg $ readMaybe [a]) (fromMaybe off $ readMaybe o)) lw fc mgs
+boxParamReader (Box bb off lw fc mgs) "width" val = 
+  Box bb off (fromMaybe lw $ readMaybe val) fc mgs
+boxParamReader (Box bb off lw _ mgs) "color" val = 
+  Box bb off lw val mgs
+boxParamReader (Box bb off lw fc mgs@(BoxMargins mt mr mb ml)) ('m':pos) val = do
+  let mgs' = case pos of
+         "t" -> BoxMargins (fromMaybe mt $ readMaybe val) mr mb ml
+         "r" -> BoxMargins mt (fromMaybe mr $ readMaybe val) mb ml
+         "b" -> BoxMargins mt mr (fromMaybe mb $ readMaybe val) ml
+         "l" -> BoxMargins mt mr mb (fromMaybe ml $ readMaybe val)
+         _ -> mgs
+  Box bb off lw fc mgs'
+boxParamReader b _ _ = b
+
 -- | Parsers a string wrapped in a font specification.
 fontParser :: TextRenderInfo -> Maybe [Action]
               -> Parser [(Widget, TextRenderInfo, FontIndex, Maybe [Action])]