From 7ef539d28d7f1f0fe9cc11d1339c580d44140bf2 Mon Sep 17 00:00:00 2001 From: jao Date: Sat, 1 Oct 2022 16:10:21 +0100 Subject: Config.Template refactorings --- src/Xmobar/Config/Template.hs | 211 +++++++++++++++++++++--------------------- 1 file changed, 104 insertions(+), 107 deletions(-) (limited to 'src/Xmobar') diff --git a/src/Xmobar/Config/Template.hs b/src/Xmobar/Config/Template.hs index 67ed061..407771d 100644 --- a/src/Xmobar/Config/Template.hs +++ b/src/Xmobar/Config/Template.hs @@ -28,55 +28,56 @@ import qualified Text.Parsec.Combinator as C import Text.ParserCombinators.Parsec (Parser) -import Xmobar.Config.Types +import qualified Xmobar.Config.Types as T --- | Runs the template string parser -parseString :: Config -> String -> [Segment] +type Context = (T.TextRenderInfo, T.FontIndex, Maybe [T.Action]) + +retSegment :: Context -> T.Widget -> Parser [T.Segment] +retSegment (i, idx, as) widget = return [(widget, i, idx, as)] + +-- | Run the template string parser +parseString :: T.Config -> String -> [T.Segment] parseString c s = - case P.parse (stringParser ci 0 Nothing) "" s of - Left _ -> [(Text $ "Could not parse string: " ++ s , ci , 0 , Nothing)] + case P.parse (stringParser ci) "" s of + Left _ -> [(T.Text $ "Could not parse string: " ++ s, ti, 0, Nothing)] Right x -> 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)] + where ci = (ti , 0, Nothing) + ti = T.TextRenderInfo (T.fgColor c) 0 0 [] + +-- | Top level parser reading the full template string +stringParser :: Context -> Parser [[T.Segment]] +stringParser c = C.manyTill (allParsers c) C.eof + +allParsers :: Context -> Parser [T.Segment] +allParsers c = foldl (\p fn -> p <|> P.try (fn c)) (textParser c) + [ iconParser, hspaceParser, rawParser, actionParser + , fontParser, boxParser, colorParser] + +-- | 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 + +-- | Parse a maximal string without markup +textParser :: Context -> Parser [T.Segment] +textParser c = + C.many1 (P.noneOf "<" <|> P.try (notFollowedBy' (P.char '<') trys')) + >>= retSegment c . T.Text + where trys = P.try . P.string + trys' = foldl (\p s -> p <|> trys s) (trys "fc=") + [ "box", "fn=", "action=", "/action>", "icon=" + , "hspace=", "raw=", "/fn>", "/box>", "/fc>"] -- | 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 +rawParser :: Context -> Parser [T.Segment] +rawParser c = do P.string "" - return [(Text s, c, f, a)] + retSegment c (T.Text s) _ -> 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 +iconParser :: Context -> Parser [T.Segment] +iconParser c = do P.string "") (P.try (P.string "/>")) - return [(Icon i, c, f, a)] + retSegment c (T.Icon i) -hspaceParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -hspaceParser c f a = do +hspaceParser :: Context -> Parser [T.Segment] +hspaceParser c = do P.string "")) - return [(Hspace (fromMaybe 0 $ readMaybe pVal), c, f, a)] + retSegment c (T.Hspace (fromMaybe 0 $ readMaybe pVal)) -actionParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -actionParser c f act = do +actionParser :: Context -> Parser [T.Segment] +actionParser (ti, fi, 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 + let a = T.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 "") + s <- C.manyTill (allParsers (ti, fi, a')) (P.try $ P.string "") return (concat s) -toButtons :: String -> [Button] +toButtons :: String -> [T.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 +-- | Parse a string wrapped in a color specification +colorParser :: Context -> Parser [T.Segment] +colorParser (T.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 + let (ot,ob) = case break (==',') (drop 1 $ snd colorParts) of (top,',':btm) -> (top, btm) (top, _) -> (top, top) - tri = TextRenderInfo (fst colorParts) + tri = T.TextRenderInfo (fst colorParts) (fromMaybe (-1) $ readMaybe ot) (fromMaybe (-1) $ readMaybe ob) bs - s <- C.manyTill (allParsers tri fidx a) (P.try $ P.string "") + s <- C.manyTill (allParsers (tri, fidx, a)) (P.try $ P.string "") return (concat s) + where colors = C.many1 (P.alphaNum <|> P.char ',' <|> P.char ':' <|> P.char '#') --- | Parses a string wrapped in a box specification. -boxParser :: TextRenderInfo -> FontIndex -> Maybe [Action] -> Parser [Segment] -boxParser (TextRenderInfo cs ot ob bs) f a = do +-- | Parse a string wrapped in a box specification +boxParser :: Context -> Parser [T.Segment] +boxParser (T.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) + (C.option "" (C.many1 (P.alphaNum + <|> P.char '=' + <|> P.char ' ' + <|> P.char '#' + <|> P.char ','))) + let b = T.Box T.BBFull (T.BoxOffset T.C 0) 1 cs (T.BoxMargins 0 0 0 0) let g = boxReader b (words c) s <- C.manyTill - (allParsers (TextRenderInfo cs ot ob (g : bs)) f a) + (allParsers (T.TextRenderInfo cs ot ob (g : bs), f, a)) (P.try $ P.string "") return (concat s) -boxReader :: Box -> [String] -> Box +boxReader :: T.Box -> [String] -> T.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 +boxReader b (x:xs) = boxReader (boxParamReader b param val) xs + where (param,val) = case break (=='=') x of + (p,'=':v) -> (p, v) + (p, _) -> (p, "") -boxParamReader :: Box -> String -> String -> Box +boxParamReader :: T.Box -> String -> String -> T.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 + +boxParamReader (T.Box bb off lw fc mgs) "type" val = + T.Box (fromMaybe bb $ readMaybe ("BB" ++ val)) off lw fc mgs + +boxParamReader (T.Box bb (T.BoxOffset alg off) lw fc mgs) "offset" (a:o) = + T.Box bb (T.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 + +boxParamReader (T.Box bb off lw fc mgs) "width" val = + T.Box bb off (fromMaybe lw $ readMaybe val) fc mgs + +boxParamReader (T.Box bb off lw _ mgs) "color" val = + T.Box bb off lw val mgs + +boxParamReader (T.Box bb off lw fc mgs@(T.BoxMargins mt mr mb ml)) ('m':pos) v = 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' + "t" -> T.BoxMargins (maybeVal mt) mr mb ml + "r" -> T.BoxMargins mt (maybeVal mr) mb ml + "b" -> T.BoxMargins mt mr (maybeVal mb) ml + "l" -> T.BoxMargins mt mr mb (maybeVal ml) + _ -> mgs + maybeVal d = fromMaybe d (readMaybe v) + in T.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 "") +-- | Parse a string wrapped in a font specification +fontParser :: Context -> Parser [T.Segment] +fontParser (i, _, a) = do + f <- C.between (P.string "") (C.many1 P.digit) + s <- C.manyTill (allParsers (i, 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 '#') -- cgit v1.2.3