From ef380c045957413948d390c152f6401869526285 Mon Sep 17 00:00:00 2001 From: jao Date: Fri, 30 Sep 2022 06:50:53 +0100 Subject: Run.Parsers -> Config.Template --- src/Xmobar/Config/Parse.hs | 11 +- src/Xmobar/Config/Template.hs | 200 ++++++++++++++++++++++++++++++++++ src/Xmobar/Config/Types.hs | 45 ++++++++ src/Xmobar/Draw/Boxes.hs | 23 ++-- src/Xmobar/Draw/Cairo.hs | 35 +++--- src/Xmobar/Draw/Types.hs | 3 +- src/Xmobar/Run/Parsers.hs | 244 ------------------------------------------ src/Xmobar/Text/Output.hs | 16 +-- src/Xmobar/Text/Swaybar.hs | 20 ++-- src/Xmobar/X11/Draw.hs | 3 +- src/Xmobar/X11/Loop.hs | 10 +- 11 files changed, 309 insertions(+), 301 deletions(-) create mode 100644 src/Xmobar/Config/Template.hs delete mode 100644 src/Xmobar/Run/Parsers.hs (limited to 'src') diff --git a/src/Xmobar/Config/Parse.hs b/src/Xmobar/Config/Parse.hs index 16af3db..23de4db 100644 --- a/src/Xmobar/Config/Parse.hs +++ b/src/Xmobar/Config/Parse.hs @@ -19,7 +19,8 @@ module Xmobar.Config.Parse(readConfig , parseConfig , indexedFont - , indexedOffset) where + , indexedOffset + , colorComponents) where import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Number (int) @@ -31,6 +32,14 @@ import Xmobar.Config.Types import qualified System.IO as S (readFile) +-- | Splits a colors string into its two components +colorComponents :: Config -> String -> (String, String) +colorComponents conf c = + case break (==',') c of + (f,',':b) -> (f, b) + (f, _) -> (f, bgColor conf) + + stripComments :: String -> String stripComments = unlines . map (drop 5 . strip False . (replicate 5 ' '++)) . lines diff --git a/src/Xmobar/Config/Template.hs b/src/Xmobar/Config/Template.hs new file mode 100644 index 0000000..28ccbe1 --- /dev/null +++ b/src/Xmobar/Config/Template.hs @@ -0,0 +1,200 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Xmobar.Config.Template +-- Copyright: (c) 2022 jao +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: mail@jao.io +-- Stability: unstable +-- Portability: portable +-- Created: Fri Sep 30, 2022 06:33 +-- +-- +-- Parsing template strings +-- +------------------------------------------------------------------------------ + + +module Xmobar.Config.Template (parseString) where + +import Control.Monad (guard, mzero) +import Data.Maybe (fromMaybe) + +import Text.Parsec ((<|>)) +import qualified Text.Parsec as P +import qualified Text.Parsec.Combinator as C +import Text.ParserCombinators.Parsec (Parser) + +import Text.Read (readMaybe) + +import Xmobar.Config.Types + +-- | Runs the template string parser +parseString :: Config -> String -> IO [Segment] +parseString c s = + case P.parse (stringParser ci 0 Nothing) "" s of + Left _ -> return [(Text $ "Could not parse string: " ++ s + , ci + , 0 + , Nothing)] + Right x -> return (concat x) + where ci = TextRenderInfo (fgColor c) 0 0 [] + +allParsers :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] +allParsers c f a = textParser c f a + <|> P.try (iconParser c f a) + <|> P.try (hspaceParser c f a) + <|> P.try (rawParser c f a) + <|> P.try (actionParser c f a) + <|> P.try (fontParser c a) + <|> P.try (boxParser c f a) + <|> colorParser c f a + +-- | Gets the string and combines the needed parsers +stringParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [[Segment]] +stringParser c f a = C.manyTill (allParsers c f a) C.eof + +-- | Parses a maximal string without markup. +textParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] +textParser c f a = do s <- C.many1 $ + P.noneOf "<" <|> + P.try (notFollowedBy' (P.char '<') + (P.try (P.string "fc=") <|> + P.try (P.string "box") <|> + P.try (P.string "fn=") <|> + P.try (P.string "action=") <|> + P.try (P.string "/action>") <|> + P.try (P.string "icon=") <|> + P.try (P.string "hspace=") <|> + P.try (P.string "raw=") <|> + P.try (P.string "/fn>") <|> + P.try (P.string "/box>") <|> + P.string "/fc>")) + return [(Text s, c, f, a)] + +-- | Parse a "raw" tag, which we use to prevent other tags from creeping in. +-- The format here is net-string-esque: a literal "". +rawParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] +rawParser c f a = do + P.string " do + guard ((len :: Integer) <= fromIntegral (maxBound :: Int)) + s <- C.count (fromIntegral len) P.anyChar + P.string "/>" + return [(Text s, c, f, a)] + _ -> mzero + +-- | 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 + C.notFollowedBy $ P.try (e >> return '*') + return x + +iconParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] +iconParser c f a = do + P.string "") (P.try (P.string "/>")) + return [(Icon i, c, f, a)] + +hspaceParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] +hspaceParser c f a = do + P.string "")) + return [(Hspace (fromMaybe 0 $ readMaybe pVal), c, f, a)] + +actionParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] +actionParser c f act = do + P.string "")] + buttons <- (P.char '>' >> return "1") <|> (P.space >> P.spaces >> + C.between (P.string "button=") (P.string ">") (C.many1 (P.oneOf "12345"))) + let a = Spawn (toButtons buttons) command + a' = case act of + Nothing -> Just [a] + Just act' -> Just $ a : act' + s <- C.manyTill (allParsers c f a') (P.try $ P.string "") + return (concat s) + +toButtons :: String -> [Button] +toButtons = map (\x -> read [x]) + +-- | Parsers a string wrapped in a color specification. +colorParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] +colorParser (TextRenderInfo _ _ _ bs) fidx a = do + c <- C.between (P.string "") colors + let colorParts = break (==':') c + let (ot,ob) = case break (==',') (Prelude.drop 1 $ snd colorParts) of + (top,',':btm) -> (top, btm) + (top, _) -> (top, top) + tri = TextRenderInfo (fst colorParts) + (fromMaybe (-1) $ readMaybe ot) + (fromMaybe (-1) $ readMaybe ob) + bs + s <- C.manyTill (allParsers tri fidx a) (P.try $ P.string "") + return (concat s) + +-- | Parses a string wrapped in a box specification. +boxParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] +boxParser (TextRenderInfo cs ot ob bs) f a = do + c <- C.between (P.string "") + (C.option "" (C.many1 (P.alphaNum + <|> P.char '=' + <|> P.char ' ' + <|> P.char '#' + <|> P.char ','))) + let b = Box BBFull (BoxOffset C 0) 1 cs (BoxMargins 0 0 0 0) + let g = boxReader b (words c) + s <- C.manyTill + (allParsers (TextRenderInfo cs ot ob (g : bs)) f a) + (P.try $ P.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 align offset) lw fc mgs + where offset = fromMaybe off $ readMaybe o + align = fromMaybe alg $ readMaybe [a] +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 [Segment] +fontParser c a = do + f <- C.between (P.string "") colors + s <- C.manyTill (allParsers c (fromMaybe 0 $ readMaybe f) a) (P.try $ P.string "") + return (concat s) + +-- | Parses a color specification (hex or named) +colors :: Parser String +colors = C.many1 (P.alphaNum <|> P.char ',' <|> P.char ':' <|> P.char '#') diff --git a/src/Xmobar/Config/Types.hs b/src/Xmobar/Config/Types.hs index 4959aa1..df39f6d 100644 --- a/src/Xmobar/Config/Types.hs +++ b/src/Xmobar/Config/Types.hs @@ -15,14 +15,28 @@ module Xmobar.Config.Types ( Config (..) , XPosition (..), Align (..), Border (..), TextOutputFormat (..) + , Segment , FontIndex + , Box(..) + , BoxBorder(..) + , BoxOffset(..) + , BoxMargins(..) + , TextRenderInfo(..) + , Widget(..) , SignalChan (..) + , Action (..) + , Button ) where import qualified Control.Concurrent.STM as STM import qualified Xmobar.Run.Runnable as R import qualified Xmobar.System.Signal as S +import Data.Int (Int32) +import Foreign.C.Types (CInt) + +import Xmobar.Run.Actions (Action (..), Button) + -- $config -- Configuration data type @@ -110,3 +124,34 @@ instance Read SignalChan where instance Show SignalChan where show (SignalChan (Just _)) = "SignalChan (Just )" show (SignalChan Nothing) = "SignalChan Nothing" + +data Widget = Icon String | Text String | Hspace Int32 deriving Show + +data BoxOffset = BoxOffset Align Int32 deriving (Eq, Show) + +-- margins: Top, Right, Bottom, Left +data BoxMargins = BoxMargins Int32 Int32 Int32 Int32 deriving (Eq, Show) + +data BoxBorder = BBTop + | BBBottom + | BBVBoth + | BBLeft + | BBRight + | BBHBoth + | BBFull + deriving (Read, Eq, Show) + +data Box = Box { bBorder :: BoxBorder + , bOffset :: BoxOffset + , bWidth :: CInt + , bColor :: String + , bMargins :: BoxMargins + } deriving (Eq, Show) + +data TextRenderInfo = TextRenderInfo { tColorsString :: String + , tBgTopOffset :: Int32 + , tBgBottomOffset :: Int32 + , tBoxes :: [Box] + } deriving Show + +type Segment = (Widget, TextRenderInfo, FontIndex, Maybe [Action]) diff --git a/src/Xmobar/Draw/Boxes.hs b/src/Xmobar/Draw/Boxes.hs index 1358805..692e232 100644 --- a/src/Xmobar/Draw/Boxes.hs +++ b/src/Xmobar/Draw/Boxes.hs @@ -16,7 +16,6 @@ module Xmobar.Draw.Boxes (Line, boxLines, BoxRect, borderRect) where import qualified Xmobar.Config.Types as T -import qualified Xmobar.Run.Parsers as P type Line = (Double, Double, Double, Double) type BoxRect = (Double, Double, Double, Double) @@ -25,19 +24,19 @@ type BoxRect = (Double, Double, Double, Double) -- The Box is to be positioned between x0 and x1, with height ht, and drawn -- with line width lw. The returned lists are coordinates of the beginning -- and end of each line. -boxLines :: P.Box -> Double -> Double -> Double -> [Line] -boxLines (P.Box bd offset lw _ margins) ht x0 x1 = +boxLines :: T.Box -> Double -> Double -> Double -> [Line] +boxLines (T.Box bd offset lw _ margins) ht x0 x1 = case bd of - P.BBTop -> [rtop] - P.BBBottom -> [rbot] - P.BBVBoth -> [rtop, rbot] - P.BBLeft -> [rleft] - P.BBRight -> [rright] - P.BBHBoth -> [rleft, rright] - P.BBFull -> [rtop, rbot, rleft, rright] + T.BBTop -> [rtop] + T.BBBottom -> [rbot] + T.BBVBoth -> [rtop, rbot] + T.BBLeft -> [rleft] + T.BBRight -> [rright] + T.BBHBoth -> [rleft, rright] + T.BBFull -> [rtop, rbot, rleft, rright] where - (P.BoxMargins top right bot left) = margins - (P.BoxOffset align m) = offset + (T.BoxMargins top right bot left) = margins + (T.BoxOffset align m) = offset ma = fromIntegral m (p0, p1) = case align of T.L -> (0, -ma) diff --git a/src/Xmobar/Draw/Cairo.hs b/src/Xmobar/Draw/Cairo.hs index 7e22df4..cd85580 100644 --- a/src/Xmobar/Draw/Cairo.hs +++ b/src/Xmobar/Draw/Cairo.hs @@ -29,14 +29,13 @@ import Graphics.Rendering.Cairo.Types(Surface) import qualified Xmobar.Config.Types as C import qualified Xmobar.Config.Parse as ConfigParse -import qualified Xmobar.Run.Parsers as P import qualified Xmobar.Text.Pango as TextPango import qualified Xmobar.Draw.Boxes as Boxes import qualified Xmobar.Draw.Types as T -type Renderinfo = (P.Segment, Surface -> Double -> Double -> IO (), Double) -type BoundedBox = (Double, Double, [P.Box]) +type Renderinfo = (C.Segment, Surface -> Double -> Double -> IO (), Double) +type BoundedBox = (Double, Double, [C.Box]) type Acc = (Double, T.Actions, [BoundedBox]) readColourName :: String -> (SRGB.Colour Double, Double) @@ -63,10 +62,10 @@ renderLines color wd lns = do mapM_ (\(x0, y0, x1, y1) -> Cairo.moveTo x0 y0 >> Cairo.lineTo x1 y1 >> Cairo.stroke) lns -segmentMarkup :: C.Config -> P.Segment -> String -segmentMarkup conf (P.Text txt, info, idx, _actions) = +segmentMarkup :: C.Config -> C.Segment -> String +segmentMarkup conf (C.Text txt, info, idx, _actions) = let fnt = TextPango.fixXft $ ConfigParse.indexedFont conf idx - (fg, bg) = P.colorComponents conf (P.tColorsString info) + (fg, bg) = ConfigParse.colorComponents conf (C.tColorsString info) attrs = [Pango.FontDescr fnt, Pango.FontForeground fg] attrs' = if bg == C.bgColor conf then attrs @@ -74,8 +73,8 @@ segmentMarkup conf (P.Text txt, info, idx, _actions) = in Pango.markSpan attrs' $ Pango.escapeMarkup txt segmentMarkup _ _ = "" -withRenderinfo :: Pango.PangoContext -> T.DrawContext -> P.Segment -> IO Renderinfo -withRenderinfo ctx dctx seg@(P.Text _, inf, idx, a) = do +withRenderinfo :: Pango.PangoContext -> T.DrawContext -> C.Segment -> IO Renderinfo +withRenderinfo ctx dctx seg@(C.Text _, inf, idx, a) = do let conf = T.dcConfig dctx lyt <- Pango.layoutEmpty ctx mk <- Pango.layoutSetMarkup lyt (segmentMarkup conf seg) :: IO String @@ -88,25 +87,25 @@ withRenderinfo ctx dctx seg@(P.Text _, inf, idx, a) = do Pango.layoutSetEllipsize lyt Pango.EllipsizeEnd Pango.layoutSetWidth lyt (Just $ mx - off) Cairo.renderWith s $ Cairo.moveTo off voff >> Pango.showLayout lyt - return ((P.Text mk, inf, idx, a), slyt, wd) + return ((C.Text mk, inf, idx, a), slyt, wd) -withRenderinfo _ _ seg@(P.Hspace w, _, _, _) = +withRenderinfo _ _ seg@(C.Hspace w, _, _, _) = return (seg, \_ _ _ -> return (), fromIntegral w) -withRenderinfo _ dctx seg@(P.Icon p, _, _, _) = do +withRenderinfo _ dctx seg@(C.Icon p, _, _, _) = do let (wd, _) = T.dcIconLookup dctx p ioff = C.iconOffset (T.dcConfig dctx) vpos = T.dcHeight dctx / 2 + fromIntegral ioff render _ off mx = when (off + wd <= mx) $ T.dcIconDrawer dctx off vpos p return (seg, render, wd) -drawBox :: T.DrawContext -> Surface -> Double -> Double -> P.Box -> IO () -drawBox dctx surf x0 x1 box@(P.Box _ _ w color _) = +drawBox :: T.DrawContext -> Surface -> Double -> Double -> C.Box -> IO () +drawBox dctx surf x0 x1 box@(C.Box _ _ w color _) = Cairo.renderWith surf $ renderLines color (fromIntegral w) (Boxes.boxLines box (T.dcHeight dctx) x0 x1) drawSegmentBackground :: - T.DrawContext -> Surface -> P.TextRenderInfo -> Double -> Double -> IO () + T.DrawContext -> Surface -> C.TextRenderInfo -> Double -> Double -> IO () drawSegmentBackground dctx surf info x0 x1 = when (bg /= C.bgColor conf && (top >= 0 || bot >= 0)) $ Cairo.renderWith surf $ do @@ -114,16 +113,16 @@ drawSegmentBackground dctx surf info x0 x1 = Cairo.rectangle x0 top (x1 - x0) (T.dcHeight dctx - bot - top) Cairo.fillPreserve where conf = T.dcConfig dctx - (_, bg) = P.colorComponents conf (P.tColorsString info) - top = fromIntegral $ P.tBgTopOffset info - bot = fromIntegral $ P.tBgBottomOffset info + (_, bg) = ConfigParse.colorComponents conf (C.tColorsString info) + top = fromIntegral $ C.tBgTopOffset info + bot = fromIntegral $ C.tBgBottomOffset info drawSegment :: T.DrawContext -> Surface -> Double -> Acc -> Renderinfo -> IO Acc drawSegment dctx surface maxoff (off, acts, boxs) (segment, render, lwidth) = do let end = min maxoff (off + lwidth) (_, info, _, a) = segment acts' = case a of Just as -> (as, off, end):acts; _ -> acts - bs = P.tBoxes info + bs = C.tBoxes info boxs' = if null bs then boxs else (off, end, bs):boxs drawSegmentBackground dctx surface info off end render surface off maxoff diff --git a/src/Xmobar/Draw/Types.hs b/src/Xmobar/Draw/Types.hs index 75dd714..9853c38 100644 --- a/src/Xmobar/Draw/Types.hs +++ b/src/Xmobar/Draw/Types.hs @@ -17,9 +17,8 @@ module Xmobar.Draw.Types where -import Xmobar.Config.Types (Config) +import Xmobar.Config.Types (Config, Segment) import Xmobar.Run.Actions (Action) -import Xmobar.Run.Parsers (Segment) type Position = Double type ActionPos = ([Action], Position, Position) diff --git a/src/Xmobar/Run/Parsers.hs b/src/Xmobar/Run/Parsers.hs deleted file mode 100644 index 9b36786..0000000 --- a/src/Xmobar/Run/Parsers.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Run.Parsers --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz --- Stability : unstable --- Portability : portable --- --- Parsing for template substrings --- ------------------------------------------------------------------------------ - -module Xmobar.Run.Parsers ( parseString - , colorComponents - , Segment - , FontIndex - , Box(..) - , BoxBorder(..) - , BoxOffset(..) - , BoxMargins(..) - , TextRenderInfo(..) - , Widget(..)) where - -import Control.Monad (guard, mzero) -import Data.Maybe (fromMaybe) -import Data.Int (Int32) -import Text.ParserCombinators.Parsec -import Text.Read (readMaybe) -import Foreign.C.Types (CInt) - -import Xmobar.Config.Types -import Xmobar.Run.Actions - -data Widget = Icon String | Text String | Hspace Int32 deriving Show - -data BoxOffset = BoxOffset Align Int32 deriving (Eq, Show) - --- margins: Top, Right, Bottom, Left -data BoxMargins = BoxMargins Int32 Int32 Int32 Int32 deriving (Eq, Show) - -data BoxBorder = BBTop - | BBBottom - | BBVBoth - | BBLeft - | BBRight - | BBHBoth - | BBFull - deriving (Read, Eq, Show) - -data Box = Box { bBorder :: BoxBorder - , bOffset :: BoxOffset - , bWidth :: CInt - , bColor :: String - , bMargins :: BoxMargins - } deriving (Eq, Show) - -data TextRenderInfo = TextRenderInfo { tColorsString :: String - , tBgTopOffset :: Int32 - , tBgBottomOffset :: Int32 - , tBoxes :: [Box] - } deriving Show - -type Segment = (Widget, TextRenderInfo, FontIndex, Maybe [Action]) - --- | Runs the string parser -parseString :: Config -> String -> IO [Segment] -parseString c s = - case parse (stringParser ci 0 Nothing) "" s of - Left _ -> return [(Text $ "Could not parse string: " ++ s - , ci - , 0 - , Nothing)] - Right x -> return (concat x) - where ci = TextRenderInfo (fgColor c) 0 0 [] - --- | Splits a colors string into its two components -colorComponents :: Config -> String -> (String, String) -colorComponents conf c = - case break (==',') c of - (f,',':b) -> (f, b) - (f, _) -> (f, bgColor conf) - -allParsers :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -allParsers c f a = textParser c f a - <|> try (iconParser c f a) - <|> try (hspaceParser c f a) - <|> try (rawParser c f a) - <|> try (actionParser c f a) - <|> try (fontParser c a) - <|> try (boxParser c f a) - <|> colorParser c f a - --- | Gets the string and combines the needed parsers -stringParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [[Segment]] -stringParser c f a = manyTill (allParsers c f a) eof - --- | Parses a maximal string without markup. -textParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -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 "hspace=") <|> - try (string "raw=") <|> - try (string "/fn>") <|> - try (string "/box>") <|> - string "/fc>")) - return [(Text s, c, f, a)] - --- | Parse a "raw" tag, which we use to prevent other tags from creeping in. --- The format here is net-string-esque: a literal "". -rawParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -rawParser c f a = do - string " do - guard ((len :: Integer) <= fromIntegral (maxBound :: Int)) - s <- count (fromIntegral len) anyChar - string "/>" - return [(Text s, c, f, a)] - _ -> mzero - --- | 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 $ try (e >> return '*') - return x - -iconParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -iconParser c f a = do - string "") (try (string "/>")) - return [(Icon i, c, f, a)] - -hspaceParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -hspaceParser c f a = do - string "")) - return [(Hspace (fromMaybe 0 $ readMaybe pVal), c, f, a)] - -actionParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -actionParser c f act = do - string "")] - buttons <- (char '>' >> return "1") <|> (space >> spaces >> - between (string "button=") (string ">") (many1 (oneOf "12345"))) - let a = Spawn (toButtons buttons) command - a' = case act of - Nothing -> Just [a] - Just act' -> Just $ a : act' - s <- manyTill (allParsers c f a') (try $ string "") - return (concat s) - -toButtons :: String -> [Button] -toButtons = map (\x -> read [x]) - --- | Parsers a string wrapped in a color specification. -colorParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -colorParser (TextRenderInfo _ _ _ bs) fidx 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) - tri = TextRenderInfo (fst colorParts) - (fromMaybe (-1) $ readMaybe ot) - (fromMaybe (-1) $ readMaybe ob) - bs - s <- manyTill (allParsers tri fidx a) (try $ string "") - return (concat s) - --- | Parses a string wrapped in a box specification. -boxParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -boxParser (TextRenderInfo cs ot ob bs) f a = do - 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 (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 align offset) lw fc mgs - where offset = fromMaybe off $ readMaybe o - align = fromMaybe alg $ readMaybe [a] -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 [Segment] -fontParser c a = do - f <- between (string "") colors - s <- manyTill (allParsers c (fromMaybe 0 $ readMaybe f) a) (try $ string "") - return (concat s) - --- | Parses a color specification (hex or named) -colors :: Parser String -colors = many1 (alphaNum <|> char ',' <|> char ':' <|> char '#') diff --git a/src/Xmobar/Text/Output.hs b/src/Xmobar/Text/Output.hs index 783a5bb..6e5b0f1 100644 --- a/src/Xmobar/Text/Output.hs +++ b/src/Xmobar/Text/Output.hs @@ -15,13 +15,15 @@ module Xmobar.Text.Output (initLoop, format) where -import Xmobar.Config.Types (Config(textOutputFormat, additionalFonts, font) - , TextOutputFormat(..)) -import Xmobar.Run.Parsers ( Segment - , Widget(..) - , parseString - , tColorsString - , colorComponents) +import Xmobar.Config.Types ( Config (..) + , TextOutputFormat (..) + , Segment + , Widget (..) + , tColorsString) + + +import Xmobar.Config.Parse (colorComponents) +import Xmobar.Config.Template (parseString) import Xmobar.Text.Ansi (withAnsiColor) import Xmobar.Text.Pango (withPangoMarkup) diff --git a/src/Xmobar/Text/Swaybar.hs b/src/Xmobar/Text/Swaybar.hs index a2fc585..355de06 100644 --- a/src/Xmobar/Text/Swaybar.hs +++ b/src/Xmobar/Text/Swaybar.hs @@ -24,16 +24,16 @@ import Data.ByteString.Lazy.UTF8 (toString) import GHC.Generics -import Xmobar.Config.Types (Config (additionalFonts)) - -import Xmobar.Run.Parsers ( Segment - , Widget(..) - , Box(..) - , BoxBorder(..) - , FontIndex - , tBoxes - , tColorsString - , colorComponents) +import Xmobar.Config.Types ( Config (additionalFonts) + , Segment + , Widget(..) + , Box(..) + , BoxBorder(..) + , FontIndex + , tBoxes + , tColorsString) + +import Xmobar.Config.Parse (colorComponents) import Xmobar.Text.SwaybarClicks (startHandler) import Xmobar.Text.Pango (withPangoFont) diff --git a/src/Xmobar/X11/Draw.hs b/src/Xmobar/X11/Draw.hs index a056136..b380497 100644 --- a/src/Xmobar/X11/Draw.hs +++ b/src/Xmobar/X11/Draw.hs @@ -25,7 +25,6 @@ import Foreign.C.Types as FT import qualified Graphics.X11.Xlib as X11 import qualified Xmobar.Config.Types as C -import qualified Xmobar.Run.Parsers as P import qualified Xmobar.Draw.Types as D import qualified Xmobar.Draw.Cairo as DC @@ -69,7 +68,7 @@ withPixmap disp win (X11.Rectangle _ _ w h) depth action = do X11.sync disp True return res -draw :: [[P.Segment]] -> T.X [D.ActionPos] +draw :: [[C.Segment]] -> T.X [D.ActionPos] draw segments = do xconf <- ask let disp = T.display xconf diff --git a/src/Xmobar/X11/Loop.hs b/src/Xmobar/X11/Loop.hs index 599e680..721a35b 100644 --- a/src/Xmobar/X11/Loop.hs +++ b/src/Xmobar/X11/Loop.hs @@ -35,10 +35,10 @@ import qualified Graphics.X11.Xinerama as Xinerama import qualified Graphics.X11.Xrandr as Xrandr import qualified Xmobar.Config.Types as C +import qualified Xmobar.Config.Template as CT import qualified Xmobar.Run.Actions as A import qualified Xmobar.Run.Loop as L -import qualified Xmobar.Run.Parsers as P import qualified Xmobar.System.Utils as U import qualified Xmobar.System.Signal as S @@ -145,15 +145,15 @@ signalLoop xc@(T.XConf d r w fs is cfg) actions signalv strs = do r' <- W.repositionWin d w (NE.head fs) rcfg signalLoop (T.XConf d r' w fs is rcfg) actions signalv strs -parseSegments :: C.Config -> STM.TVar [String] -> IO [[P.Segment]] +parseSegments :: C.Config -> STM.TVar [String] -> IO [[C.Segment]] parseSegments conf v = do s <- STM.readTVarIO v let l:c:r:_ = s ++ repeat "" - MR.liftIO $ mapM (P.parseString conf) [l, c, r] + MR.liftIO $ mapM (CT.parseString conf) [l, c, r] -updateIconCache :: T.XConf -> [[P.Segment]] -> IO T.XConf +updateIconCache :: T.XConf -> [[C.Segment]] -> IO T.XConf updateIconCache xc@(T.XConf d _ w _ c cfg) segs = do - let paths = [p | (P.Icon p, _, _, _) <- concat segs] + let paths = [p | (C.Icon p, _, _, _) <- concat segs] c' <- Bitmap.updateCache d w c (C.iconRoot cfg) paths return $ xc {T.iconCache = c'} -- cgit v1.2.3