From faee05164998ddfd53cbb473170baac6962922a4 Mon Sep 17 00:00:00 2001 From: Unoqwy Date: Fri, 7 Aug 2020 14:46:55 +0200 Subject: better parsing for boxes + add margins --- src/Xmobar/X11/Draw.hs | 40 ++++++++++++++++----------------- src/Xmobar/X11/Parsers.hs | 57 ++++++++++++++++++++++++++++++++--------------- 2 files changed, 59 insertions(+), 38 deletions(-) diff --git a/src/Xmobar/X11/Draw.hs b/src/Xmobar/X11/Draw.hs index 0e07573..22b88ae 100644 --- a/src/Xmobar/X11/Draw.hs +++ b/src/Xmobar/X11/Draw.hs @@ -105,14 +105,14 @@ verticalOffset ht (Icon _) _ _ conf printString :: Display -> Drawable -> XFont -> GC -> String -> String -> Position -> Position -> Position -> Position -> String -> Int -> IO () -printString d p (Core fs) gc fc bc x y ay ht s a = do +printString d p (Core fs) gc fc bc x y _ _ 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 ay ht s a = +printString d p (Utf8 fs) gc fc bc x y _ _ s a = withColors d [fc, bc] $ \[fc', bc'] -> do setForeground d gc fc' when (a == 255) (setBackground d gc bc') @@ -171,38 +171,38 @@ printStrings dr gc fontlist voffs offs a boxes sl@((s,c,i,l):xs) = do 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 + let (xx, Box bb offset lineWidth fc mgs) = b lw = fromIntegral lineWidth :: Position withColors d [fc] $ \[fc'] -> do setForeground d gc fc' setLineAttributes d gc lineWidth lineSolid capNotLast joinMiter - case pos of + case bb of BBVBoth -> do - drawBoxBorder d dr gc BBTop alg offset ht xx lw - drawBoxBorder d dr gc BBBottom alg offset ht xx lw + drawBoxBorder d dr gc BBTop offset ht xx lw mgs + drawBoxBorder d dr gc BBBottom offset ht xx lw mgs BBHBoth -> do - drawBoxBorder d dr gc BBLeft alg offset ht xx lw - drawBoxBorder d dr gc BBRight alg offset ht xx lw + drawBoxBorder d dr gc BBLeft offset ht xx lw mgs + drawBoxBorder d dr gc BBRight offset ht xx lw mgs BBFull -> do - drawBoxBorder d dr gc BBTop alg offset ht xx lw - drawBoxBorder d dr gc BBBottom alg offset ht xx lw - drawBoxBorder d dr gc BBLeft alg offset ht xx lw - drawBoxBorder d dr gc BBRight alg offset ht xx lw - _ -> drawBoxBorder d dr gc pos alg offset ht xx lw + drawBoxBorder d dr gc BBTop offset ht xx lw mgs + drawBoxBorder d dr gc BBBottom offset ht xx lw mgs + drawBoxBorder d dr gc BBLeft offset ht xx lw mgs + drawBoxBorder d dr gc BBRight offset ht xx lw mgs + _ -> drawBoxBorder d dr gc bb offset ht xx lw mgs drawBoxes d dr gc ht bs -drawBoxBorder :: Display -> Drawable -> GC -> BoxBorder -> Align -> Position -> Position - -> (Position, Position) -> Position -> IO () -drawBoxBorder d dr gc pos alg offset ht (x1,x2) lw = do +drawBoxBorder :: Display -> Drawable -> GC -> BoxBorder -> BoxOffset -> Position + -> (Position, Position) -> Position -> BoxMargins -> IO () +drawBoxBorder d dr gc pos (BoxOffset alg offset) ht (x1,x2) lw (BoxMargins mt mr mb ml) = do let (p1,p2) = case alg of L -> (0, -offset) C -> (offset, -offset) R -> (offset, 0 ) lc = lw `div` 2 case pos of - BBTop -> drawLine d dr gc (x1 + p1) lc (x2 + p2) lc + BBTop -> drawLine d dr gc (x1 + p1) (mt + lc) (x2 + p2) (mt + lc) BBBottom -> do - let lc' = max lc 1 + let lc' = max lc 1 + mb drawLine d dr gc (x1 + p1) (ht - lc') (x2 + p2) (ht - lc') - BBLeft -> drawLine d dr gc (x1 - 1) p1 (x1 - 1) (ht + p2) - BBRight -> drawLine d dr gc (x2 + lc - 1) p1 (x2 + lc - 1) (ht + p2) + BBLeft -> drawLine d dr gc (x1 - 1 + ml) p1 (x1 - 1 + ml) (ht + p2) + BBRight -> drawLine d dr gc (x2 + lc - 1 - mr) p1 (x2 + lc - 1 - mr) (ht + p2) diff --git a/src/Xmobar/X11/Parsers.hs b/src/Xmobar/X11/Parsers.hs index 7fa5c00..d35cfa0 100644 --- a/src/Xmobar/X11/Parsers.hs +++ b/src/Xmobar/X11/Parsers.hs @@ -14,7 +14,8 @@ -- ----------------------------------------------------------------------------- -module Xmobar.X11.Parsers (parseString, Box(..), BoxBorder(..), TextRenderInfo(..), Widget(..)) where +module Xmobar.X11.Parsers (parseString, Box(..), BoxBorder(..), BoxOffset(..), + BoxMargins(..), TextRenderInfo(..), Widget(..)) where import Xmobar.Config.Types import Xmobar.X11.Actions @@ -29,6 +30,9 @@ import Foreign.C.Types (CInt) data Widget = Icon String | Text String +data BoxOffset = BoxOffset Align Int32 deriving Eq +-- margins: Top, Right, Bottom, Left +data BoxMargins = BoxMargins Int32 Int32 Int32 Int32 deriving Eq data BoxBorder = BBTop | BBBottom | BBVBoth @@ -37,19 +41,7 @@ data BoxBorder = BBTop | 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 Box = Box BoxBorder BoxOffset CInt String BoxMargins deriving Eq data TextRenderInfo = TextRenderInfo { tColorsString :: String , tBgTopOffset :: Int32 @@ -94,7 +86,7 @@ textParser c f a = do s <- many1 $ noneOf "<" <|> try (notFollowedBy' (char '<') (try (string "fc=") <|> - try (string "box=") <|> + try (string "box") <|> try (string "fn=") <|> try (string "action=") <|> try (string "/action>") <|> @@ -177,13 +169,42 @@ colorParser (TextRenderInfo _ _ _ bs) f a = do 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 + c <- between (string "") (option "" (many1 (alphaNum <|> char '=' <|> char ' ' <|> char '#' <|> char ','))) + let b = Box BBFull (BoxOffset C 0) 1 cs (BoxMargins 0 0 0 0) + let g = boxReader b (words c) s <- manyTill - (allParsers (TextRenderInfo cs ot ob (b : bs)) f a) + (allParsers (TextRenderInfo cs ot ob (g : bs)) f a) (try $ string "") return (concat s) + +boxReader :: Box -> [String] -> Box +boxReader b [] = b +boxReader b (x:xs) = do + let (param,val) = case break (=='=') x of + (p,'=':v) -> (p, v) + (p, _) -> (p, "") + boxReader (boxParamReader b param val) xs +boxParamReader :: Box -> String -> String -> Box +boxParamReader b _ "" = b +boxParamReader (Box bb off lw fc mgs) "type" val = + Box (fromMaybe bb $ readMaybe ("BB" ++ val)) off lw fc mgs +boxParamReader (Box bb (BoxOffset alg off) lw fc mgs) "offset" (a:o) = + Box bb (BoxOffset (fromMaybe alg $ readMaybe [a]) (fromMaybe off $ readMaybe o)) lw fc mgs +boxParamReader (Box bb off lw fc mgs) "width" val = + Box bb off (fromMaybe lw $ readMaybe val) fc mgs +boxParamReader (Box bb off lw _ mgs) "color" val = + Box bb off lw val mgs +boxParamReader (Box bb off lw fc mgs@(BoxMargins mt mr mb ml)) ('m':pos) val = do + let mgs' = case pos of + "t" -> BoxMargins (fromMaybe mt $ readMaybe val) mr mb ml + "r" -> BoxMargins mt (fromMaybe mr $ readMaybe val) mb ml + "b" -> BoxMargins mt mr (fromMaybe mb $ readMaybe val) ml + "l" -> BoxMargins mt mr mb (fromMaybe ml $ readMaybe val) + _ -> mgs + Box bb off lw fc mgs' +boxParamReader b _ _ = b + -- | Parsers a string wrapped in a font specification. fontParser :: TextRenderInfo -> Maybe [Action] -> Parser [(Widget, TextRenderInfo, FontIndex, Maybe [Action])] -- cgit v1.2.3