Use a newtype for the backtracking Parsec Alternative instance

Ignore-this: e79b4134f53f7449f54b08c4fc4dc787

darcs-hash:20091011035512-1499c-347dab168c4a8ee5507c18b0eb336f0a07114976.gz

1 files changed, 31 insertions, 25 deletions

diff --git a/Parsers.hs b/Parsers.hs
index 9d90554..5fae1d8 100644
--- a/Parsers.hs
+++ b/Parsers.hs
@@ -1,5 +1,4 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE FlexibleContexts, GeneralizedNewtypeDeriving #-}
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  Xmobar.Parsers
@@ -21,18 +20,18 @@ module Parsers
     ) where
 
 import Config
-import Commands
 import Runnable
-import Text.ParserCombinators.Parsec hiding ((<|>))
-import qualified Text.ParserCombinators.Parsec as Parsec
+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 Data.Foldable (sequenceA_)
-import Data.List (find,inits,tails)
-import Control.Applicative.Permutation (optAtom, runPermsSep)
-import Control.Applicative hiding (many)
-import Control.Monad.Writer
-import Data.Either
+import Text.ParserCombinators.Parsec as Parsec
 
 -- | Runs the string parser
 parseString :: Config -> String -> IO [(String, String)]
@@ -111,13 +110,16 @@ 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
+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 (GenParser tok st) where
-    (<|>) x y = (Parsec.<|>) (try x) y
-    empty = pzero
+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
@@ -125,7 +127,7 @@ readsToParsec = do
     input <- getInput
     case reads input of
         (result,rest):_ -> do
-            sequenceA_ $ do
+            maybe (return Nothing) (fmap Just) $ do
                   ls <- fmap (lines . fst) . find ((==rest) . snd)
                             $ zip (inits input) (tails input)
                   lastLine <- safeLast ls
@@ -148,10 +150,14 @@ liftM9 fun a b c d e f g h i
 -- | 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 = flip parse "Config" $ sepEndSpaces ["Config","{"]
-                                    *> perms <* wrapSkip (string "}") <* eof
+parseConfig = flip parse "Config" $ do
+                sepEndSpaces ["Config","{"]
+                x <- unWrapParser perms
+                wrapSkip (string "}")
+                eof
+                return x
     where
-      perms = runPermsSep (wrapSkip $ string ",") $ liftM9 Config
+      perms = runPermsSep (WrappedParser $ wrapSkip $ string ",") $ liftM9 Config
         <$> withDef font         "font"          strField
         <*> withDef bgColor      "bgColor"       strField
         <*> withDef fgColor      "fgColor"       strField
@@ -162,13 +168,13 @@ parseConfig = flip parse "Config" $ sepEndSpaces ["Config","{"]
         <*> withDef alignSep     "alignSep"      strField
         <*> withDef template     "template"      strField
 
-      wrapSkip x = many space *> x <* many space
-      sepEndSpaces = mapM_ (\s -> string s <* many space)
+      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 $ parser name)
+                                        (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
+      field cont name = sepEndSpaces [name,"="] >> cont