summaryrefslogtreecommitdiffhomepage
path: root/src/Parsers.hs
diff options
context:
space:
mode:
authorJose Antonio Ortega Ruiz <jao@gnu.org>2010-12-21 02:36:35 +0100
committerJose Antonio Ortega Ruiz <jao@gnu.org>2010-12-21 02:36:35 +0100
commite3853a9cb2a9a2cffa174d1334e2ca8ba610f151 (patch)
tree13aa04faea320afe85636e23686280386c1c2910 /src/Parsers.hs
parent598bfe5deeff079280e8513c55dc7bda3e8cf9a0 (diff)
downloadxmobar-e3853a9cb2a9a2cffa174d1334e2ca8ba610f151.tar.gz
xmobar-e3853a9cb2a9a2cffa174d1334e2ca8ba610f151.tar.bz2
Haskell sources moved to src/ to unclutter toplevel
Diffstat (limited to 'src/Parsers.hs')
-rw-r--r--src/Parsers.hs183
1 files changed, 183 insertions, 0 deletions
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 <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."
+