Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 81289a1382
Fetching contributors…

Cannot retrieve contributors at this time

188 lines (159 sloc) 7.4 kb
{-# 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 [("", s, "")]
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 <|?> pPersistent
<|?> pCommands <|?> pSepChar
<|?> pAlignSep <|?> pTemplate
fields = [ "font", "bgColor", "fgColor", "sepChar", "alignSep"
, "border", "borderColor" ,"template", "position"
, "lowerOnStart", "persistent", "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"
pPersistent = field persistent "persistent" $ tillFieldEnd >>= read' "persistent"
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 "]") >> (string "}" <|> notNextRun)
notNextRun = do { string ","; notFollowedBy $ wrapSkip $ string "Run"; return ","}
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."
Jump to Line
Something went wrong with that request. Please try again.