Fix bugs in parser. Also adds pattern matching in anonymous functions. Still need to work on error messages though.

elm/src/Parse/ParseLib.hs

@@ -2,12 +2,12 @@
 module ParseLib where
 
 import Ast
-import Control.Applicative ((<$>))
+import Control.Applicative ((<$>),(<*>))
 import Control.Monad
 import Data.Char (isSymbol)
 import Text.Parsec hiding (newline,spaces)
 
-reserved = [ "if", "then", "else"
+reserveds = [ "if", "then", "else"
            , "case", "of", "data"
            , "let", "in" ]
 
@@ -25,18 +25,22 @@ lowVar = makeVar (lower <?> "lower case variable")
 capVar :: (Monad m) => ParsecT [Char] u m String
 capVar = makeVar (upper <?> "upper case variable")
 
-makeVar p = do
+innerVarChar :: (Monad m) => ParsecT [Char] u m Char
-  c <- p
+innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> "" 
-  cs <- many (alphaNum <|> char '_' <|> char '\'' <?> "")
-  guard $ c:cs `notElem` reserved
-  return $ c:cs
 
+makeVar p = do v <- (:) <$> p <*> many innerVarChar
+               guard (v `notElem` reserveds)
+               return v
+
+reserved word =
+  try (string word >> notFollowedBy innerVarChar) >> return word
+  <?> "reserved word '" ++ word ++ "'"
 
 anyOp :: (Monad m) => ParsecT [Char] u m String
 anyOp = betwixt '`' '`' var <|>
         (do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
             guard (op `notElem` [ "=", "..", "->", "--" ])
-            return op) <?> "infix operator"
+            return op) <?> "infix operator (e.g. x + y)"
 
 arrow :: (Monad m) => ParsecT [Char] u m String
 arrow = string "->" <|> string "\8594" <?> "arrow (->)"
@@ -45,20 +49,32 @@ commaSep :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
 commaSep p = do
   x <- optionMaybe p
   case x of
-    Just a  -> (a:) <$> many (try (whitespace >> char ',' >> whitespace >> p))
+    Just a  -> (a:) <$> many (try (whitespace >> (char ',' <?> "comma ','")) >>
+                              whitespace >> p)
     Nothing -> return []
 
 semiSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
-semiSep1 p = do a <- p
+semiSep1 p = do
-                (a:) <$> many (try (whitespace >> char ';' >> whitespace >> p))
+  a <- p
+  (a:) <$> many (try (whitespace >> (char ';' <?> "semicolon ';'")) >>
+                 whitespace >> p)
 
 pipeSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
-pipeSep1 p = do a <- p
+pipeSep1 p = do
-                (a:) <$> many (try (whitespace >> char '|' >> whitespace >> p))
+  a <- p
+  (a:) <$> many (try (whitespace >> (char '|' <?> "type divider '|'")) >>
+                 whitespace >> p)
+
+consSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
+consSep1 p = do
+  a <- p
+  (a:) <$> many (try (whitespace >> (char ':' <?> "cons operator ':'")) >>
+                 whitespace >> p)
 
 spaceSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
-spaceSep1 p = do a <- p
+spaceSep1 p =  (:) <$> p <*> spacePrefix p
-                 (a:) <$> many (try (forcedWS >> p))
+
+spacePrefix p = many (try (whitespace >> p))
 
 betwixt a b c = do char a ; out <- c
                    char b <?> "closing '" ++ [b] ++ "'" ; return out

elm/src/Parse/ParseTypes.hs

@@ -1,7 +1,7 @@
 module ParseTypes where
 
 import Ast
-import Control.Applicative ((<$>))
+import Control.Applicative ((<$>),(<*>))
 import Control.Monad (liftM)
 import Data.Char (isUpper,isLower)
 import Data.Maybe (fromMaybe)
@@ -37,7 +37,7 @@ typeSimple = VarPT <$> var
 
 typeApp :: (Monad m) => ParsecT [Char] u m ParseType
 typeApp = do name <- capVar
-             args <- many (typeSimple <|> typeUnambiguous)
+             args <- spacePrefix (typeUnambiguous <|> typeSimple)
              return $ case args of
                         [] -> VarPT name
                         _  -> ADTPT name args
@@ -45,20 +45,17 @@ typeApp = do name <- capVar
 typeExpr :: (Monad m) => ParsecT [Char] u m ParseType
 typeExpr = do
   t1 <- typeVar <|> typeApp <|> typeUnambiguous
-  whitespace ; arrow <- optionMaybe arrow ; whitespace
+  whitespace ; arr <- optionMaybe arrow ; whitespace
-  case arrow of Just _  -> LambdaPT t1 <$> typeExpr
+  case arr of Just _  -> LambdaPT t1 <$> typeExpr
               Nothing -> return t1
 
 typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType])
-typeConstructor = do
+typeConstructor = (,) <$> capVar <*> spacePrefix (typeSimple <|> typeUnambiguous)
-  name <- capVar
-  args <- many (try (forcedWS >> (typeSimple <|> typeUnambiguous)))
-  return $ (,) name args
 
 datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], GuidCounter [Type])
 datatype = do
-  string "data" <?> "datatype definition (data T = A | B | ...)"
+  reserved "data" <?> "datatype definition (data T = A | B | ...)"
-  forcedWS ; name <- capVar ; args <- many (try (forcedWS >> lowVar))
+  forcedWS ; name <- capVar ; args <- spacePrefix lowVar
   whitespace ; string "=" ; whitespace
   tcs <- pipeSep1 typeConstructor
   return $ (map fst tcs , map toFunc tcs , toTypes name args tcs)

elm/src/Parse/Parser.hs

@@ -32,7 +32,8 @@ toVar v = case v of "True"  -> Boolean True
                     _       -> Var v
 
 chrTerm :: (Monad m) => ParsecT [Char] u m Expr
-chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\'')) <?> "character"
+chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
+          <?> "character"
 
 
 --------  Complex Terms  --------
@@ -67,9 +68,9 @@ appExpr = do
 
 binaryExpr = binops appExpr anyOp
 
-ifExpr = do string "if"   ; forcedWS ; e1 <- expr ; forcedWS
+ifExpr = do reserved "if"   ; whitespace ; e1 <- expr ; whitespace
-            string "then" ; forcedWS ; e2 <- expr ; (forcedWS <?> "an 'else' branch")
+            reserved "then" ; whitespace ; e2 <- expr ; (whitespace <?> "an 'else' branch")
-            string "else" <?> "an 'else' branch" ; forcedWS ; If e1 e2 <$> expr
+            reserved "else" <?> "an 'else' branch" ; whitespace ; If e1 e2 <$> expr
 
 lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
                 whitespace
@@ -87,24 +88,24 @@ assignExpr = do
                         fail "matching tuples is not yet supported in this context"
                     else fail $ "Only tuples can be matched in this context, " ++
                                 "not other abstract data types such as lists."
-    _ -> fail $ "Variables in assign statement are not acceptable: " ++
+    _ -> fail $ "Left-hand side of assign statement is not acceptable: " ++
                 "only named variables, named functions, and tuples are okay."
 
 letExpr = do
-  string "let"
+  reserved "let"
   brace <- optionMaybe . try $ do
              whitespace
              char '{' <?> "a set of definitions { x = ... ; y = ... }"
   case brace of
-    Nothing -> do forcedWS; f <- assignExpr; forcedWS; string "in"; forcedWS;
+    Nothing -> do whitespace; f <- assignExpr; whitespace; reserved "in"; whitespace
                   Let [f] <$> expr
     Just '{' -> do whitespace ; fs <- semiSep1 assignExpr ; whitespace
                    string "}" <?> "closing bracket '}'"
-                   whitespace; string "in"; forcedWS; e <- expr
+                   whitespace; reserved "in"; whitespace; e <- expr
                    return (Let fs e)
 
 caseExpr = do
-  string "case"; forcedWS; e <- expr; forcedWS; string "of"; whitespace
+  reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace
   Case e <$> brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
     where case_ = do p <- patternExpr; whitespace; arrow; whitespace
                      (,) p <$> expr
@@ -117,14 +118,14 @@ def = do (f,e) <- assignExpr
 
 defs1 = do optional freshLine
            d <- datatype <|> def
-           (d:) <$> many (try (freshLine >> (datatype <|> def)))
+           (d:) <$> many (try (try freshLine >> (datatype <|> def)))
 
 defs = do
   (fss,ess,tss) <- unzip3 <$> defs1
   let (fs,es,ts) = (concat fss, concat ess, concat `liftM` sequence tss)
-  optional freshLine ; optional whitespace ; eof
+  optional freshLine ; optional spaces ; eof
   return (Let (zip fs es) (Var "main"), liftM (zip fs) ts)
 
-toDefs source = case parse defs "Elm code" source of
+toDefs source = case parse defs "" source of
                   Right result -> Right result
-                  Left err -> Left $ show err
+                  Left err -> Left $ "Parse error at " ++ show err

elm/src/Parse/Patterns.hs

@@ -16,7 +16,7 @@ patternBasic :: Monad m => ParsecT [Char] u m Pattern
 patternBasic =
     choice [ char '_' >> return PAnything
            , do x@(c:_) <- var
-                if isUpper c then PData x <$> patternTerm `endBy` whitespace
+                if isUpper c then PData x <$> spacePrefix patternTerm
                              else return $ PVar x
            ]
 
@@ -24,14 +24,6 @@ patternTuple :: Monad m => ParsecT [Char] u m Pattern
 patternTuple = do ps <- parens (commaSep patternExpr)
                   return $ case ps of { [p] -> p; _ -> ptuple ps }
 
-patternCons :: Monad m => ParsecT [Char] u m Pattern
-patternCons = do
-  p <- patternTerm
-  colon <- optionMaybe (char ':' <?> "more complicated pattern")
-  case colon of
-    Just ':' -> pcons p <$> patternExpr
-    Nothing -> return p
-
 patternList :: Monad m => ParsecT [Char] u m Pattern
 patternList = plist <$> braces (commaSep patternExpr)
 
@@ -39,4 +31,4 @@ patternTerm :: Monad m => ParsecT [Char] u m Pattern
 patternTerm = patternTuple <|> patternList <|> patternBasic <?> "pattern"
 
 patternExpr :: Monad m => ParsecT [Char] u m Pattern
-patternExpr = patternTuple <|> patternList <|> patternCons <?> "pattern"
+patternExpr = foldl1 pcons <$> consSep1 patternTerm <?> "pattern"