diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 = "\n" +mail = "\n" license :: String license = "\nThis program is distributed in the hope that it will be useful,\n" ++ diff --git a/Parsers.hs b/Parsers.hs --- a/Parsers.hs +++ b/Parsers.hs @@ -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 " 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 "") - 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 "") colors + s <- manyTill (textParser c <|> colorParser) (try $ string "") + 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 diff --git a/Plugins/Monitors/Common.hs b/Plugins/Monitors/Common.hs --- a/Plugins/Monitors/Common.hs +++ b/Plugins/Monitors/Common.hs @@ -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 "") <|> try ( + do string " char ',' <|> char '#') + char '>' + return $ "") + -- | 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 diff --git a/README b/README --- a/README +++ b/README @@ -29,7 +29,7 @@ The latest binary can be found here: - + 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: + + + + 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 ------------ diff --git a/XUtil.hsc b/XUtil.hsc --- a/XUtil.hsc +++ b/XUtil.hsc @@ -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. diff --git a/Xmobar.hs b/Xmobar.hs --- a/Xmobar.hs +++ b/Xmobar.hs @@ -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 diff --git a/xmobar.cabal b/xmobar.cabal --- a/xmobar.cabal +++ b/xmobar.cabal @@ -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