Support for multiple fonts

6 files changed, 104 insertions, 70 deletions

diff --git a/readme.md b/readme.md
index 381dbbc..3db4955 100644
--- a/readme.md
+++ b/readme.md
@@ -198,6 +198,9 @@ For the output template:
 - `<fc=#FF0000>string</fc>` will print `string` with `#FF0000` color
   (red).
 
+- `<fn=1>string</fn>` will print `string` with the first font from `fontList`.
+  The index `0` corresponds to the standard font.
+
 - `<icon=/path/to/icon.xbm/>` will insert the given bitmap. XPM image
   format is also supported when compiled with `--flags="with_xpm"`.
 
@@ -227,6 +230,10 @@ Other configuration options:
 `font`
 :    Name of the font to be used. Use the `xft:` prefix for XFT fonts.
 
+`fontList`
+:    Haskell-style list of fonts to be used with the `fn`-template.
+     Use the `xft:` prefix for XFT fonts.
+
 `bgColor`
 :    Background color.
 
diff --git a/src/Bitmap.hs b/src/Bitmap.hs
index ec99ad8..55ee42f 100644
--- a/src/Bitmap.hs
+++ b/src/Bitmap.hs
@@ -54,10 +54,10 @@ data Bitmap = Bitmap { width  :: Dimension
                      }
 
 updateCache :: Display -> Window -> Map FilePath Bitmap -> FilePath ->
-               [[(Widget, String, Maybe [Action])]] -> IO (Map FilePath Bitmap)
+               [[(Widget, String, 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
+  let paths = map (\(Icon p, _, _, _) -> p) . concatMap (filter icons) $ ps
+      icons (Icon _, _, _, _) = True
       icons _ = False
       expandPath path@('/':_) = path
       expandPath path@('.':'/':_) = path
diff --git a/src/Config.hs b/src/Config.hs
index 6353112..7929011 100644
--- a/src/Config.hs
+++ b/src/Config.hs
@@ -49,6 +49,7 @@ import Plugins.DateZone
 -- | The configuration data type
 data Config =
     Config { font :: String         -- ^ Font
+           , fontList :: [String]   -- ^ List of alternative fonts
            , bgColor :: String      -- ^ Backgroud color
            , fgColor :: String      -- ^ Default font color
            , position :: XPosition  -- ^ Top Bottom or Static
@@ -110,6 +111,7 @@ data Border = NoBorder
 defaultConfig :: Config
 defaultConfig =
     Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*"
+           , fontList = []
            , bgColor = "#000000"
            , fgColor = "#BFBFBF"
            , alpha   = 255
diff --git a/src/Main.hs b/src/Main.hs
index 48df632..0eca0cb 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -59,12 +59,13 @@ main = do
 
   conf  <- doOpts c o
   fs    <- initFont d (font conf)
+  fl    <- mapM (initFont d) (fontList conf)
   cls   <- mapM (parseTemplate conf) (splitTemplate conf)
   sig   <- setupSignalHandler
   vars  <- mapM (mapM $ startCommand sig) cls
   (r,w) <- createWin d fs conf
   let ic = Map.empty
-  startLoop (XConf d r w fs ic conf) sig vars
+  startLoop (XConf d r w (fs:fl) ic conf) sig vars
 
 -- | Splits the template in its parts
 splitTemplate :: Config -> [String]
diff --git a/src/Parsers.hs b/src/Parsers.hs
index d2fa1bf..59a1dc7 100644
--- a/src/Parsers.hs
+++ b/src/Parsers.hs
@@ -34,44 +34,50 @@ import Graphics.X11.Types (Button)
 data Widget = Icon String | Text String
 
 type ColorString = String
+type FontIndex   = Int
 
 -- | Runs the string parser
-parseString :: Config -> String -> IO [(Widget, ColorString, Maybe [Action])]
+parseString :: Config -> String -> IO [(Widget, ColorString, FontIndex, Maybe [Action])]
 parseString c s =
-    case parse (stringParser (fgColor c) Nothing) "" s of
+    case parse (stringParser (fgColor c) 0 Nothing) "" s of
       Left  _ -> return [(Text $ "Could not parse string: " ++ s
                           , fgColor c
+                          , 0
                           , Nothing)]
       Right x -> return (concat x)
 
 allParsers :: ColorString
+           -> FontIndex
            -> Maybe [Action]
-           -> Parser [(Widget, ColorString, Maybe [Action])]
-allParsers c a =
-        textParser c a
-  <|> try (iconParser c a)
-  <|> try (rawParser c a)
-  <|> try (actionParser c a)
-  <|> colorParser a
+           -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]
+allParsers c f a =
+        textParser c f a
+  <|> try (iconParser c f a)
+  <|> try (rawParser c f a)
+  <|> try (actionParser c f a)
+  <|> try (fontParser c a)
+  <|> colorParser f a
 
 -- | Gets the string and combines the needed parsers
-stringParser :: String -> Maybe [Action]
-                -> Parser [[(Widget, ColorString, Maybe [Action])]]
-stringParser c a = manyTill (allParsers c a) eof
+stringParser :: String -> FontIndex -> Maybe [Action]
+                -> Parser [[(Widget, ColorString, FontIndex, Maybe [Action])]]
+stringParser c f a = manyTill (allParsers c f a) eof
 
 -- | Parses a maximal string without color markup.
-textParser :: String -> Maybe [Action]
-              -> Parser [(Widget, ColorString, Maybe [Action])]
-textParser c a = do s <- many1 $
-                          noneOf "<" <|>
-                            try (notFollowedBy' (char '<')
-                                  (try (string "fc=")  <|>
-                                   try (string "action=") <|>
-                                   try (string "/action>") <|>
-                                   try (string "icon=") <|>
-                                   try (string "raw=") <|>
-                                   string "/fc>"))
-                    return [(Text s, c, a)]
+textParser :: String -> FontIndex -> Maybe [Action]
+              -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]
+textParser c f a = do s <- many1 $
+                            noneOf "<" <|>
+                              try (notFollowedBy' (char '<')
+                                    (try (string "fc=")  <|>
+                                     try (string "fn=")  <|>
+                                     try (string "action=") <|>
+                                     try (string "/action>") <|>
+                                     try (string "icon=") <|>
+                                     try (string "raw=") <|>
+                                     try (string "/fn>") <|>
+                                     string "/fc>"))
+                      return [(Text s, c, f, a)]
 
 -- | Parse a "raw" tag, which we use to prevent other tags from creeping in.
 -- The format here is net-string-esque: a literal "<raw=" followed by a
@@ -79,9 +85,10 @@ textParser c a = do s <- many1 $
 -- a literal ":" as digit-string-terminator, the raw string itself, and
 -- then a literal "/>".
 rawParser :: ColorString
+          -> FontIndex
           -> Maybe [Action]
-          -> Parser [(Widget, ColorString, Maybe [Action])]
-rawParser c a = do
+          -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]
+rawParser c f a = do
   string "<raw="
   lenstr <- many1 digit
   char ':'
@@ -90,7 +97,7 @@ rawParser c a = do
       guard ((len :: Integer) <= fromIntegral (maxBound :: Int))
       s <- count (fromIntegral len) anyChar
       string "/>"
-      return [(Text s, c, a)]
+      return [(Text s, c, f, a)]
     _ -> mzero
 
 -- | Wrapper for notFollowedBy that returns the result of the first parser.
@@ -101,15 +108,15 @@ notFollowedBy' p e = do x <- p
                         notFollowedBy $ try (e >> return '*')
                         return x
 
-iconParser :: String -> Maybe [Action]
-              -> Parser [(Widget, ColorString, Maybe [Action])]
-iconParser c a = do
+iconParser :: String -> FontIndex -> Maybe [Action]
+              -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]
+iconParser c f a = do
   string "<icon="
   i <- manyTill (noneOf ">") (try (string "/>"))
-  return [(Icon i, c, a)]
+  return [(Icon i, c, f, a)]
 
-actionParser :: String -> Maybe [Action] -> Parser [(Widget, ColorString, Maybe [Action])]
-actionParser c act = do
+actionParser :: String -> FontIndex -> Maybe [Action] -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]
+actionParser c f act = do
   string "<action="
   command <- choice [between (char '`') (char '`') (many1 (noneOf "`")),
                    many1 (noneOf ">")]
@@ -119,17 +126,24 @@ actionParser c act = do
       a' = case act of
         Nothing -> Just [a]
         Just act' -> Just $ a : act'
-  s <- manyTill (allParsers c a') (try $ string "</action>")
+  s <- manyTill (allParsers c f a') (try $ string "</action>")
   return (concat s)
 
 toButtons :: String -> [Button]
 toButtons = map (\x -> read [x])
 
 -- | Parsers a string wrapped in a color specification.
-colorParser :: Maybe [Action] -> Parser [(Widget, ColorString, Maybe [Action])]
-colorParser a = do
+colorParser :: FontIndex -> Maybe [Action] -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])]
+colorParser f a = do
   c <- between (string "<fc=") (string ">") colors
-  s <- manyTill (allParsers c a) (try $ string "</fc>")
+  s <- manyTill (allParsers c 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 c a = do
+  f <- between (string "<fn=") (string ">") colors
+  s <- manyTill (allParsers c (read f) a) (try $ string "</fn>")
   return (concat s)
 
 -- | Parses a color specification (hex or named)
@@ -198,23 +212,24 @@ parseConfig = runParser parseConf fields "Config" . stripComments
         return (x,s)
 
       perms = permute $ Config
-              <$?> pFont <|?> pBgColor <|?> pFgColor <|?> pPosition
-              <|?> pTextOffset <|?> pIconOffset <|?> pBorder
+              <$?> pFont <|?> pFontList <|?> pBgColor <|?> pFgColor
+              <|?> pPosition <|?> pTextOffset <|?> pIconOffset <|?> pBorder
               <|?> pBdColor <|?> pBdWidth <|?> pAlpha <|?> pHideOnStart
               <|?> pAllDesktops <|?> pOverrideRedirect <|?> pPickBroadest
               <|?> pLowerOnStart <|?> pPersistent <|?> pIconRoot
               <|?> pCommands <|?> pSepChar <|?> pAlignSep <|?> pTemplate
 
 
-      fields    = [ "font", "bgColor", "fgColor", "sepChar", "alignSep"
-                  , "border", "borderColor" ,"template", "position"
-                  , "textOffset", "iconOffset"
+      fields    = [ "font", "fontList","bgColor", "fgColor", "sepChar"
+                  , "alignSep" , "border", "borderColor" ,"template"
+                  , "position" , "textOffset", "iconOffset"
                   , "allDesktops", "overrideRedirect", "pickBroadest"
                   , "hideOnStart", "lowerOnStart", "persistent", "iconRoot"
                   , "alpha", "commands"
                   ]
 
       pFont = strField font "font"
+      pFontList = strListField fontList "fontList"
       pBgColor = strField bgColor "bgColor"
       pFgColor = strField fgColor "fgColor"
       pBdColor = strField borderColor "borderColor"
@@ -253,7 +268,6 @@ parseConfig = runParser parseConf fields "Config" . stripComments
                       }
       readCommands = manyTill anyChar (try commandsEnd) >>=
                         read' commandsErr . flip (++) "]"
-
       strField e n = field e n strMulti
 
       strMulti = scan '"'
@@ -266,6 +280,15 @@ parseConfig = runParser parseConf fields "Config" . stripComments
             rowCont    = try $ char '\\' >> string "\n"
             unescQuote = lookAhead (noneOf "\\") >> lookAhead (string "\"")
 
+      strListField e n = field e n strList
+      strList = do
+        spaces
+        char '['
+        list <- sepBy (strMulti >>= \x -> spaces >> return x) (char ',')
+        spaces
+        char ']'
+        return list
+
       wrapSkip   x = many space >> x >>= \r -> many space >> return r
       sepEndSpc    = mapM_ (wrapSkip . try . string)
       fieldEnd     = many $ space <|> oneOf ",}"
diff --git a/src/Xmobar.hs b/src/Xmobar.hs
index 6d113f8..0d63b31 100644
--- a/src/Xmobar.hs
+++ b/src/Xmobar.hs
@@ -74,12 +74,12 @@ type X = ReaderT XConf IO
 
 -- | The ReaderT inner component
 data XConf =
-    XConf { display :: Display
-          , rect    :: Rectangle
-          , window  :: Window
-          , fontS   :: XFont
-          , iconS   :: Map FilePath Bitmap
-          , config  :: Config
+    XConf { display   :: Display
+          , rect      :: Rectangle
+          , window    :: Window
+          , fontListS :: [XFont]
+          , iconS     :: Map FilePath Bitmap
+          , config    :: Config
           }
 
 -- | Runs the ReaderT
@@ -201,7 +201,7 @@ eventLoop tv xc@(XConf d r w fs is cfg) as signal = do
             eventLoop tv xc as signal
 
         reposWindow rcfg = do
-          r' <- repositionWin d w fs rcfg
+          r' <- repositionWin d w (fs!!0) rcfg
           eventLoop tv (XConf d r' w fs is rcfg) as signal
 
         updateConfigPosition ocfg =
@@ -242,21 +242,21 @@ startCommand sig (com,s,ss)
     where is = s ++ "Updating..." ++ ss
 
 updateString :: Config -> TVar [String]
-                -> IO [[(Widget, String, Maybe [Action])]]
+                -> IO [[(Widget, String, Int, Maybe [Action])]]
 updateString conf v = do
   s <- atomically $ readTVar v
   let l:c:r:_ = s ++ repeat ""
   io $ mapM (parseString conf) [l, c, r]
 
-updateActions :: XConf -> Rectangle -> [[(Widget, String, Maybe [Action])]]
+updateActions :: XConf -> Rectangle -> [[(Widget, String, Int, Maybe [Action])]]
                  -> IO [([Action], Position, Position)]
 updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do
-  let (d,fs) = (display &&& fontS) conf
-      strLn :: [(Widget, String, Maybe [Action])] -> IO [(Maybe [Action], Position, Position)]
+  let (d,fs) = (display &&& fontListS) conf
+      strLn :: [(Widget, String, Int, Maybe [Action])] -> IO [(Maybe [Action], Position, Position)]
       strLn  = io . mapM getCoords
       iconW i = maybe 0 Bitmap.width (lookup i $ iconS conf)
-      getCoords (Text s,_,a) = textWidth d fs s >>= \tw -> return (a, 0, fi tw)
-      getCoords (Icon s,_,a) = return (a, 0, fi $ iconW s)
+      getCoords (Text s,_,i,a) = textWidth d (fs!!i) s >>= \tw -> return (a, 0, fi tw)
+      getCoords (Icon s,_,_,a) = return (a, 0, fi $ iconW s)
       partCoord off xs = map (\(a, x, x') -> (fromJust a, x, x')) $
                          filter (\(a, _,_) -> isJust a) $
                          scanl (\(_,_,x') (a,_,w') -> (a, x', x' + w'))
@@ -276,16 +276,16 @@ updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do
 -- $print
 
 -- | Draws in and updates the window
-drawInWin :: Rectangle -> [[(Widget, String, Maybe [Action])]] -> X ()
+drawInWin :: Rectangle -> [[(Widget, String, Int, Maybe [Action])]] -> X ()
 drawInWin wr@(Rectangle _ _ wid ht) ~[left,center,right] = do
   r <- ask
   let (c,d) = (config &&& display) r
-      (w,fs) = (window &&& fontS  ) r
+      (w,fs) = (window &&& fontListS  ) r
       strLn = io . mapM getWidth
       iconW i = maybe 0 Bitmap.width (lookup i $ iconS r)
-      getWidth (Text s,cl,_) =
-        textWidth d fs s >>= \tw -> return (Text s,cl,fi tw)
-      getWidth (Icon s,cl,_) = return (Icon s,cl,fi $ iconW s)
+      getWidth (Text s,cl,i,_) =
+        textWidth d (fs!!i) s >>= \tw -> return (Text s,cl,i,fi tw)
+      getWidth (Icon s,cl,i,_) = return (Icon s,cl,i,fi $ iconW s)
 
   p <- io $ createPixmap d w wid ht
                          (defaultDepthOfScreen (defaultScreenOfDisplay d))
@@ -325,16 +325,17 @@ verticalOffset _ (Icon _) _ conf
      return $ bwidth + 1
 
 -- | An easy way to print the stuff we need to print
-printStrings :: Drawable -> GC -> XFont -> Position
-             -> Align -> [(Widget, String, Position)] -> X ()
+printStrings :: Drawable -> GC -> [XFont] -> Position
+             -> Align -> [(Widget, String, Int, Position)] -> X ()
 printStrings _ _ _ _ _ [] = return ()
-printStrings dr gc fontst offs a sl@((s,c,l):xs) = do
+printStrings dr gc fontlist offs a sl@((s,c,i,l):xs) = do
   r <- ask
   let (conf,d) = (config &&& display) r
       alph = alpha conf
       Rectangle _ _ wid ht = rect r
-      totSLen = foldr (\(_,_,len) -> (+) len) 0 sl
+      totSLen = foldr (\(_,_,_,len) -> (+) len) 0 sl
       remWidth = fi wid - fi totSLen
+      fontst = fontlist !! i
       offset = case a of
                  C -> (remWidth + offs) `div` 2
                  R -> remWidth
@@ -348,4 +349,4 @@ printStrings dr gc fontst offs a sl@((s,c,l):xs) = do
     (Icon p) -> io $ maybe (return ())
                            (drawBitmap d dr gc fc bc offset valign)
                            (lookup p (iconS r))
-  printStrings dr gc fontst (offs + l) a xs
+  printStrings dr gc fontlist (offs + l) a xs