Some monad stack simplifications

Author: paf31

examples/test.purs.hs

@@ -15,7 +15,7 @@ import Text.Parsing.Parser.String
 parens :: forall m a. (Monad m) => ParserT String m a -> ParserT String m a
 parens = between (string "(") (string ")")
 
-nested :: forall m. (Monad m) => ParserT String m Number
+nested :: forall m. (Functor m, Monad m) => ParserT String m Number
 nested = fix $ \p -> (do 
   string "a"
   return 0) <|> ((+) 1) <$> parens p

src/Text/Parsing/Parser.purs.hs

@@ -5,6 +5,7 @@ import Prelude
 import Data.Either
 import Data.Maybe
 import Data.Monoid
+import Data.Tuple
 
 import Control.Monad
 import Control.Monad.Identity
@@ -24,55 +25,60 @@ instance errorParseError :: Error ParseError where
   noMsg = ParseError { message: "" }
   strMsg msg = ParseError { message: msg }
 
-data Consumed = Consumed Boolean
+data ParserT s m a = ParserT (s -> m { input :: s, result :: Either ParseError a, consumed :: Boolean })
 
-runConsumed :: Consumed -> Boolean
-runConsumed (Consumed c) = c
-
-data ParserT s m a = ParserT (StateT s (StateT Consumed (ErrorT ParseError m)) a)
-
-unParserT :: forall m s a. ParserT s m a -> StateT s (StateT Consumed (ErrorT ParseError m)) a
+unParserT :: forall m s a. ParserT s m a -> s -> m { input :: s, result :: Either ParseError a, consumed :: Boolean }
 unParserT (ParserT p) = p
 
 runParserT :: forall m s a. (Monad m) => s -> ParserT s m a -> m (Either ParseError a)
-runParserT s = runErrorT <<< flip evalStateT (Consumed false) <<< flip evalStateT s <<< unParserT
+runParserT s p = do
+  o <- unParserT p s
+  return o.result
 
 type Parser s a = ParserT s Identity a
 
 runParser :: forall s a. s -> Parser s a -> Either ParseError a
 runParser s = runIdentity <<< runParserT s
 
-instance functorParserT :: (Monad m) => Functor (ParserT s m) where
-  (<$>) = liftA1
+instance functorParserT :: (Functor m) => Functor (ParserT s m) where
+  (<$>) f p = ParserT $ \s -> f' <$> unParserT p s 
+    where
+    f' o = { input: o.input, result: f <$> o.result, consumed: o.consumed }
 
 instance applyParserT :: (Monad m) => Apply (ParserT s m) where
   (<*>) = ap
 
 instance applicativeParserT :: (Monad m) => Applicative (ParserT s m) where
-  pure a = ParserT (pure a) 
+  pure a = ParserT $ \s -> pure { input: s, result: Right a, consumed: false }
 
 instance alternativeParserT :: (Monad m) => Alternative (ParserT s m) where
-  empty = ParserT empty
-  (<|>) p1 p2 = ParserT (unParserT p1 <|> unParserT p2)
+  empty = fail "No alternative"
+  (<|>) p1 p2 = ParserT $ \s -> unParserT p1 s >>= \o ->
+    case o.result of
+      Left _ | not o.consumed -> unParserT p2 s
+      _ -> return o
 
 instance bindParserT :: (Monad m) => Bind (ParserT s m) where
-  (>>=) p f = ParserT (unParserT p >>= (unParserT <<< f))
+  (>>=) p f = ParserT $ \s -> unParserT p s >>= \o ->
+    case o.result of
+      Left err -> return { input: o.input, result: Left err, consumed: o.consumed }
+      Right a -> updateConsumedFlag o.consumed <$> unParserT (f a) o.input
+    where
+    updateConsumedFlag c o = { input: o.input, consumed: c || o.consumed, result: o.result }
 
 instance monadParserT :: (Monad m) => Monad (ParserT s m)
 
 instance monadTransParserT :: MonadTrans (ParserT s) where
-  lift m = ParserT (lift (lift (lift m)))
-
-instance monadErrorParserT :: (Monad m) => MonadError ParseError (ParserT s m) where
-  throwError e = ParserT (throwError e)
-  catchError p f = ParserT (catchError (unParserT p) (unParserT <<< f))
+  lift m = ParserT $ \s -> (\a -> { input: s, consumed: false, result: Right a }) <$> m
 
 instance monadStateParserT :: (Monad m) => MonadState s (ParserT s m) where
-  state f = ParserT (state f)
+  state f = ParserT $ \s -> 
+    return $ case f s of
+      Tuple a s' -> { input: s', consumed: false, result: Right a }
 
-instance monadStateConsumerParserT :: (Monad m) => MonadState Consumed (ParserT s m) where
-  state f = ParserT (state f)
+consume :: forall s m. (Monad m) => ParserT s m {}
+consume = ParserT $ \s -> return { consumed: true, input: s, result: Right {} }
 
 fail :: forall m s a. (Monad m) => String -> ParserT s m a
-fail message = throwError (ParseError { message: message })
+fail message = ParserT $ \s -> return { input: s, consumed: false, result: Left (ParseError { message: message }) }
 

src/Text/Parsing/Parser/Combinators.purs.hs

@@ -17,12 +17,12 @@ import Control.Monad.State.Class
 import Text.Parsing.Parser
 
 fix :: forall m s a. (ParserT m s a -> ParserT m s a) -> ParserT m s a
-fix f = ParserT (StateT (\s -> runStateT (unParserT (f (fix f))) s))
+fix f = ParserT $ \s -> unParserT (f (fix f)) s
 
 fix2 :: forall m s a b. (Tuple (ParserT m s a) (ParserT m s b) -> Tuple (ParserT m s a) (ParserT m s b)) -> Tuple (ParserT m s a) (ParserT m s b)
 fix2 f = Tuple
-           (ParserT (StateT (\s -> runStateT (unParserT (fst (f (fix2 f)))) s)))
-           (ParserT (StateT (\s -> runStateT (unParserT (snd (f (fix2 f)))) s)))
+           (ParserT $ \s -> unParserT (fst (f (fix2 f))) s)
+           (ParserT $ \s -> unParserT (snd (f (fix2 f))) s)
 
 many :: forall m s a. (Monad m) => ParserT s m a -> ParserT s m [a]
 many p = many1 p <|> return []
@@ -49,14 +49,14 @@ optional :: forall m s a. (Monad m) => ParserT s m a -> ParserT s m {}
 optional p = (do p
                  return {}) <|> return {}
 
-optionMaybe :: forall m s a. (Monad m) => ParserT s m a -> ParserT s m (Maybe a)
+optionMaybe :: forall m s a. (Functor m, Monad m) => ParserT s m a -> ParserT s m (Maybe a)
 optionMaybe p = option Nothing (Just <$> p)
 
-try :: forall m s a. (Monad m) => ParserT s m a -> ParserT s m a
-try p = catchError p $ \e -> do
-  Consumed consumed <- get
-  when consumed $ put (Consumed false)
-  throwError (e :: ParseError)
+try :: forall m s a. (Functor m) => ParserT s m a -> ParserT s m a
+try p = ParserT $ \s -> try' s <$> unParserT p s
+  where 
+  try' s o@{ result = Left _ } = { input: s, result: o.result, consumed: false }
+  try' _ o = o
 
 sepBy :: forall m s a sep. (Monad m) => ParserT s m a -> ParserT s m sep -> ParserT s m [a]
 sepBy p sep = sepBy1 p sep <|> return []

src/Text/Parsing/Parser/String.purs.hs

@@ -3,9 +3,11 @@ module Text.Parsing.Parser.String where
 import Prelude
 
 import Data.String
+import Data.Either
 
-import Control.Monad.State.Class
+import Control.Monad.Error
 import Control.Monad.Error.Class
+import Control.Monad.State.Class
 
 import Data.Foldable
 import Data.Monoid
@@ -14,37 +16,27 @@ import Text.Parsing.Parser
 import Text.Parsing.Parser.Combinators
 
 eof :: forall m. (Monad m) => ParserT String m {}
-eof = do
-  s <- get
-  case s of
-    "" -> return {}
-    _ -> fail "Expected EOF"
+eof = ParserT $ \s -> 
+  return $ case s of
+    "" -> { consumed: false, input: s, result: Right {} }
+    _ -> { consumed: false, input: s, result: Left (strMsg "Expected EOF") }
 
 string :: forall m. (Monad m) => String -> ParserT String m String
-string s = do
-  s' <- get
-  case indexOf s s' of
-    0 -> do
-      put (Consumed true)
-      put (drop (length s) s')
-      return s
-    _ -> fail $ "Expected \"" ++ s ++ "\""
+string s = ParserT $ \s'  -> 
+  return $ case indexOf s s' of
+    0 -> { consumed: true, input: drop (length s) s', result: Right s }
+    _ -> { consumed: false, input: s', result: Left (strMsg ("Expected " ++ show s)) }
 
 char :: forall m. (Monad m) => ParserT String m String
-char = do
-  s <- get
-  case s of
-    "" -> fail "Unexpected EOF"
-    _ -> do
-      put (Consumed true)
-      put (drop 1 s)
-      return (take 1 s)
+char = ParserT $ \s' -> 
+  return $ case s' of
+    "" -> { consumed: false, input: s', result: Left (strMsg "Unexpected EOF") }
+    _ -> { consumed: true, input: drop 1 s', result: Right (charAt 0 s') }
 
 satisfy :: forall m. (Monad m) => (String -> Boolean) -> ParserT String m String
 satisfy f = do
   p <- char
-  r <- if not $ f p then fail "Character did not satisfy prediate" else return p
-  return r
+  if f p then return p else fail "Character did not satisfy predicate"
 
 whiteSpace :: forall m. (Monad m) => ParserT String m String
 whiteSpace = do