get rid of action-permutations and use parsec permutation library instead

Ignore-this: 73dbcd588c961bd8bb4dd6d0c931cb3760e2949e
code gets shorter and error messages maybe meaningful

darcs-hash:20100206003909-d6583-631e1c5e75ad7e7334f865828b398f4d2310af5a.gz

3 files changed, 64 insertions, 83 deletions

diff --git a/Main.hs b/Main.hs
index a94c597..c34af3b 100644
--- a/Main.hs
+++ b/Main.hs
@@ -35,8 +35,7 @@ import System.Console.GetOpt
 import System.Exit
 import System.Environment
 import System.Posix.Files
-
-import Control.Monad.Writer (MonadWriter,MonadIO,unless,runWriterT)
+import Control.Monad (unless)
 
 -- $main
 
@@ -46,9 +45,9 @@ main = do
   d   <- openDisplay ""
   args     <- getArgs
   (o,file) <- getOpts args
-  (c,defaultings) <- runWriterT $ case file of
-                    [cfgfile] -> readConfig cfgfile
-                    _         -> readDefaultConfig
+  (c,defaultings) <- case file of
+                       [cfgfile] -> readConfig cfgfile
+                       _         -> readDefaultConfig
 
   unless (null defaultings) $ putStrLn $ "Fields missing from config defaulted: "
                                             ++ intercalate "," defaultings
@@ -68,19 +67,20 @@ main = do
   releaseFont d fs
 
 -- | Reads the configuration files or quits with an error
-readConfig :: (MonadIO m, MonadWriter [String] m) => FilePath -> m Config
+readConfig :: FilePath -> IO (Config,[String])
 readConfig f = do
   file <- io $ fileExist f
   s    <- io $ if file then readFileSafe f else error $ f ++ ": file not found!\n" ++ usage
   either (\err -> error $ f ++ ": configuration file contains errors at:\n" ++ show err)
-         id $ parseConfig s
+         return $ parseConfig s
+
 -- | Read default configuration file or load the default config
-readDefaultConfig :: (MonadIO m, MonadWriter [String] m) => m Config
+readDefaultConfig :: IO (Config,[String])
 readDefaultConfig = do
   home <- io $ getEnv "HOME"
   let path = home ++ "/.xmobarrc"
   f <- io $ fileExist path
-  if f then readConfig path else return defaultConfig
+  if f then readConfig path else return (defaultConfig,[])
 
 data Opts = Help
           | Version
diff --git a/Parsers.hs b/Parsers.hs
index 0b77940..58e3bcd 100644
--- a/Parsers.hs
+++ b/Parsers.hs
@@ -23,15 +23,9 @@ import Config
 import Runnable
 import Commands
 
-import Control.Monad.Writer(mapM_, ap, liftM, liftM2, MonadWriter, tell)
-import Control.Applicative.Permutation(optAtom, runPermsSep)
-import Control.Applicative(Applicative, (<*>), Alternative, empty, (<$), (<$>))
-import qualified Control.Applicative
-
-import Data.List(tails, find, inits)
 import qualified Data.Map as Map
-
-import Text.ParserCombinators.Parsec as Parsec
+import Text.ParserCombinators.Parsec
+import Text.ParserCombinators.Parsec.Perm
 
 -- | Runs the string parser
 parseString :: Config -> String -> IO [(String, String)]
@@ -110,43 +104,6 @@ combine c m ((ts,s,ss):xs) = (com, s, ss) : combine c m xs
 allTillSep :: Config -> Parser String
 allTillSep = many . noneOf . sepChar
 
-newtype WrappedParser tok st a = WrappedParser { unWrapParser :: GenParser tok st a }
-    deriving (Functor,Monad)
-
-instance Applicative (WrappedParser tok st) where
-    pure = WrappedParser . return
-    (<*>) x y = WrappedParser $ unWrapParser x `ap` unWrapParser y
-
-instance Alternative (WrappedParser tok st) where
-    (<|>) x y = WrappedParser $ try (unWrapParser x) Parsec.<|> unWrapParser y
-    empty = WrappedParser pzero
-
-readsToParsec :: Read b => CharParser st b
-readsToParsec = do
-    pos0 <- getPosition
-    input <- getInput
-    case reads input of
-        (result,rest):_ -> do
-            maybe (return Nothing) (fmap Just) $ 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)
-
-liftM9 :: (Monad m) => (a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> b) ->
-          m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m a6 -> m a7 -> m a8 -> m a9 -> m b
-liftM9 fun a b c d e f g h i
-    = fun `liftM` a `ap` b `ap` c `ap` d `ap` e `ap` f `ap` g `ap` h `ap` i
-
 stripComments :: String -> String
 stripComments = unlines . map (drop 5 . strip False . (replicate 5 ' '++)) . lines
     where strip m ('-':'-':xs) = if m then "--" ++ strip m xs else ""
@@ -159,33 +116,57 @@ stripComments = unlines . map (drop 5 . strip False . (replicate 5 ' '++)) . lin
 
 -- | Parse the config, logging a list of fields that were missing and replaced
 -- by the default definition.
-parseConfig :: MonadWriter [String] m => String -> Either ParseError (m Config)
-parseConfig = parseConf "Config" . stripComments
+parseConfig :: String -> Either ParseError (Config,[String])
+parseConfig = runParser parseConf fields "Config" . stripComments
     where
-      parseConf = parse $ do
-        sepEndSpaces ["Config","{"]
-        x <- unWrapParser perms
-        wrapSkip (string "}")
+      parseConf = do
+        many space
+        sepEndSpc ["Config","{"]
+        x <- perms
         eof
-        return x
-      perms = runPermsSep (WrappedParser $ wrapSkip $ string ",") $ liftM9 Config
-        <$> withDef font         "font"          strField
-        <*> withDef bgColor      "bgColor"       strField
-        <*> withDef fgColor      "fgColor"       strField
-        <*> withDef position     "position"     (field readsToParsec)
-        <*> withDef lowerOnStart "lowerOnStart" (field parseEnum    )
-        <*> withDef commands     "commands"     (field readsToParsec)
-        <*> withDef sepChar      "sepChar"       strField
-        <*> withDef alignSep     "alignSep"      strField
-        <*> withDef template     "template"      strField
-
-      wrapSkip x = many space >> liftM2 const x (many space)
-      sepEndSpaces = mapM_ (\s -> liftM2 const (string s) $ many space)
-
-      withDef ext name parser = optAtom (do tell [name]; return $ ext defaultConfig)
-                                        (liftM return $ WrappedParser $ parser name)
-
-      parseEnum = choice $ map (\x -> x <$ string (show x)) [minBound .. maxBound]
-
-      strField name = flip field name $ between (char '"') (char '"') (many1 . satisfy $ (/= '"'))
-      field cont name = sepEndSpaces [name,"="] >> cont
+        s <- getState
+        return (x,s)
+
+      perms = permute $ Config
+              <$?> pFont         <|?> pBgColor
+              <|?> pFgColor      <|?> pPosition
+              <|?> pLowerOnStart <|?> pCommands
+              <|?> pSepChar      <|?> pAlignSep
+              <|?> pTemplate
+
+      fields    = [ "font", "bgColor", "fgColor", "sepChar", "alignSep"
+                  , "template", "position", "lowerOnStart", "commands"]
+      pFont     = strField font     "font"
+      pBgColor  = strField bgColor  "bgColor"
+      pFgColor  = strField fgColor  "fgColor"
+      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"
+      pCommands     = field commands     "commands"     $ readCommands
+
+      tillFieldEnd = 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 field: " ++ d
+
+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."
+
diff --git a/xmobar.cabal b/xmobar.cabal
index fa66a9a..8551806 100644
--- a/xmobar.cabal
+++ b/xmobar.cabal
@@ -56,4 +56,4 @@ executable xmobar
         build-depends: hinotify
         cpp-options: -DINOTIFY
 
-    build-depends:      X11>=1.3.0, mtl, unix, parsec, filepath, stm, action-permutations==0.0.0.0
+    build-depends:      X11>=1.3.0, mtl, unix, parsec, filepath, stm