diff options
Diffstat (limited to 'Parsers.hs')
| -rw-r--r-- | Parsers.hs | 183 |
1 files changed, 0 insertions, 183 deletions
diff --git a/Parsers.hs b/Parsers.hs deleted file mode 100644 index 1450a0e..0000000 --- a/Parsers.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving #-} ------------------------------------------------------------------------------ --- | --- Module : Xmobar.Parsers --- Copyright : (c) Andrea Rossato --- License : BSD-style (see LICENSE) --- --- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> --- Stability : unstable --- Portability : unportable --- --- Parsers needed for Xmobar, a text based status bar --- ------------------------------------------------------------------------------ - -module Parsers - ( parseString - , parseTemplate - , parseConfig - ) where - -import Config -import Runnable -import Commands - -import qualified Data.Map as Map -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Perm - --- | Runs the string parser -parseString :: Config -> String -> IO [(String, String)] -parseString c s = - case parse (stringParser (fgColor c)) "" s of - Left _ -> return [("Could not parse string: " ++ s, fgColor c)] - Right x -> return (concat x) - --- | Gets the string and combines the needed parsers -stringParser :: String -> Parser [[(String, String)]] -stringParser c = manyTill (textParser c <|> colorParser) eof - --- | Parses a maximal string without color markup. -textParser :: String -> Parser [(String, String)] -textParser c = do s <- many1 $ - noneOf "<" <|> - ( try $ notFollowedBy' (char '<') - (string "fc=" <|> string "/fc>" ) ) - return [(s, c)] - --- | 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 - --- | Parsers a string wrapped in a color specification. -colorParser :: Parser [(String, String)] -colorParser = do - c <- between (string "<fc=") (string ">") colors - s <- manyTill (textParser c <|> colorParser) (try $ string "</fc>") - return (concat s) - --- | Parses a color specification (hex or named) -colors :: Parser String -colors = many1 (alphaNum <|> char ',' <|> char '#') - --- | Parses the output template string -templateStringParser :: Config -> Parser (String,String,String) -templateStringParser c = do - s <- allTillSep c - com <- templateCommandParser c - ss <- allTillSep c - return (com, s, ss) - --- | Parses the command part of the template string -templateCommandParser :: Config -> Parser String -templateCommandParser c = - let chr = char . head . sepChar - in between (chr c) (chr c) (allTillSep c) - --- | Combines the template parsers -templateParser :: Config -> Parser [(String,String,String)] -templateParser = many . templateStringParser - --- | Actually runs the template parsers -parseTemplate :: Config -> String -> IO [(Runnable,String,String)] -parseTemplate c s = - do str <- case parse (templateParser c) "" s of - Left _ -> return [("","","")] - Right x -> return x - let cl = map alias (commands c) - m = Map.fromList $ zip cl (commands c) - return $ combine c m str - --- | Given a finite "Map" and a parsed template produce the resulting --- output string. -combine :: Config -> Map.Map String Runnable -> [(String, String, String)] -> [(Runnable,String,String)] -combine _ _ [] = [] -combine c m ((ts,s,ss):xs) = (com, s, ss) : combine c m xs - where com = Map.findWithDefault dflt ts m - dflt = Run $ Com ts [] [] 10 - -allTillSep :: Config -> Parser String -allTillSep = many . noneOf . sepChar - -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 _ [] = [] - --- | Parse the config, logging a list of fields that were missing and replaced --- by the default definition. -parseConfig :: String -> Either ParseError (Config,[String]) -parseConfig = runParser parseConf fields "Config" . stripComments - where - parseConf = do - many space - sepEndSpc ["Config","{"] - x <- perms - eof - s <- getState - return (x,s) - - perms = permute $ Config - <$?> pFont <|?> pBgColor - <|?> pFgColor <|?> pPosition - <|?> pBorder <|?> pBdColor - <|?> pLowerOnStart <|?> pCommands - <|?> pSepChar <|?> pAlignSep - <|?> pTemplate - - fields = [ "font", "bgColor", "fgColor", "sepChar", "alignSep" - , "border", "borderColor" ,"template", "position" - , "lowerOnStart", "commands"] - pFont = strField font "font" - pBgColor = strField bgColor "bgColor" - pFgColor = strField fgColor "fgColor" - pBdColor = strField borderColor "borderColor" - pSepChar = strField sepChar "sepChar" - pAlignSep = strField alignSep "alignSep" - pTemplate = strField template "template" - - pPosition = field position "position" $ tillFieldEnd >>= read' "position" - pLowerOnStart = field lowerOnStart "lowerOnStart" $ tillFieldEnd >>= read' "lowerOnStart" - pBorder = field border "border" $ tillFieldEnd >>= read' "border" - pCommands = field commands "commands" $ readCommands - - staticPos = do string "Static" - wrapSkip (string "{") - p <- many (noneOf "}") - wrapSkip (string "}") - string "," - return ("Static {" ++ p ++ "}") - tillFieldEnd = staticPos <|> many (noneOf ",}\n\r") - - commandsEnd = wrapSkip (string "]") >> oneOf "}," - 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 (\")." - - wrapSkip x = many space >> x >>= \r -> many space >> return r - sepEndSpc = mapM_ (wrapSkip . try . string) - fieldEnd = many $ space <|> oneOf ",}" - field e n c = (,) (e defaultConfig) $ - updateState (filter (/= n)) >> sepEndSpc [n,"="] >> - wrapSkip c >>= \r -> fieldEnd >> return r - - read' d s = case reads s of - [(x, _)] -> return x - _ -> fail $ "error reading the " ++ d ++ " field: " ++ s - -commandsErr :: String -commandsErr = "commands: this usually means that a command could not be parsed.\n" ++ - "The error could be located at the begining of the command which follows the offending one." - |