xmobar 0.9.1 → 0.9.2
raw patch · 7 files changed
+122/−89 lines, 7 files
Files
- Main.hs +2/−2
- Parsers.hs +25/−31
- Plugins/Monitors/Common.hs +18/−7
- README +12/−2
- XUtil.hsc +44/−26
- Xmobar.hs +19/−19
- xmobar.cabal +2/−2
Main.hs view
@@ -117,10 +117,10 @@ footer = "\nMail bug reports and suggestions to " ++ mail info :: String-info = "xmobar " ++ showVersion version ++ " (C) 2007 - 2008 Andrea Rossato " ++ mail ++ license+info = "xmobar " ++ showVersion version ++ " (C) 2007 - 2009 Andrea Rossato " ++ mail ++ license mail :: String-mail = "<andrea.rossato@ing.unitn.it>\n"+mail = "<andrea.rossato@unitn.it>\n" license :: String license = "\nThis program is distributed in the hope that it will be useful,\n" ++
Parsers.hs view
@@ -14,12 +14,6 @@ module Parsers ( parseString- , stringParser- , colorParser- , colorsAndText- , templateStringParser- , templateCommandParser- , templateParser , parseTemplate ) where @@ -32,28 +26,37 @@ -- | Runs the string parser parseString :: Config -> String -> IO [(String, String)] parseString c s =- case parse (stringParser c) "" s of+ case parse (stringParser (fgColor c)) "" s of Left _ -> return [("Could not parse string: " ++ s, fgColor c)] Right x -> return (concat x) -- | Gets the string and combines the needed parsers-stringParser :: Config -> Parser [[(String, String)]]-stringParser = flip manyTill eof . colorParser+stringParser :: String -> Parser [[(String, String)]]+stringParser c = manyTill (textParser c <|> colorParser) eof --- | Parses a string with the default color (no color set)-colorParser :: Config -> Parser [(String, String)]-colorParser c = do- s <- manyTill anyChar (tryString "<fc" <|> endOfLine "")- n <- colorsAndText <|> endOfLine ("","")- return [(s,fgColor c),n]+-- | Parses a maximal string without color markup.+textParser :: String -> Parser [(String, String)]+textParser c = do s <- many1 $+ noneOf "<" <|>+ ( try $ notFollowedBy' (char '<')+ (string "fc=" <|> string "/fc>" ) )+ return [(s, c)] --- | Parses a string with a color set-colorsAndText :: Parser (String, String)-colorsAndText = do- c <- inside (string "=") colors (string ">")- s <- manyTill anyChar (tryString "</fc>")- return (s,c)+-- | Wrapper for notFollowedBy that returns the result of the first parser.+-- Also works around the issue that, at least in Parsec 3.0.0, notFollowedBy+-- accepts only parsers with return type Char.+notFollowedBy' :: Parser a -> Parser b -> Parser a+notFollowedBy' p e = do x <- p+ notFollowedBy (e >> return '*')+ return x +-- | Parsers a string wrapped in a color specification.+colorParser :: Parser [(String, String)]+colorParser = do+ c <- between (string "<fc=") (string ">") colors+ s <- manyTill (textParser c <|> colorParser) (try $ string "</fc>")+ return (concat s)+ -- | Parses a color specification (hex or named) colors :: Parser String colors = many1 (alphaNum <|> char ',' <|> char '#')@@ -70,7 +73,7 @@ templateCommandParser :: Config -> Parser String templateCommandParser c = let chr = char . head . sepChar- in inside (chr c) (allTillSep c) (chr c)+ in between (chr c) (chr c) (allTillSep c) -- | Combines the template parsers templateParser :: Config -> Parser [(String,String,String)]@@ -94,14 +97,5 @@ where com = Map.findWithDefault dflt ts m dflt = Run $ Com ts [] [] 10 -endOfLine :: a -> Parser a-endOfLine r = eof >> return r--tryString :: String -> Parser String-tryString = try . string- allTillSep :: Config -> Parser String allTillSep = many . noneOf . sepChar--inside :: Parser a -> Parser b -> Parser c -> Parser b-inside pa pb pc = pa >> pb >>= \r -> pc >> return r
Plugins/Monitors/Common.hs view
@@ -196,19 +196,30 @@ -- | Parses the output template string templateStringParser :: Parser (String,String,String) templateStringParser =- do{ s <- many $ noneOf "<"- ; (_,com,_) <- templateCommandParser- ; ss <- many $ noneOf "<"- ; return (s, com, ss)- } + do { s <- nonPlaceHolder+ ; com <- templateCommandParser+ ; ss <- nonPlaceHolder+ ; return (s, com, ss)+ } + where+ nonPlaceHolder = liftM concat . many $+ (many1 $ noneOf "<") <|> colorSpec +-- | Recognizes color specification and returns it unchanged+colorSpec :: Parser String+colorSpec = (try $ string "</fc>") <|> try (+ do string "<fc="+ s <- many1 (alphaNum <|> char ',' <|> char '#')+ char '>'+ return $ "<fc=" ++ s ++ ">")+ -- | Parses the command part of the template string-templateCommandParser :: Parser (String,String,String)+templateCommandParser :: Parser String templateCommandParser = do { char '<' ; com <- many $ noneOf ">" ; char '>'- ; return $ ("",com,"")+ ; return com } -- | Combines the template parsers
README view
@@ -29,7 +29,7 @@ The latest binary can be found here: -<http://code.haskell.org/~arossato/xmobar/xmobar-0.9.bin>+<http://code.haskell.org/~arossato/xmobar/xmobar-0.9.2.bin> A recent screen shot can be found here: @@ -38,6 +38,15 @@ Version 0.9 requires Cabal-1.2.x, but should work both with ghc-6.6.1 and ghc-6.8.1. +Bug Reports+-----------++To submit bug reports you can use the Google code bug tracking system+available at the following address:++<http://code.google.com/p/xmobar/issues>++ Installation ------------ @@ -529,7 +538,8 @@ least for letting me think I grasp existential types...;-). [xmobar] incorporates patches from: Krzysztof Kosciuszkiewicz, Spencer-Janssen, Jens Petersen, Dmitry Kurochkin, and Lennart Kolmodin.+Janssen, Jens Petersen, Dmitry Kurochkin, Lennart Kolmodin, and+Norbert Zeh. Useful links ------------
XUtil.hsc view
@@ -27,6 +27,7 @@ , hGetLineSafe , io , fi+ , withColors ) where import Control.Concurrent@@ -147,42 +148,59 @@ -> Position -> Position -> String -> IO () printString d p (Core fs) gc fc bc x y s = do setFont d gc $ fontFromFontStruct fs- [fc',bc'] <- mapM (initColor d) [fc,bc]- setForeground d gc fc'- setBackground d gc bc'- drawImageString d p gc x y s-printString d p (Utf8 fs) gc fc bc x y s = do- [fc',bc'] <- mapM (initColor d) [fc,bc]- setForeground d gc fc'- setBackground d gc bc'- io $ wcDrawImageString d p fs gc x y s+ withColors d [fc, bc] $ \[fc', bc'] -> do+ setForeground d gc fc'+ setBackground d gc bc'+ drawImageString d p gc x y s++printString d p (Utf8 fs) gc fc bc x y s =+ withColors d [fc, bc] $ \[fc', bc'] -> do+ setForeground d gc fc'+ setBackground d gc bc'+ io $ wcDrawImageString d p fs gc x y s+ #ifdef XFT printString dpy drw fs@(Xft font) gc fc bc x y s = do let screen = defaultScreenOfDisplay dpy colormap = defaultColormapOfScreen screen visual = defaultVisualOfScreen screen- bcolor <- initColor dpy bc- (a,d) <- textExtents fs s- gi <- xftTextExtents dpy font s- setForeground dpy gc bcolor- fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi))- (y - fi a)- (fi $ xglyphinfo_xOff gi)- (fi $ a + d)- withXftDraw dpy drw visual colormap $- \draw -> withXftColorName dpy visual colormap fc $- \color -> xftDrawString draw color font x y s+ withColors dpy [bc] $ \[bcolor] -> do+ (a,d) <- textExtents fs s+ gi <- xftTextExtents dpy font s+ setForeground dpy gc bcolor+ fillRectangle dpy drw gc (x - fi (xglyphinfo_x gi))+ (y - fi a)+ (fi $ xglyphinfo_xOff gi)+ (fi $ a + d)+ withXftDraw dpy drw visual colormap $+ \draw -> withXftColorName dpy visual colormap fc $+ \color -> xftDrawString draw color font x y s #endif +data DynPixel = DynPixel { allocated :: Bool+ , pixel :: Pixel+ }+ -- | Get the Pixel value for a named color: if an invalid name is -- given the black pixel will be returned.-initColor :: Display -> String -> IO Pixel-initColor dpy c =- catch (initColor' dpy c) (const . return . blackPixel dpy $ (defaultScreen dpy))+initColor :: Display -> String -> IO DynPixel+initColor dpy c = (initColor' dpy c) `catch`+ (const . return $ DynPixel False (blackPixel dpy $ defaultScreen dpy)) -initColor' :: Display -> String -> IO Pixel-initColor' dpy c = (color_pixel . fst) `liftM` allocNamedColor dpy colormap c- where colormap = defaultColormap dpy (defaultScreen dpy)+initColor' :: Display -> String -> IO DynPixel+initColor' dpy c = do+ (c', _) <- allocNamedColor dpy colormap c+ return $ DynPixel True (color_pixel c')+ where colormap = defaultColormap dpy (defaultScreen dpy)++withColors :: MonadIO m => Display -> [String] -> ([Pixel] -> m a) -> m a+withColors d cs f = do+ ps <- mapM (io . initColor d) cs+ r <- f $ map pixel ps+ io $ freeColors d cmap (map pixel $ filter allocated ps) 0+ return r+ where+ cmap = defaultColormap d (defaultScreen d) -- | Creates a window with the attribute override_redirect set to True. -- Windows Managers should not touch this kind of windows.
Xmobar.hs view
@@ -233,25 +233,25 @@ let (c,d ) = (config &&& display) r (w,fs) = (window &&& fontS ) r strLn = io . mapM (\(s,cl) -> textWidth d fs s >>= \tw -> return (s,cl,fi tw))- bgcolor <- io $ initColor d $ bgColor c- gc <- io $ createGC d w- -- create a pixmap to write to and fill it with a rectangle- p <- io $ createPixmap d w wid ht- (defaultDepthOfScreen (defaultScreenOfDisplay d))- -- the fgcolor of the rectangle will be the bgcolor of the window- io $ setForeground d gc bgcolor- io $ fillRectangle d p gc 0 0 wid ht- -- write to the pixmap the new string- printStrings p gc fs 1 L =<< strLn left- printStrings p gc fs 1 R =<< strLn right- printStrings p gc fs 1 C =<< strLn center- -- copy the pixmap with the new string to the window- io $ copyArea d p w gc 0 0 wid ht 0 0- -- free up everything (we do not want to leak memory!)- io $ freeGC d gc- io $ freePixmap d p- -- resync- io $ sync d True+ withColors d [bgColor c] $ \[bgcolor] -> do+ gc <- io $ createGC d w+ -- create a pixmap to write to and fill it with a rectangle+ p <- io $ createPixmap d w wid ht+ (defaultDepthOfScreen (defaultScreenOfDisplay d))+ -- the fgcolor of the rectangle will be the bgcolor of the window+ io $ setForeground d gc bgcolor+ io $ fillRectangle d p gc 0 0 wid ht+ -- write to the pixmap the new string+ printStrings p gc fs 1 L =<< strLn left+ printStrings p gc fs 1 R =<< strLn right+ printStrings p gc fs 1 C =<< strLn center+ -- copy the pixmap with the new string to the window+ io $ copyArea d p w gc 0 0 wid ht 0 0+ -- free up everything (we do not want to leak memory!)+ io $ freeGC d gc+ io $ freePixmap d p+ -- resync+ io $ sync d True -- | An easy way to print the stuff we need to print printStrings :: Drawable -> GC -> XFont -> Position
xmobar.cabal view
@@ -1,5 +1,5 @@ name: xmobar-version: 0.9.1+version: 0.9.2 homepage: http://code.haskell.org/~arossato/xmobar synopsis: A Minimalistic Text Based Status Bar description: Xmobar is a minimalistic text based status bar.@@ -11,7 +11,7 @@ license: BSD3 license-file: LICENSE author: Andrea Rossato-maintainer: andrea.rossato@unibz.it+maintainer: andrea.rossato@unitn.it cabal-version: >= 1.2 build-type: Simple