Add some basic combinators

Author: paf31

parsing.purs

@@ -3,6 +3,8 @@ module Parsing where
 import Prelude
 import Either
 import String
+import Arrays
+import Maybe
 
 data ParseError = ParseError
   { message :: String
@@ -15,41 +17,153 @@ parseError message = ParseError
 
 data ParseResult s a = ParseResult
   { leftover :: s
-  , result :: a
+  , consumed :: Boolean
+  , result :: Either ParseError a
   }
 
-parseResult :: forall s a. s -> a -> ParseResult s a
-parseResult leftover result = ParseResult
+parseResult :: forall s a. s -> Boolean -> Either ParseError a -> ParseResult s a
+parseResult leftover consumed result = ParseResult
   { leftover: leftover
+  , consumed: consumed
   , result: result
   }
 
-data Parser s a = Parser (s -> Either ParseError (ParseResult s a))
+successResult :: forall s a. s -> Boolean -> a -> ParseResult s a
+successResult leftover consumed result = parseResult leftover consumed (Right result)
 
-runParser :: forall s a. Parser s a -> s -> Either ParseError (ParseResult s a)
-runParser (Parser p) s = p s
+failureResult :: forall s a. s -> Boolean -> ParseError -> ParseResult s a
+failureResult leftover consumed err = parseResult leftover consumed (Left err)
 
-fail :: String -> forall s a. Parser s a
-fail message = Parser $ \s -> Left (parseError message)
+instance Prelude.Functor (ParseResult s) where
+  (<$>) f (ParseResult o) = parseResult o.leftover o.consumed (f <$> o.result)
 
-string :: String -> Parser String String
-string s = Parser $ \s' -> case indexOfS s' s of
-  0 -> Right $ parseResult (substring (lengthS s) (lengthS s') s') s
-  _ -> Left $ parseError $ "Expected \"" ++ s ++ "\""
+data Parser s a = Parser (s -> ParseResult s a)
 
-char :: Parser String String
-char = Parser $ \s -> case s of
-  "" -> Left $ parseError $ "Unexpected EOF"
-  _ -> Right $ parseResult (substring 1 (lengthS s) s) (substr 0 1 s)
+runParser :: forall s a. Parser s a -> s -> ParseResult s a
+runParser (Parser p) s = p s
 
 instance Prelude.Monad (Parser s) where
-  return a = Parser $ \s -> Right (parseResult s a)
-  (>>=) (Parser p) f = Parser $ \s -> case p s of
-    Left err -> Left err
-    Right (ParseResult { leftover = s, result = a }) -> runParser (f a) s
+  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' -- TODO
 
 instance Prelude.Alternative (Parser s) where
   empty = fail "No alternative"
   (<|>) p1 p2 = Parser $ \s -> case runParser p1 s of
-    Left _ -> runParser p2 s
-    Right res -> Right res
+    ParseResult ({ leftover = s', consumed = false, result = Left _ }) -> runParser p2 s
+    res -> res
+
+-- Polymorphic Parser Combinators
+
+fail :: forall s a. String -> Parser s a
+fail message = Parser $ \s -> failureResult s false (parseError message)
+
+(<?>) :: forall s a. Parser s a -> String -> Parser s a
+(<?>) p msg = p <|> fail msg
+
+many :: forall s a. Parser s a -> Parser s [a]
+many p = many1 p <|> return []
+
+many1 :: forall s a. Parser s a -> Parser s [a]
+many1 p = do a <- p
+             as <- many p
+             return (a : as)
+
+between :: forall s a open close. Parser s open -> Parser s close -> ({} -> Parser s a) -> Parser s a
+between open close p = do
+  open
+  a <- p {}
+  close 
+  return a
+
+option :: forall s a. a -> Parser s a -> Parser s a
+option a p = p <|> return a
+
+optional :: forall s a. Parser s a -> Parser s {}
+optional p = (do p
+                 return {}) <|> return {}
+
+optionMaybe :: forall s a. Parser s a -> Parser s (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
+
+sepBy :: forall s a sep. Parser s a -> Parser s sep -> Parser s [a]
+sepBy p sep = sepBy1 p sep <|> return []
+
+sepBy1 :: forall s a sep. Parser s a -> Parser s sep -> Parser s [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 p sep = sepEndBy1 p sep <|> return []
+
+sepEndBy1 :: forall s a sep. Parser s a -> Parser s sep -> Parser s [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 p sep = many1 $ do 
+  a <- p
+  sep
+  return a
+
+endBy :: forall s a sep. Parser s a -> Parser s sep -> Parser s [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 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 p f a = chainl1 p f <|> return a
+
+chainl1 :: forall s a. Parser s a -> Parser s (a -> a -> a) -> Parser s 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' 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 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' p f a = (do f' <- f
+                     a' <- chainr1 p f
+                     return $ f' a a') <|> return a
+
+-- String Parsers
+
+eof :: Parser String {}
+eof = Parser $ \s -> case s of
+  "" -> successResult s false {}
+  _ -> failureResult s false $ parseError "Expected EOF"
+
+string :: String -> Parser String String
+string s = Parser $ \s' -> case indexOfS s' s of
+  0 -> successResult (substring (lengthS s) (lengthS s') s') true s
+  _ -> failureResult s' false $ parseError $ "Expected \"" ++ s ++ "\""
+
+char :: Parser String String
+char = Parser $ \s -> case s of
+  "" -> failureResult s false $ parseError "Unexpected EOF"
+  _ -> successResult (substring 1 (lengthS s) s) true (substr 0 1 s)

test.purs

@@ -4,26 +4,35 @@ import Prelude
 import Either
 import Eff
 import Parsing
-
-parser :: Parser String String
-parser = do
-  s1 <- string "a" <|> string "b"
-  s2 <- string s1
-  return $ s1 ++ s2
+import Trace
+import Arrays
+import Maybe
 
 parens :: forall a. ({} -> Parser String a) -> Parser String a
-parens p = do
-  string "("
-  a <- p {}
-  string ")"
-  return a
+parens = between (string "(") (string ")")
 
 nested :: {} -> Parser String 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) } -> Trace.print err.message
+  ParseResult { result = Right result } -> Trace.print result
+
+opTest = chainl char (do string "+"
+                         return (++)) ""
+
 main = do
-  case runParser (nested {}) "(((a)))" of
-    Left (ParseError err) -> Trace.print err.message
-    Right (ParseResult res) -> Trace.print res.result
+  parseTest (nested {}) "(((a)))"
+  parseTest (many (string "a")) "aaa"
+  parseTest (parens (const $ do
+    string "a"
+    optionMaybe $ string "b")) "(ab)"
+  parseTest (string "a" `sepBy1` string ",") "a,a,a"
+  parseTest (do
+    as <- string "a" `endBy1` string ","
+    eof
+    return as) "a,a,a,"  
+  parseTest opTest "a+b+c"