summaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
-rw-r--r--readme.md7
-rw-r--r--src/Bitmap.hs6
-rw-r--r--src/Config.hs2
-rw-r--r--src/Main.hs3
-rw-r--r--src/Parsers.hs109
-rw-r--r--src/Xmobar.hs47
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