Parse config file more intelligently.

Ignore-this: 9d6cd7536b6df73f3af44b7a74b826a1

Using parsec and action-permutations, config options may be permuted or left
out (to be replaced by the default configuration option).

This patch improves forwards compatibility with xmobar (ex. the addition of
lowerOnStart broke many configs), and provides some help to find typos in the
config. The commands section is still parsed with Read however.

darcs-hash:20090914023921-1499c-b73a792ccfafd50d31878e35f928facb50748531.gz

1 files changed, 63 insertions, 1 deletions

diff --git a/Parsers.hs b/Parsers.hs
index 8867dba..f03ec8e 100644
--- a/Parsers.hs
+++ b/Parsers.hs
@@ -15,14 +15,22 @@
 module Parsers
     ( parseString
     , parseTemplate
+    , parseConfig
     ) where
 
 import Config
 import Commands
 import Runnable
-import Text.ParserCombinators.Parsec
+import Text.ParserCombinators.Parsec hiding ((<|>))
+import qualified Text.ParserCombinators.Parsec as Parsec
 import qualified Data.Map as Map
 
+import Data.Foldable (sequenceA_)
+import Data.List (find,inits,tails)
+import Control.Applicative.Permutation(optAtom, runPermsSep)
+import Control.Monad(Monad(return), mapM_, ap)
+import Control.Applicative hiding (many)
+
 -- | Runs the string parser
 parseString :: Config -> String -> IO [(String, String)]
 parseString c s =
@@ -99,3 +107,57 @@ combine c m ((ts,s,ss):xs) = (com, s, ss) : combine c m xs
 
 allTillSep :: Config -> Parser String
 allTillSep = many . noneOf . sepChar
+
+instance Applicative (GenParser tok st) where
+    pure = return
+    (<*>) = ap
+
+instance Alternative (GenParser tok st) where
+    (<|>) x y = (Parsec.<|>) (try x) y
+    empty = pzero
+
+readsToParsec :: Read b => CharParser st b
+readsToParsec = do
+    pos0 <- getPosition
+    input <- getInput
+    case reads input of
+        (result,rest):_ -> do
+            sequenceA_ $ do
+                  ls <- fmap (lines . fst) . find ((==rest) . snd)
+                            $ zip (inits input) (tails input)
+                  lastLine <- safeLast ls
+                  return $ setPosition
+                      . flip setSourceColumn (length lastLine)
+                      . flip incSourceLine (length ls - 1) $ pos0
+            setInput rest
+            return result
+        _ -> setInput input >> fail "readsToParsec failed"
+
+safeLast :: [a] -> Maybe a
+safeLast [] = Nothing
+safeLast xs = Just (last xs)
+
+-- | Parse the config
+parseConfig :: String -> Either ParseError Config
+parseConfig = flip parse "Config" $ sepEndSpaces ["Config","{"]
+                                    *> perms<* wrapSkip (string "}")
+    where
+      perms = runPermsSep (wrapSkip $ string ",") $ Config
+        <$> withDef font         (strField "font")
+        <*> withDef bgColor      (strField "bgColor")
+        <*> withDef fgColor      (strField "fgColor")
+        <*> withDef position     (field "position" readsToParsec)
+        <*> withDef lowerOnStart (field "lowerOnStart" parseEnum)
+        <*> withDef commands     (field "commands" readsToParsec)
+        <*> withDef sepChar      (strField "sepChar")
+        <*> withDef alignSep     (strField "alignSep")
+        <*> withDef template     (strField "template")
+
+      wrapSkip x = many space *> x <* many space
+      sepEndSpaces = mapM_ (\s -> string s <* many space)
+      withDef f = optAtom (f defaultConfig)
+
+      parseEnum = choice $ map (\x -> x <$ string (show x)) [minBound .. maxBound]
+
+      strField name = field name $ between (char '"') (char '"') (many1 . satisfy $ (/= '"'))
+      field name cont = sepEndSpaces [name,"="] *> cont