From e3853a9cb2a9a2cffa174d1334e2ca8ba610f151 Mon Sep 17 00:00:00 2001 From: Jose Antonio Ortega Ruiz Date: Tue, 21 Dec 2010 02:36:35 +0100 Subject: Haskell sources moved to src/ to unclutter toplevel --- src/Parsers.hs | 183 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 183 insertions(+) create mode 100644 src/Parsers.hs (limited to 'src/Parsers.hs') diff --git a/src/Parsers.hs b/src/Parsers.hs new file mode 100644 index 0000000..1450a0e --- /dev/null +++ b/src/Parsers.hs @@ -0,0 +1,183 @@ +{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving #-} +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Parsers +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz +-- 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 "") colors + s <- manyTill (textParser c <|> colorParser) (try $ string "") + 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." + -- cgit v1.2.3