From 45126039c7d1a7c990e83c644df984823aff6656 Mon Sep 17 00:00:00 2001 From: Unoqwy Date: Sat, 25 Jul 2020 00:10:30 +0200 Subject: Add the tag to set borders around text --- src/Xmobar/X11/Draw.hs | 61 ++++++++++++++++++++++++++++++++++++++++------- src/Xmobar/X11/Parsers.hs | 58 +++++++++++++++++++++++++++++++++++--------- 2 files changed, 99 insertions(+), 20 deletions(-) diff --git a/src/Xmobar/X11/Draw.hs b/src/Xmobar/X11/Draw.hs index cd74872..8906da2 100644 --- a/src/Xmobar/X11/Draw.hs +++ b/src/Xmobar/X11/Draw.hs @@ -23,7 +23,8 @@ import Prelude hiding (lookup) import Control.Monad.IO.Class import Control.Monad.Reader import Control.Arrow ((&&&)) -import Data.Map hiding (foldr, map, filter) +import Data.Map hiding ((\\), foldr, map, filter) +import Data.List ((\\)) import qualified Data.List.NonEmpty as NE import Graphics.X11.Xlib hiding (textExtents, textWidth) @@ -36,7 +37,7 @@ import Xmobar.X11.Types import Xmobar.X11.Text import Xmobar.X11.ColorCache import Xmobar.X11.Window (drawBorder) -import Xmobar.X11.Parsers (TextRenderInfo(..), Widget(..)) +import Xmobar.X11.Parsers hiding (parseString) import Xmobar.System.Utils (safeIndex) #ifdef XFT @@ -76,9 +77,9 @@ drawInWin wr@(Rectangle _ _ wid ht) ~[left,center,right] = do liftIO $ setForeground d gc bgcolor liftIO $ fillRectangle d p gc 0 0 wid ht -- write to the pixmap the new string - printStrings p gc fs vs 1 L =<< strLn left - printStrings p gc fs vs 1 R =<< strLn right - printStrings p gc fs vs 1 C =<< strLn center + printStrings p gc fs vs 1 L [] =<< strLn left + printStrings p gc fs vs 1 R [] =<< strLn right + printStrings p gc fs vs 1 C [] =<< strLn center -- draw border if requested liftIO $ drawBorder (border c) (borderWidth c) d p gc bdcolor wid ht -- copy the pixmap with the new string to the window @@ -130,9 +131,9 @@ printString dpy drw fs@(Xft fonts) _ fc bc x y ay ht s al = -- | An easy way to print the stuff we need to print printStrings :: Drawable -> GC -> NE.NonEmpty XFont -> [Int] -> Position - -> Align -> [(Widget, TextRenderInfo, Int, Position)] -> X () -printStrings _ _ _ _ _ _ [] = return () -printStrings dr gc fontlist voffs offs a sl@((s,c,i,l):xs) = do + -> Align -> [((Position, Position), Box)] -> [(Widget, TextRenderInfo, Int, Position)] -> X () +printStrings _ _ _ _ _ _ _ [] = return () +printStrings dr gc fontlist voffs offs a boxes sl@((s,c,i,l):xs) = do r <- ask let (conf,d) = (config &&& display) r alph = alpha conf @@ -157,4 +158,46 @@ printStrings dr gc fontlist voffs offs a sl@((s,c,i,l):xs) = do (Icon p) -> liftIO $ maybe (return ()) (B.drawBitmap d dr gc fc bc offset valign) (lookup p (iconS r)) - printStrings dr gc fontlist voffs (offs + l) a xs + let x2 = offset + l - 1 + let triBoxes = tBoxes c + dropBoxes = filter (\(_,b) -> not(b `elem` triBoxes)) boxes + boxes' = map (\((x1,_),b) -> ((x1, x2), b)) (filter (\(_,b) -> b `elem` triBoxes) boxes) + ++ map (\b -> ((offset - 1, x2), b)) (triBoxes \\ (map snd boxes)) + if Prelude.null xs + then liftIO $ drawBoxes d dr gc (fromIntegral ht) (dropBoxes ++ boxes') + else liftIO $ drawBoxes d dr gc (fromIntegral ht) dropBoxes + printStrings dr gc fontlist voffs (offs + l) a boxes' xs + +drawBoxes :: Display -> Drawable -> GC -> Position -> [((Position, Position), Box)] -> IO () +drawBoxes _ _ _ _ [] = return () +drawBoxes d dr gc ht (b:bs) = do + let (xx, Box pos alg offset lineWidth fc) = b + withColors d [fc] $ \[fc'] -> do + setForeground d gc fc' + setLineAttributes d gc lineWidth lineSolid capNotLast joinMiter + case pos of + BBVBoth -> do + drawBoxBorder d dr gc BBTop alg offset ht xx + drawBoxBorder d dr gc BBBottom alg offset ht xx + BBHBoth -> do + drawBoxBorder d dr gc BBLeft alg offset ht xx + drawBoxBorder d dr gc BBRight alg offset ht xx + BBFull -> do + drawBoxBorder d dr gc BBTop alg offset ht xx + drawBoxBorder d dr gc BBBottom alg offset ht xx + drawBoxBorder d dr gc BBLeft alg offset ht xx + drawBoxBorder d dr gc BBRight alg offset ht xx + _ -> drawBoxBorder d dr gc pos alg offset ht xx + drawBoxes d dr gc ht bs + +drawBoxBorder :: Display -> Drawable -> GC -> BoxBorder -> Align -> Position -> Position -> (Position, Position) -> IO () +drawBoxBorder d dr gc pos alg offset ht (x1,x2) = do + let (p1,p2) = case alg of + L -> (0, (-offset)) + C -> (offset, (-offset)) + R -> (offset, 0 ) + case pos of + BBTop -> drawLine d dr gc (x1 + p1) 0 (x2 + p2) 0 + BBBottom -> drawLine d dr gc (x1 + p1) (ht - 1) (x2 + p2) (ht - 1) + BBLeft -> drawLine d dr gc x1 p1 x1 (ht + p2) + BBRight -> drawLine d dr gc x2 p1 x2 (ht + p2) diff --git a/src/Xmobar/X11/Parsers.hs b/src/Xmobar/X11/Parsers.hs index fded3b3..c25715c 100644 --- a/src/Xmobar/X11/Parsers.hs +++ b/src/Xmobar/X11/Parsers.hs @@ -14,7 +14,7 @@ -- ----------------------------------------------------------------------------- -module Xmobar.X11.Parsers (parseString, TextRenderInfo(..), Widget(..)) where +module Xmobar.X11.Parsers (parseString, Box(..), BoxBorder(..), TextRenderInfo(..), Widget(..)) where import Xmobar.Config.Types import Xmobar.X11.Actions @@ -25,15 +25,37 @@ import Data.Int (Int32) import Text.ParserCombinators.Parsec import Text.Read (readMaybe) import Graphics.X11.Types (Button) +import Foreign.C.Types (CInt) data Widget = Icon String | Text String -type AbsBgOffset = Int32 +data BoxBorder = BBTop + | BBBottom + | BBVBoth + | BBLeft + | BBRight + | BBHBoth + | BBFull + deriving ( Read, Eq ) +data Box = Box BoxBorder Align Int32 CInt String deriving ( Eq ) +instance Read Box where + readsPrec _ input = do + let b = case (words input) of + [pos] -> Just $ Box (read pos) C 0 1 "white" + [pos,alg] -> Just $ Box (read pos) (read alg) 0 1 "white" + [pos,alg,off] -> Just $ Box (read pos) (read alg) (read off) 1 "white" + [pos,alg,off,wdh] -> Just $ Box (read pos) (read alg) (read off) (read wdh) "white" + [pos,alg,off,wdh,c] -> Just $ Box (read pos) (read alg) (read off) (read wdh) c + _ -> Nothing + case b of + Just b' -> [(b', "")] + _ -> [] data TextRenderInfo = - TextRenderInfo { tColorsString :: String - , tBgTopOffset :: AbsBgOffset - , tBgBottomOffset :: AbsBgOffset - } deriving Show + TextRenderInfo { tColorsString :: String + , tBgTopOffset :: Int32 + , tBgBottomOffset :: Int32 + , tBoxes :: [Box] + } type FontIndex = Int -- | Runs the string parser @@ -46,7 +68,7 @@ parseString c s = , 0 , Nothing)] Right x -> return (concat x) - where ci = TextRenderInfo (fgColor c) 0 0 + where ci = TextRenderInfo (fgColor c) 0 0 [] allParsers :: TextRenderInfo -> FontIndex @@ -57,7 +79,8 @@ allParsers c f a = textParser c f a <|> try (rawParser c f a) <|> try (actionParser c f a) <|> try (fontParser c a) - <|> colorParser f a + <|> try (boxParser c f a) + <|> colorParser c f a -- | Gets the string and combines the needed parsers stringParser :: TextRenderInfo -> FontIndex -> Maybe [Action] @@ -71,12 +94,14 @@ textParser c f a = do s <- many1 $ noneOf "<" <|> try (notFollowedBy' (char '<') (try (string "fc=") <|> + try (string "box=") <|> try (string "fn=") <|> try (string "action=") <|> try (string "/action>") <|> try (string "icon=") <|> try (string "raw=") <|> try (string "/fn>") <|> + try (string "/box>") <|> string "/fc>")) return [(Text s, c, f, a)] @@ -135,19 +160,30 @@ toButtons :: String -> [Button] toButtons = map (\x -> read [x]) -- | Parsers a string wrapped in a color specification. -colorParser :: FontIndex -> Maybe [Action] +colorParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [(Widget, TextRenderInfo, FontIndex, Maybe [Action])] -colorParser f a = do +colorParser (TextRenderInfo _ _ _ bs) f a = do c <- between (string "") colors 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 (TextRenderInfo (fst colorParts) (fromMaybe (-1) $ readMaybe ot) (fromMaybe (-1) $ readMaybe ob)) f a) + (allParsers (TextRenderInfo (fst colorParts) (fromMaybe (-1) $ readMaybe ot) (fromMaybe (-1) $ readMaybe ob) bs) f a) (try $ string "") return (concat s) +-- | Parses a string wrapped in a box specification. +boxParser :: TextRenderInfo -> FontIndex -> Maybe [Action] + -> Parser [(Widget, TextRenderInfo, FontIndex, Maybe [Action])] +boxParser (TextRenderInfo cs ot ob bs) f a = do + c <- between (string "") (many1 (alphaNum <|> char ' ' <|> char '#')) + let b = fromMaybe (Box BBFull C 0 1 "white") $ readMaybe c + s <- manyTill + (allParsers (TextRenderInfo cs ot ob (b : bs)) f a) + (try $ string "") + return (concat s) + -- | Parsers a string wrapped in a font specification. fontParser :: TextRenderInfo -> Maybe [Action] -> Parser [(Widget, TextRenderInfo, FontIndex, Maybe [Action])] -- cgit v1.2.3