diff options
Diffstat (limited to 'src/Parsers.hs')
| -rw-r--r-- | src/Parsers.hs | 117 |
1 files changed, 84 insertions, 33 deletions
diff --git a/src/Parsers.hs b/src/Parsers.hs index a5869ef..d2fa1bf 100644 --- a/src/Parsers.hs +++ b/src/Parsers.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE FlexibleContexts #-} ----------------------------------------------------------------------------- -- | -- Module : Xmobar.Parsers @@ -25,16 +25,18 @@ import Runnable import Commands import Actions +import Control.Monad (guard, mzero, liftM) import qualified Data.Map as Map import Text.ParserCombinators.Parsec import Text.ParserCombinators.Parsec.Perm +import Graphics.X11.Types (Button) data Widget = Icon String | Text String type ColorString = String -- | Runs the string parser -parseString :: Config -> String -> IO [(Widget, ColorString, Maybe Action)] +parseString :: Config -> String -> IO [(Widget, ColorString, Maybe [Action])] parseString c s = case parse (stringParser (fgColor c) Nothing) "" s of Left _ -> return [(Text $ "Could not parse string: " ++ s @@ -42,15 +44,24 @@ parseString c s = , Nothing)] Right x -> return (concat x) +allParsers :: ColorString + -> Maybe [Action] + -> Parser [(Widget, ColorString, Maybe [Action])] +allParsers c a = + textParser c a + <|> try (iconParser c a) + <|> try (rawParser c a) + <|> try (actionParser c a) + <|> colorParser a + -- | Gets the string and combines the needed parsers -stringParser :: String -> Maybe Action - -> Parser [[(Widget, ColorString, Maybe Action)]] -stringParser c a = manyTill (textParser c a <|> try (iconParser c a) <|> - try (actionParser c) <|> colorParser a) eof +stringParser :: String -> Maybe [Action] + -> Parser [[(Widget, ColorString, Maybe [Action])]] +stringParser c a = manyTill (allParsers c a) eof -- | Parses a maximal string without color markup. -textParser :: String -> Maybe Action - -> Parser [(Widget, ColorString, Maybe Action)] +textParser :: String -> Maybe [Action] + -> Parser [(Widget, ColorString, Maybe [Action])] textParser c a = do s <- many1 $ noneOf "<" <|> try (notFollowedBy' (char '<') @@ -58,9 +69,29 @@ textParser c a = do s <- many1 $ try (string "action=") <|> try (string "/action>") <|> try (string "icon=") <|> + try (string "raw=") <|> string "/fc>")) return [(Text s, c, a)] +-- | Parse a "raw" tag, which we use to prevent other tags from creeping in. +-- The format here is net-string-esque: a literal "<raw=" followed by a +-- 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 + -> Maybe [Action] + -> Parser [(Widget, ColorString, Maybe [Action])] +rawParser c a = do + string "<raw=" + lenstr <- many1 digit + char ':' + case reads lenstr of + [(len,[])] -> do + guard ((len :: Integer) <= fromIntegral (maxBound :: Int)) + s <- count (fromIntegral len) anyChar + string "/>" + return [(Text s, c, 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 @@ -70,28 +101,35 @@ notFollowedBy' p e = do x <- p notFollowedBy $ try (e >> return '*') return x -iconParser :: String -> Maybe Action - -> Parser [(Widget, ColorString, Maybe Action)] +iconParser :: String -> Maybe [Action] + -> Parser [(Widget, ColorString, Maybe [Action])] iconParser c a = do string "<icon=" i <- manyTill (noneOf ">") (try (string "/>")) return [(Icon i, c, a)] -actionParser :: String -> Parser [(Widget, ColorString, Maybe Action)] -actionParser c = do - a <- between (string "<action=") (string ">") (many1 (noneOf ">")) - let a' = Just (Spawn a) - s <- manyTill (try (textParser c a') <|> try (iconParser c a') <|> - try (colorParser a') <|> actionParser c) - (try $ string "</action>") +actionParser :: String -> Maybe [Action] -> Parser [(Widget, ColorString, Maybe [Action])] +actionParser c act = do + string "<action=" + command <- choice [between (char '`') (char '`') (many1 (noneOf "`")), + many1 (noneOf ">")] + 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 a') (try $ string "</action>") return (concat s) +toButtons :: String -> [Button] +toButtons = map (\x -> read [x]) + -- | Parsers a string wrapped in a color specification. -colorParser :: Maybe Action -> Parser [(Widget, ColorString, Maybe Action)] +colorParser :: Maybe [Action] -> Parser [(Widget, ColorString, Maybe [Action])] colorParser a = do c <- between (string "<fc=") (string ">") colors - s <- manyTill (try (textParser c a) <|> try (iconParser c a) <|> - try (colorParser a) <|> actionParser c) (try $ string "</fc>") + s <- manyTill (allParsers c a) (try $ string "</fc>") return (concat s) -- | Parses a color specification (hex or named) @@ -142,9 +180,6 @@ stripComments :: String -> String stripComments = unlines . map (drop 5 . strip False . (replicate 5 ' '++)) . lines where strip m ('-':'-':xs) = if m then "--" ++ strip m xs else "" - strip m ('\\':xss) = case xss of - '\\':xs -> '\\' : strip m xs - _ -> strip m $ drop 1 xss strip m ('"':xs) = '"': strip (not m) xs strip m (x:xs) = x : strip m xs strip _ [] = [] @@ -164,14 +199,19 @@ parseConfig = runParser parseConf fields "Config" . stripComments perms = permute $ Config <$?> pFont <|?> pBgColor <|?> pFgColor <|?> pPosition - <|?> pBorder <|?> pBdColor <|?> pAlpha <|?> pHideOnStart <|?> pAllDesktops - <|?> pOverrideRedirect <|?> pLowerOnStart <|?> pPersistent + <|?> pTextOffset <|?> pIconOffset <|?> pBorder + <|?> pBdColor <|?> pBdWidth <|?> pAlpha <|?> pHideOnStart + <|?> pAllDesktops <|?> pOverrideRedirect <|?> pPickBroadest + <|?> pLowerOnStart <|?> pPersistent <|?> pIconRoot <|?> pCommands <|?> pSepChar <|?> pAlignSep <|?> pTemplate + fields = [ "font", "bgColor", "fgColor", "sepChar", "alignSep" , "border", "borderColor" ,"template", "position" - , "allDesktops", "overrideRedirect" - , "hideOnStart", "lowerOnStart", "persistent", "commands" + , "textOffset", "iconOffset" + , "allDesktops", "overrideRedirect", "pickBroadest" + , "hideOnStart", "lowerOnStart", "persistent", "iconRoot" + , "alpha", "commands" ] pFont = strField font "font" @@ -182,14 +222,19 @@ parseConfig = runParser parseConf fields "Config" . stripComments pAlignSep = strField alignSep "alignSep" pTemplate = strField template "template" - pAlpha = readField alpha "alpha" + pTextOffset = readField textOffset "textOffset" + pIconOffset = readField iconOffset "iconOffset" pPosition = readField position "position" pHideOnStart = readField hideOnStart "hideOnStart" pLowerOnStart = readField lowerOnStart "lowerOnStart" pPersistent = readField persistent "persistent" pBorder = readField border "border" + pBdWidth = readField borderWidth "borderWidth" pAllDesktops = readField allDesktops "allDesktops" pOverrideRedirect = readField overrideRedirect "overrideRedirect" + pPickBroadest = readField pickBroadest "pickBroadest" + pIconRoot = readField iconRoot "iconRoot" + pAlpha = readField alpha "alpha" pCommands = field commands "commands" readCommands @@ -209,11 +254,17 @@ parseConfig = runParser parseConf fields "Config" . stripComments readCommands = manyTill anyChar (try commandsEnd) >>= read' commandsErr . flip (++) "]" - strField e n = field e n . between (strDel "start" n) (strDel "end" n) . - many $ noneOf "\"\n\r" - strDel t n = char '"' <?> strErr t n - strErr t n = "the " ++ t ++ " of the string field " ++ n ++ - " - a double quote (\")." + strField e n = field e n strMulti + + strMulti = scan '"' + where + scan lead = do + spaces + char lead + s <- manyTill anyChar (rowCont <|> unescQuote) + (char '"' >> return s) <|> liftM (s ++) (scan '\\') + rowCont = try $ char '\\' >> string "\n" + unescQuote = lookAhead (noneOf "\\") >> lookAhead (string "\"") wrapSkip x = many space >> x >>= \r -> many space >> return r sepEndSpc = mapM_ (wrapSkip . try . string) |