Parser is now a monad transformer

Author: paf31

Gruntfile.js

@@ -6,17 +6,19 @@ module.exports = function(grunt) {
 
         clean: ["externs", "js"],
 
-        "purescript-make": {
+        "purescript": {
             options: {
                 tco: true,
+                main: true,
                 magicDo: true
             },
             lib: {
                 src:
                     [ "src/**/*.purs.hs"
                     , "examples/**/*.purs.hs"
                     , "bower_components/purescript-*/src/**/*.purs"
-                    ]
+                    ],
+                dest: "js/Main.js"
             }
         }
 
@@ -25,5 +27,5 @@ module.exports = function(grunt) {
     grunt.loadNpmTasks("grunt-purescript");
     grunt.loadNpmTasks("grunt-contrib-clean");
 
-    grunt.registerTask("default", ["purescript-make:lib"]);
+    grunt.registerTask("default", ["purescript:lib"]);
 };

bower.json

@@ -7,7 +7,7 @@
     "tmp/**"
   ],
   "dependencies": {
-    "purescript-transformers": "https://github.com/purescript/purescript-transformers.git",
+    "purescript-transformers": "*",
     "purescript-either": "*",
     "purescript-maybe": "*",
     "purescript-arrays": "*",

examples/test.purs.hs

@@ -5,28 +5,31 @@ import Data.Array
 import Data.Either
 import Data.Maybe
 import Control.Monad.Eff
+import Control.Monad.Identity
 import Debug.Trace
 import Text.Parsing.Parser
 import Text.Parsing.Parser.Combinators
 import Text.Parsing.Parser.Expr
 import Text.Parsing.Parser.String
 
-parens :: forall a. ({} -> Parser String a) -> Parser String a
+parens :: forall m a. (Monad m) => ({} -> ParserT String m a) -> ParserT String m a
 parens = between (string "(") (string ")")
 
-nested :: {} -> Parser String Number
+nested :: forall m. (Monad m) => {} -> ParserT String m Number
 nested _ = (do 
   string "a"
   return 0) <|> ((+) 1) <$> parens nested
 
 parseTest :: forall s a eff. (Show a) => Parser s a -> s -> Eff (trace :: Trace | eff) {}
-parseTest p input = case runParser p input of
-  ParseResult { result = Left (ParseError err) } -> print err.message
-  ParseResult { result = Right result } -> print result
+parseTest p input = case runParser input p of
+  Left (ParseError err) -> print err.message
+  Right result -> print result
 
+opTest :: Parser String String
 opTest = chainl char (do string "+"
                          return (++)) ""
 
+digit :: Parser String Number
 digit = (string "0" >>= \_ -> return 0) 
         <|> (string "1" >>= \_ -> return 1) 
         <|> (string "2" >>= \_ -> return 2) 
@@ -38,6 +41,7 @@ digit = (string "0" >>= \_ -> return 0)
         <|> (string "8" >>= \_ -> return 8) 
         <|> (string "9" >>= \_ -> return 9) 
 
+exprTest :: Parser String Number
 exprTest = buildExprParser [[Infix (string "/" >>= \_ -> return (/)) AssocRight]
                            ,[Infix (string "*" >>= \_ -> return (*)) AssocRight]
                            ,[Infix (string "-" >>= \_ -> return (-)) AssocRight]

src/Text/Parsing/Parser.purs.hs

@@ -1,60 +1,68 @@
 module Text.Parsing.Parser where
 
 import Prelude
-import Control.Monad
+
 import Data.Either
 import Data.Maybe
+import Data.Monoid
+
+import Control.Monad
+import Control.Monad.Identity
+
+import Control.Monad.Trans
+import Control.Monad.State.Class
+import Control.Monad.State.Trans
+import Control.Monad.Error
+import Control.Monad.Error.Class
+import Control.Monad.Error.Trans
 
 data ParseError = ParseError
   { message :: String
   }
 
-parseError :: String -> ParseError
-parseError message = ParseError
-  { message: message
-  }
+instance errorParseError :: Error ParseError where
+  noMsg = ParseError { message: "" }
+  strMsg msg = ParseError { message: msg }
 
-data ParseResult s a = ParseResult
-  { leftover :: s
-  , consumed :: Boolean
-  , result :: Either ParseError a
-  }
+data Consumed = Consumed Boolean
 
-parseResult :: forall s a. s -> Boolean -> Either ParseError a -> ParseResult s a
-parseResult leftover consumed result = ParseResult
-  { leftover: leftover
-  , consumed: consumed
-  , result: result
-  }
+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 (ParserT p) = p
 
-successResult :: forall s a. s -> Boolean -> a -> ParseResult s a
-successResult leftover consumed result = parseResult leftover consumed (Right result)
+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
 
-failureResult :: forall s a. s -> Boolean -> ParseError -> ParseResult s a
-failureResult leftover consumed err = parseResult leftover consumed (Left err)
+type Parser s a = ParserT s Identity a
 
-instance functorParseResult :: Prelude.Functor (ParseResult s) where
-  (<$>) f (ParseResult o) = parseResult o.leftover o.consumed (f <$> o.result)
+runParser :: forall s a. s -> Parser s a -> Either ParseError a
+runParser s = runIdentity <<< runParserT s
 
-data Parser s a = Parser (s -> ParseResult s a)
+instance monadParserT :: (Monad m) => Monad (ParserT s m) where
+  return a = ParserT (return a)
+  (>>=) p f = ParserT (unParserT p >>= (unParserT <<< f))
 
-runParser :: forall s a. Parser s a -> s -> ParseResult s a
-runParser (Parser p) s = p s
+instance alternativeParserT :: (Monad m) => Alternative (ParserT s m) where
+  empty = ParserT empty
+  (<|>) p1 p2 = ParserT (unParserT p1 <|> unParserT p2)
 
-instance monadParser :: Prelude.Monad (Parser s) where
-  return a = Parser $ \s -> successResult s false a
-  (>>=) p f = Parser $ \s -> case runParser p s of
-    ParseResult ({ leftover = s', consumed = consumed, result = Left err }) -> failureResult s' consumed err
-    ParseResult ({ leftover = s', consumed = consumed, result = Right a }) -> runParser (f a) s'
+instance monadTransParserT :: MonadTrans (ParserT s) where
+  lift m = ParserT (lift (lift (lift m)))
 
-instance monadAlternative :: Prelude.Alternative (Parser s) where
-  empty = fail "No alternative"
-  (<|>) p1 p2 = Parser $ \s -> case runParser p1 s of
-    ParseResult ({ leftover = s', consumed = false, result = Left _ }) -> runParser p2 s
-    res -> res
+instance monadErrorParserT :: (Monad m) => MonadError ParseError (ParserT s m) where
+  throwError e = ParserT (throwError e)
+  catchError p f = ParserT (catchError (unParserT p) (unParserT <<< f))
 
-fail :: forall s a. String -> Parser s a
-fail message = Parser $ \s -> failureResult s false (parseError message)
+instance monadStateParserT :: (Monad m) => MonadState s (ParserT s m) where
+  state f = ParserT (state f)
 
+instance monadStateConsumerParserT :: (Monad m) => MonadState Consumed (ParserT s m) where
+  state f = ParserT (state f)
 
+fail :: forall m s a. (Monad m) => String -> ParserT s m a
+fail message = throwError (ParseError { message: message })
 

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

@@ -1,104 +1,114 @@
 module Text.Parsing.Parser.Combinators where
 
 import Prelude
+
 import Data.Maybe
 import Data.Array
 import Data.Either
+
+import Control.Monad
+
+import Control.Monad.Error.Trans
+import Control.Monad.Error.Class
+import Control.Monad.State.Trans
+import Control.Monad.State.Class
+
 import Text.Parsing.Parser
 
-many :: forall s a. Parser s a -> Parser s [a]
+many :: forall m s a. (Monad m) => ParserT s m a -> ParserT s m [a]
 many p = many1 p <|> return []
 
-many1 :: forall s a. Parser s a -> Parser s [a]
+many1 :: forall m s a. (Monad m) => ParserT s m a -> ParserT s m [a]
 many1 p = do a <- p
              as <- many p
              return (a : as)
 
-(<?>) :: forall s a. Parser s a -> String -> Parser s a
+(<?>) :: forall m s a. (Monad m) => ParserT s m a -> String -> ParserT s m a
 (<?>) p msg = p <|> fail msg
 
-between :: forall s a open close. Parser s open -> Parser s close -> ({} -> Parser s a) -> Parser s a
+between :: forall m s a open close. (Monad m) => ParserT s m open -> ParserT s m close -> ({} -> ParserT s m a) -> ParserT s m a
 between open close p = do
   open
   a <- p {}
   close 
   return a
 
-option :: forall s a. a -> Parser s a -> Parser s a
+option :: forall m s a. (Monad m) => a -> ParserT s m a -> ParserT s m a
 option a p = p <|> return a
 
-optional :: forall s a. Parser s a -> Parser s {}
+optional :: forall m s a. (Monad m) => ParserT s m a -> ParserT s m {}
 optional p = (do p
                  return {}) <|> return {}
 
-optionMaybe :: forall s a. Parser s a -> Parser s (Maybe a)
+optionMaybe :: forall m s a. (Monad m) => ParserT s m a -> ParserT s m (Maybe a)
 optionMaybe p = option Nothing (Just <$> p)
 
-try :: forall s a. Parser s a -> Parser s a
-try p = Parser $ \s -> case runParser p s of
-  ParseResult ({ consumed = true, result = Left err }) -> failureResult s false err
-  res -> res
+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)
 
-sepBy :: forall s a sep. Parser s a -> Parser s sep -> Parser s [a]
+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 []
 
-sepBy1 :: forall s a sep. Parser s a -> Parser s sep -> Parser s [a]
+sepBy1 :: forall m s a sep. (Monad m) => ParserT s m a -> ParserT s m sep -> ParserT s m [a]
 sepBy1 p sep = do
   a <- p
   as <- many $ do
     sep
     p
   return (a : as)
 
-sepEndBy :: forall s a sep. Parser s a -> Parser s sep -> Parser s [a]
+sepEndBy :: forall m s a sep. (Monad m) => ParserT s m a -> ParserT s m sep -> ParserT s m [a]
 sepEndBy p sep = sepEndBy1 p sep <|> return []
 
-sepEndBy1 :: forall s a sep. Parser s a -> Parser s sep -> Parser s [a]
+sepEndBy1 :: forall m s a sep. (Monad m) => ParserT s m a -> ParserT s m sep -> ParserT s m [a]
 sepEndBy1 p sep = do
   a <- p
   (do sep
       as <- sepEndBy p sep
       return (a : as)) <|> return [a]
 
-endBy1 :: forall s a sep. Parser s a -> Parser s sep -> Parser s [a]
+endBy1 :: forall m s a sep. (Monad m) => ParserT s m a -> ParserT s m sep -> ParserT s m [a]
 endBy1 p sep = many1 $ do 
   a <- p
   sep
   return a
 
-endBy :: forall s a sep. Parser s a -> Parser s sep -> Parser s [a]
+endBy :: forall m s a sep. (Monad m) => ParserT s m a -> ParserT s m sep -> ParserT s m [a]
 endBy p sep = many $ do
   a <- p
   sep
   return a
 
-chainr :: forall s a. Parser s a -> Parser s (a -> a -> a) -> a -> Parser s a
+chainr :: forall m s a. (Monad m) => ParserT s m a -> ParserT s m (a -> a -> a) -> a -> ParserT s m a
 chainr p f a = chainr1 p f <|> return a
 
-chainl :: forall s a. Parser s a -> Parser s (a -> a -> a) -> a -> Parser s a
+chainl :: forall m s a. (Monad m) => ParserT s m a -> ParserT s m (a -> a -> a) -> a -> ParserT s m a
 chainl p f a = chainl1 p f <|> return a
 
-chainl1 :: forall s a. Parser s a -> Parser s (a -> a -> a) -> Parser s a
+chainl1 :: forall m s a. (Monad m) => ParserT s m a -> ParserT s m (a -> a -> a) -> ParserT s m a
 chainl1 p f = do
   a <- p
   chainl1' p f a
 
-chainl1' :: forall s a. Parser s a -> Parser s (a -> a -> a) -> a -> Parser s a
+chainl1' :: forall m s a. (Monad m) => ParserT s m a -> ParserT s m (a -> a -> a) -> a -> ParserT s m a
 chainl1' p f a = (do f' <- f
                      a' <- p
                      chainl1' p f (f' a a')) <|> return a
 
-chainr1 :: forall s a. Parser s a -> Parser s (a -> a -> a) -> Parser s a
+chainr1 :: forall m s a. (Monad m) => ParserT s m a -> ParserT s m (a -> a -> a) -> ParserT s m a
 chainr1 p f = do
   a <- p
   chainr1' p f a
 
-chainr1' :: forall s a. Parser s a -> Parser s (a -> a -> a) -> a -> Parser s a
+chainr1' :: forall m s a. (Monad m) => ParserT s m a -> ParserT s m (a -> a -> a) -> a -> ParserT s m a
 chainr1' p f a = (do f' <- f
                      a' <- chainr1 p f
                      return $ f' a a') <|> return a
 
-choice :: forall s a. [Parser s a] -> Parser s a
+choice :: forall m s a. (Monad m) => [ParserT s m a] -> ParserT s m a
 choice []   = fail "Nothing to parse"
 choice [x]  = x
 choice (x:xs) = x <|> choice xs