Support for multiple fonts

1 files changed, 66 insertions, 43 deletions

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 ",}"