diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/Bitmap.hs | 6 | ||||
| -rw-r--r-- | src/Config.hs | 2 | ||||
| -rw-r--r-- | src/Main.hs | 3 | ||||
| -rw-r--r-- | src/Parsers.hs | 109 | ||||
| -rw-r--r-- | src/Xmobar.hs | 47 |
5 files changed, 97 insertions, 70 deletions
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 |