From 43d1dc71f9900986168458d3af281453f41df966 Mon Sep 17 00:00:00 2001 From: Unoqwy Date: Fri, 24 Jul 2020 01:53:15 +0200 Subject: Allow font bg to be taller (or smaller) Implemented only for XFT fonts. Adds a new "part" in the fc tag. > Example: foo bar will make the font background as tall as the bar (absolute offset, here set to 0 for both top & bottom) Changes ColorString to ColorInfo, containing both top and bottom offsets. The "colors string" is still in only one string. --- src/Xmobar/App/EventLoop.hs | 6 ++--- src/Xmobar/X11/Bitmap.hs | 4 ++-- src/Xmobar/X11/Draw.hs | 26 +++++++++++++-------- src/Xmobar/X11/Parsers.hs | 57 ++++++++++++++++++++++++++++----------------- 4 files changed, 56 insertions(+), 37 deletions(-) diff --git a/src/Xmobar/App/EventLoop.hs b/src/Xmobar/App/EventLoop.hs index e6232cd..2b33768 100644 --- a/src/Xmobar/App/EventLoop.hs +++ b/src/Xmobar/App/EventLoop.hs @@ -250,17 +250,17 @@ startCommand sig (com,s,ss) where is = s ++ "Updating..." ++ ss updateString :: Config -> TVar [String] - -> IO [[(Widget, String, Int, Maybe [Action])]] + -> IO [[(Widget, ColorInfo, Int, Maybe [Action])]] updateString conf v = do s <- readTVarIO v let l:c:r:_ = s ++ repeat "" liftIO $ mapM (parseString conf) [l, c, r] -updateActions :: XConf -> Rectangle -> [[(Widget, String, Int, Maybe [Action])]] +updateActions :: XConf -> Rectangle -> [[(Widget, ColorInfo, Int, Maybe [Action])]] -> IO [([Action], Position, Position)] updateActions conf (Rectangle _ _ wid _) ~[left,center,right] = do let (d,fs) = (display &&& fontListS) conf - strLn :: [(Widget, String, Int, Maybe [Action])] -> IO [(Maybe [Action], Position, Position)] + strLn :: [(Widget, ColorInfo, Int, Maybe [Action])] -> IO [(Maybe [Action], Position, Position)] strLn = liftIO . mapM getCoords iconW i = maybe 0 Bitmap.width (lookup i $ iconS conf) getCoords (Text s,_,i,a) = textWidth d (safeIndex fs i) s >>= \tw -> return (a, 0, fi tw) diff --git a/src/Xmobar/X11/Bitmap.hs b/src/Xmobar/X11/Bitmap.hs index e323606..e764384 100644 --- a/src/Xmobar/X11/Bitmap.hs +++ b/src/Xmobar/X11/Bitmap.hs @@ -24,7 +24,7 @@ import System.Directory (doesFileExist) import System.FilePath (()) import System.Mem.Weak ( addFinalizer ) import Xmobar.X11.ColorCache -import Xmobar.X11.Parsers (Widget(..)) +import Xmobar.X11.Parsers (ColorInfo(..), Widget(..)) import Xmobar.X11.Actions (Action) #ifdef XPM @@ -54,7 +54,7 @@ data Bitmap = Bitmap { width :: Dimension } updateCache :: Display -> Window -> Map FilePath Bitmap -> FilePath -> - [[(Widget, String, Int, Maybe [Action])]] -> IO (Map FilePath Bitmap) + [[(Widget, ColorInfo, 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 diff --git a/src/Xmobar/X11/Draw.hs b/src/Xmobar/X11/Draw.hs index ab7c6df..003f579 100644 --- a/src/Xmobar/X11/Draw.hs +++ b/src/Xmobar/X11/Draw.hs @@ -36,7 +36,7 @@ import Xmobar.X11.Types import Xmobar.X11.Text import Xmobar.X11.ColorCache import Xmobar.X11.Window (drawBorder) -import Xmobar.X11.Parsers (Widget(..)) +import Xmobar.X11.Parsers (ColorInfo(..), Widget(..)) import Xmobar.System.Utils (safeIndex) #ifdef XFT @@ -48,7 +48,7 @@ fi :: (Integral a, Num b) => a -> b fi = fromIntegral -- | Draws in and updates the window -drawInWin :: Rectangle -> [[(Widget, String, Int, Maybe [Action])]] -> X () +drawInWin :: Rectangle -> [[(Widget, ColorInfo, Int, Maybe [Action])]] -> X () drawInWin wr@(Rectangle _ _ wid ht) ~[left,center,right] = do r <- ask let (c,d) = (config &&& display) r @@ -102,33 +102,35 @@ verticalOffset ht (Icon _) _ _ conf | otherwise = return $ fi (ht `div` 2) - 1 printString :: Display -> Drawable -> XFont -> GC -> String -> String - -> Position -> Position -> String -> Int -> IO () -printString d p (Core fs) gc fc bc x y s a = do + -> Position -> Position -> Position -> Position -> String -> Int -> IO () +printString d p (Core fs) gc fc bc x y ay ht s a = do setFont d gc $ fontFromFontStruct fs withColors d [fc, bc] $ \[fc', bc'] -> do setForeground d gc fc' when (a == 255) (setBackground d gc bc') drawImageString d p gc x y s -printString d p (Utf8 fs) gc fc bc x y s a = +printString d p (Utf8 fs) gc fc bc x y ay ht s a = withColors d [fc, bc] $ \[fc', bc'] -> do setForeground d gc fc' when (a == 255) (setBackground d gc bc') liftIO $ wcDrawImageString d p fs gc x y s #ifdef XFT -printString dpy drw fs@(Xft fonts) _ fc bc x y s al = +printString dpy drw fs@(Xft fonts) _ fc bc x y ay ht s al = withDrawingColors dpy drw fc bc $ \draw fc' bc' -> do when (al == 255) $ do (a,d) <- textExtents fs s gi <- xftTxtExtents' dpy fonts s - drawXftRect draw bc' x (y - a) (1 + xglyphinfo_xOff gi) (a + d + 2) + if ay < 0 + then drawXftRect draw bc' x (y - a) (1 + xglyphinfo_xOff gi) (a + d + 2) + else drawXftRect draw bc' x ay (1 + xglyphinfo_xOff gi) ht drawXftString' draw fc' fonts (toInteger x) (toInteger y) s #endif -- | An easy way to print the stuff we need to print printStrings :: Drawable -> GC -> NE.NonEmpty XFont -> [Int] -> Position - -> Align -> [(Widget, String, Int, Position)] -> X () + -> Align -> [(Widget, ColorInfo, Int, Position)] -> X () printStrings _ _ _ _ _ _ [] = return () printStrings dr gc fontlist voffs offs a sl@((s,c,i,l):xs) = do r <- ask @@ -142,12 +144,16 @@ printStrings dr gc fontlist voffs offs a sl@((s,c,i,l):xs) = do C -> (remWidth + offs) `div` 2 R -> remWidth L -> offs - (fc,bc) = case break (==',') c of + (fc,bc) = case break (==',') (colorsString c) of (f,',':b) -> (f, b ) (f, _) -> (f, bgColor conf) valign <- verticalOffset ht s (NE.head fontlist) (voffs !! i) conf + let (ht',ay) = case (bgTopOffset c, bgBottomOffset c) of + (-1,_) -> (0, -1) + (_,-1) -> (0, -1) + (ot,ob) -> ((fromIntegral ht) - ot - ob, ob) case s of - (Text t) -> liftIO $ printString d dr fontst gc fc bc offset valign t alph + (Text t) -> liftIO $ printString d dr fontst gc fc bc offset valign ay ht' t alph (Icon p) -> liftIO $ maybe (return ()) (B.drawBitmap d dr gc fc bc offset valign) (lookup p (iconS r)) diff --git a/src/Xmobar/X11/Parsers.hs b/src/Xmobar/X11/Parsers.hs index 1d486d9..175de8c 100644 --- a/src/Xmobar/X11/Parsers.hs +++ b/src/Xmobar/X11/Parsers.hs @@ -14,37 +14,44 @@ -- ----------------------------------------------------------------------------- -module Xmobar.X11.Parsers (parseString, Widget(..)) where +module Xmobar.X11.Parsers (parseString, ColorInfo(..), Widget(..)) where import Xmobar.Config.Types import Xmobar.X11.Actions import Control.Monad (guard, mzero) import Data.Maybe (fromMaybe) +import Data.Int (Int32) import Text.ParserCombinators.Parsec import Text.Read (readMaybe) import Graphics.X11.Types (Button) data Widget = Icon String | Text String -type ColorString = String +type AbsBgOffset = Int32 +data ColorInfo = + ColorInfo { colorsString :: String + , bgTopOffset :: AbsBgOffset + , bgBottomOffset :: AbsBgOffset + } deriving Show type FontIndex = Int -- | Runs the string parser parseString :: Config -> String - -> IO [(Widget, ColorString, FontIndex, Maybe [Action])] + -> IO [(Widget, ColorInfo, FontIndex, Maybe [Action])] parseString c s = - case parse (stringParser (fgColor c) 0 Nothing) "" s of + case parse (stringParser ci 0 Nothing) "" s of Left _ -> return [(Text $ "Could not parse string: " ++ s - , fgColor c + , ci , 0 , Nothing)] Right x -> return (concat x) + where ci = ColorInfo (fgColor c) 0 0 -allParsers :: ColorString +allParsers :: ColorInfo -> FontIndex -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] + -> Parser [(Widget, ColorInfo, FontIndex, Maybe [Action])] allParsers c f a = textParser c f a <|> try (iconParser c f a) <|> try (rawParser c f a) @@ -53,13 +60,13 @@ allParsers c f a = textParser c f a <|> colorParser f a -- | Gets the string and combines the needed parsers -stringParser :: String -> FontIndex -> Maybe [Action] - -> Parser [[(Widget, ColorString, FontIndex, Maybe [Action])]] +stringParser :: ColorInfo -> FontIndex -> Maybe [Action] + -> Parser [[(Widget, ColorInfo, FontIndex, Maybe [Action])]] stringParser c f a = manyTill (allParsers c f a) eof -- | Parses a maximal string without markup. -textParser :: String -> FontIndex -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] +textParser :: ColorInfo -> FontIndex -> Maybe [Action] + -> Parser [(Widget, ColorInfo, FontIndex, Maybe [Action])] textParser c f a = do s <- many1 $ noneOf "<" <|> try (notFollowedBy' (char '<') @@ -78,10 +85,10 @@ textParser c f a = do s <- many1 $ -- string of digits (base 10) denoting the length of the raw string, -- a literal ":" as digit-string-terminator, the raw string itself, and -- then a literal "/>". -rawParser :: ColorString +rawParser :: ColorInfo -> FontIndex -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] + -> Parser [(Widget, ColorInfo, FontIndex, Maybe [Action])] rawParser c f a = do string "> return '*') return x -iconParser :: String -> FontIndex -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] +iconParser :: ColorInfo -> FontIndex -> Maybe [Action] + -> Parser [(Widget, ColorInfo, FontIndex, Maybe [Action])] iconParser c f a = do string "") (try (string "/>")) return [(Icon i, c, f, a)] -actionParser :: String -> FontIndex -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] +actionParser :: ColorInfo -> FontIndex -> Maybe [Action] + -> Parser [(Widget, ColorInfo, FontIndex, Maybe [Action])] actionParser c f act = do string " read [x]) -- | Parsers a string wrapped in a color specification. colorParser :: FontIndex -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] + -> Parser [(Widget, ColorInfo, FontIndex, Maybe [Action])] colorParser f a = do c <- between (string "") colors - s <- manyTill (allParsers c f a) (try $ string "") + let colorParts = break (==':') c + let (ot,ob) = case break (==',') (Prelude.drop 1 $ snd colorParts) of + (top,',':btm) -> (top, btm) + (top, _) -> (top, top) + s <- manyTill + (allParsers (ColorInfo (fst colorParts) (fromMaybe (-1) $ readMaybe ot) (fromMaybe (-1) $ readMaybe ob)) f a) + (try $ string "") return (concat s) -- | Parsers a string wrapped in a font specification. -fontParser :: ColorString -> Maybe [Action] - -> Parser [(Widget, ColorString, FontIndex, Maybe [Action])] +fontParser :: ColorInfo -> Maybe [Action] + -> Parser [(Widget, ColorInfo, FontIndex, Maybe [Action])] fontParser c a = do f <- between (string "") colors s <- manyTill (allParsers c (fromMaybe 0 $ readMaybe f) a) (try $ string "") @@ -145,4 +158,4 @@ fontParser c a = do -- | Parses a color specification (hex or named) colors :: Parser String -colors = many1 (alphaNum <|> char ',' <|> char '#') +colors = many1 (alphaNum <|> char ',' <|> char ':' <|> char '#') -- cgit v1.2.3