From 7514c05975601d5816c696a8072b23142e8f0802 Mon Sep 17 00:00:00 2001
From: Adam Vogt <vogt.adam@gmail.com>
Date: Mon, 14 Sep 2009 04:39:21 +0200
Subject: 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
---
 Main.hs      |  7 ++-----
 Parsers.hs   | 64 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-
 xmobar.cabal |  2 +-
 3 files changed, 66 insertions(+), 7 deletions(-)

diff --git a/Main.hs b/Main.hs
index c8ce30d..44dda60 100644
--- a/Main.hs
+++ b/Main.hs
@@ -64,11 +64,8 @@ readConfig :: FilePath -> IO Config
 readConfig f = do
   file <- fileExist f
   s    <- if file then readFileSafe f else error $ f ++ ": file not found!\n" ++ usage
-  case reads s of
-    [(conf,_)] -> return conf
-    []         -> error $ f ++ ": configuration file contains errors!\n" ++ usage
-    _          -> error ("Some problem occured. Aborting...")
-
+  either (\err -> error $ f ++ ": configuration file contains errors at:\n" ++ show err)
+         return $ parseConfig s
 -- | Read default configuration file or load the default config
 readDefaultConfig :: IO Config
 readDefaultConfig = do
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
diff --git a/xmobar.cabal b/xmobar.cabal
index 5298e30..034f0d2 100644
--- a/xmobar.cabal
+++ b/xmobar.cabal
@@ -54,4 +54,4 @@ executable xmobar
         build-depends: hinotify
         cpp-options: -DINOTIFY
 
-    build-depends:      X11>=1.3.0, mtl, unix, parsec, filepath, stm
+    build-depends:      X11>=1.3.0, mtl, unix, parsec, filepath, stm, action-permutations==0.0.0.0
-- 
cgit v1.2.3