git.iko.soy/elk
on master help sign in
Fix bugs in parser. Also adds pattern matching in anonymous functions. Still need to work on error messages though.
110944cevancz
elm/src/Parse/ParseLib.hs+31−15
compare with master
unifiedsplit
@@ -2,12 +2,12 @@
2module ParseLib where
2module ParseLib where
3
3
4import Ast
4import Ast
5−import Control.Applicative ((<$>))
5+import Control.Applicative ((<$>),(<*>))
6import Control.Monad
6import Control.Monad
7import Data.Char (isSymbol)
7import Data.Char (isSymbol)
8import Text.Parsec hiding (newline,spaces)
8import Text.Parsec hiding (newline,spaces)
9
9
10−reserved = [ "if", "then", "else"
10+reserveds = [ "if", "then", "else"
11 , "case", "of", "data"
11 , "case", "of", "data"
12 , "let", "in" ]
12 , "let", "in" ]
13
13
@@ -25,18 +25,22 @@ lowVar = makeVar (lower <?> "lower case variable")
25capVar :: (Monad m) => ParsecT [Char] u m String
25capVar :: (Monad m) => ParsecT [Char] u m String
26capVar = makeVar (upper <?> "upper case variable")
26capVar = makeVar (upper <?> "upper case variable")
27
27
28−makeVar p = do
28+innerVarChar :: (Monad m) => ParsecT [Char] u m Char
29− c <- p
30− cs <- many (alphaNum <|> char '_' <|> char '\'' <?> "")
29+innerVarChar = alphaNum <|> char '_' <|> char '\'' <?> ""
31− guard $ c:cs `notElem` reserved
32− return $ c:cs
33
30
31+makeVar p = do v <- (:) <$> p <*> many innerVarChar
32+ guard (v `notElem` reserveds)
33+ return v
34+
35+reserved word =
36+ try (string word >> notFollowedBy innerVarChar) >> return word
37+ <?> "reserved word '" ++ word ++ "'"
34
38
35anyOp :: (Monad m) => ParsecT [Char] u m String
39anyOp :: (Monad m) => ParsecT [Char] u m String
36anyOp = betwixt '`' '`' var <|>
40anyOp = betwixt '`' '`' var <|>
37 (do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
41 (do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
38 guard (op `notElem` [ "=", "..", "->", "--" ])
42 guard (op `notElem` [ "=", "..", "->", "--" ])
39− return op) <?> "infix operator"
43+ return op) <?> "infix operator (e.g. x + y)"
40
44
41arrow :: (Monad m) => ParsecT [Char] u m String
45arrow :: (Monad m) => ParsecT [Char] u m String
42arrow = string "->" <|> string "\8594" <?> "arrow (->)"
46arrow = string "->" <|> string "\8594" <?> "arrow (->)"
@@ -45,20 +49,32 @@ commaSep :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
45commaSep p = do
49commaSep p = do
46 x <- optionMaybe p
50 x <- optionMaybe p
47 case x of
51 case x of
48− Just a -> (a:) <$> many (try (whitespace >> char ',' >> whitespace >> p))
52+ Just a -> (a:) <$> many (try (whitespace >> (char ',' <?> "comma ','")) >>
53+ whitespace >> p)
49 Nothing -> return []
54 Nothing -> return []
50
55
51semiSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
56semiSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
52−semiSep1 p = do a <- p
57+semiSep1 p = do
58+ a <- p
53− (a:) <$> many (try (whitespace >> char ';' >> whitespace >> p))
59+ (a:) <$> many (try (whitespace >> (char ';' <?> "semicolon ';'")) >>
60+ whitespace >> p)
54
61
55pipeSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
62pipeSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
56−pipeSep1 p = do a <- p
63+pipeSep1 p = do
64+ a <- p
57− (a:) <$> many (try (whitespace >> char '|' >> whitespace >> p))
65+ (a:) <$> many (try (whitespace >> (char '|' <?> "type divider '|'")) >>
66+ whitespace >> p)
67+
68+consSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
69+consSep1 p = do
70+ a <- p
71+ (a:) <$> many (try (whitespace >> (char ':' <?> "cons operator ':'")) >>
72+ whitespace >> p)
58
73
59spaceSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
74spaceSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
60−spaceSep1 p = do a <- p
75+spaceSep1 p = (:) <$> p <*> spacePrefix p
61− (a:) <$> many (try (forcedWS >> p))
76+
77+spacePrefix p = many (try (whitespace >> p))
62
78
63betwixt a b c = do char a ; out <- c
79betwixt a b c = do char a ; out <- c
64 char b <?> "closing '" ++ [b] ++ "'" ; return out
80 char b <?> "closing '" ++ [b] ++ "'" ; return out
elm/src/Parse/ParseTypes.hs+8−11
@@ -1,7 +1,7 @@
1module ParseTypes where
1module ParseTypes where
2
2
3import Ast
3import Ast
4−import Control.Applicative ((<$>))
4+import Control.Applicative ((<$>),(<*>))
5import Control.Monad (liftM)
5import Control.Monad (liftM)
6import Data.Char (isUpper,isLower)
6import Data.Char (isUpper,isLower)
7import Data.Maybe (fromMaybe)
7import Data.Maybe (fromMaybe)
@@ -37,7 +37,7 @@ typeSimple = VarPT <$> var
37
37
38typeApp :: (Monad m) => ParsecT [Char] u m ParseType
38typeApp :: (Monad m) => ParsecT [Char] u m ParseType
39typeApp = do name <- capVar
39typeApp = do name <- capVar
40− args <- many (typeSimple <|> typeUnambiguous)
40+ args <- spacePrefix (typeUnambiguous <|> typeSimple)
41 return $ case args of
41 return $ case args of
42 [] -> VarPT name
42 [] -> VarPT name
43 _ -> ADTPT name args
43 _ -> ADTPT name args
@@ -45,20 +45,17 @@ typeApp = do name <- capVar
45typeExpr :: (Monad m) => ParsecT [Char] u m ParseType
45typeExpr :: (Monad m) => ParsecT [Char] u m ParseType
46typeExpr = do
46typeExpr = do
47 t1 <- typeVar <|> typeApp <|> typeUnambiguous
47 t1 <- typeVar <|> typeApp <|> typeUnambiguous
48− whitespace ; arrow <- optionMaybe arrow ; whitespace
48+ whitespace ; arr <- optionMaybe arrow ; whitespace
49− case arrow of Just _ -> LambdaPT t1 <$> typeExpr
49+ case arr of Just _ -> LambdaPT t1 <$> typeExpr
50− Nothing -> return t1
50+ Nothing -> return t1
51
51
52typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType])
52typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType])
53−typeConstructor = do
54− name <- capVar
55− args <- many (try (forcedWS >> (typeSimple <|> typeUnambiguous)))
53+typeConstructor = (,) <$> capVar <*> spacePrefix (typeSimple <|> typeUnambiguous)
56− return $ (,) name args
57
54
58datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], GuidCounter [Type])
55datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], GuidCounter [Type])
59datatype = do
56datatype = do
60− string "data" <?> "datatype definition (data T = A | B | ...)"
57+ reserved "data" <?> "datatype definition (data T = A | B | ...)"
61− forcedWS ; name <- capVar ; args <- many (try (forcedWS >> lowVar))
58+ forcedWS ; name <- capVar ; args <- spacePrefix lowVar
62 whitespace ; string "=" ; whitespace
59 whitespace ; string "=" ; whitespace
63 tcs <- pipeSep1 typeConstructor
60 tcs <- pipeSep1 typeConstructor
64 return $ (map fst tcs , map toFunc tcs , toTypes name args tcs)
61 return $ (map fst tcs , map toFunc tcs , toTypes name args tcs)
elm/src/Parse/Parser.hs+14−13
@@ -32,7 +32,8 @@ toVar v = case v of "True" -> Boolean True
32 _ -> Var v
32 _ -> Var v
33
33
34chrTerm :: (Monad m) => ParsecT [Char] u m Expr
34chrTerm :: (Monad m) => ParsecT [Char] u m Expr
35−chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\'')) <?> "character"
35+chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
36+ <?> "character"
36
37
37
38
38-------- Complex Terms --------
39-------- Complex Terms --------
@@ -67,9 +68,9 @@ appExpr = do
67
68
68binaryExpr = binops appExpr anyOp
69binaryExpr = binops appExpr anyOp
69
70
70−ifExpr = do string "if" ; forcedWS ; e1 <- expr ; forcedWS
71+ifExpr = do reserved "if" ; whitespace ; e1 <- expr ; whitespace
71− string "then" ; forcedWS ; e2 <- expr ; (forcedWS <?> "an 'else' branch")
72+ reserved "then" ; whitespace ; e2 <- expr ; (whitespace <?> "an 'else' branch")
72− string "else" <?> "an 'else' branch" ; forcedWS ; If e1 e2 <$> expr
73+ reserved "else" <?> "an 'else' branch" ; whitespace ; If e1 e2 <$> expr
73
74
74lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
75lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
75 whitespace
76 whitespace
@@ -87,24 +88,24 @@ assignExpr = do
87 fail "matching tuples is not yet supported in this context"
88 fail "matching tuples is not yet supported in this context"
88 else fail $ "Only tuples can be matched in this context, " ++
89 else fail $ "Only tuples can be matched in this context, " ++
89 "not other abstract data types such as lists."
90 "not other abstract data types such as lists."
90− _ -> fail $ "Variables in assign statement are not acceptable: " ++
91+ _ -> fail $ "Left-hand side of assign statement is not acceptable: " ++
91 "only named variables, named functions, and tuples are okay."
92 "only named variables, named functions, and tuples are okay."
92
93
93letExpr = do
94letExpr = do
94− string "let"
95+ reserved "let"
95 brace <- optionMaybe . try $ do
96 brace <- optionMaybe . try $ do
96 whitespace
97 whitespace
97 char '{' <?> "a set of definitions { x = ... ; y = ... }"
98 char '{' <?> "a set of definitions { x = ... ; y = ... }"
98 case brace of
99 case brace of
99− Nothing -> do forcedWS; f <- assignExpr; forcedWS; string "in"; forcedWS;
100+ Nothing -> do whitespace; f <- assignExpr; whitespace; reserved "in"; whitespace
100 Let [f] <$> expr
101 Let [f] <$> expr
101 Just '{' -> do whitespace ; fs <- semiSep1 assignExpr ; whitespace
102 Just '{' -> do whitespace ; fs <- semiSep1 assignExpr ; whitespace
102 string "}" <?> "closing bracket '}'"
103 string "}" <?> "closing bracket '}'"
103− whitespace; string "in"; forcedWS; e <- expr
104+ whitespace; reserved "in"; whitespace; e <- expr
104 return (Let fs e)
105 return (Let fs e)
105
106
106caseExpr = do
107caseExpr = do
107− string "case"; forcedWS; e <- expr; forcedWS; string "of"; whitespace
108+ reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace
108 Case e <$> brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
109 Case e <$> brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
109 where case_ = do p <- patternExpr; whitespace; arrow; whitespace
110 where case_ = do p <- patternExpr; whitespace; arrow; whitespace
110 (,) p <$> expr
111 (,) p <$> expr
@@ -117,14 +118,14 @@ def = do (f,e) <- assignExpr
117
118
118defs1 = do optional freshLine
119defs1 = do optional freshLine
119 d <- datatype <|> def
120 d <- datatype <|> def
120− (d:) <$> many (try (freshLine >> (datatype <|> def)))
121+ (d:) <$> many (try (try freshLine >> (datatype <|> def)))
121
122
122defs = do
123defs = do
123 (fss,ess,tss) <- unzip3 <$> defs1
124 (fss,ess,tss) <- unzip3 <$> defs1
124 let (fs,es,ts) = (concat fss, concat ess, concat `liftM` sequence tss)
125 let (fs,es,ts) = (concat fss, concat ess, concat `liftM` sequence tss)
125− optional freshLine ; optional whitespace ; eof
126+ optional freshLine ; optional spaces ; eof
126 return (Let (zip fs es) (Var "main"), liftM (zip fs) ts)
127 return (Let (zip fs es) (Var "main"), liftM (zip fs) ts)
127
128
128−toDefs source = case parse defs "Elm code" source of
129+toDefs source = case parse defs "" source of
129 Right result -> Right result
130 Right result -> Right result
130− Left err -> Left $ show err
131+ Left err -> Left $ "Parse error at " ++ show err
elm/src/Parse/Patterns.hs+2−10
@@ -16,7 +16,7 @@ patternBasic :: Monad m => ParsecT [Char] u m Pattern
16patternBasic =
16patternBasic =
17 choice [ char '_' >> return PAnything
17 choice [ char '_' >> return PAnything
18 , do x@(c:_) <- var
18 , do x@(c:_) <- var
19− if isUpper c then PData x <$> patternTerm `endBy` whitespace
19+ if isUpper c then PData x <$> spacePrefix patternTerm
20 else return $ PVar x
20 else return $ PVar x
21 ]
21 ]
22
22
@@ -24,14 +24,6 @@ patternTuple :: Monad m => ParsecT [Char] u m Pattern
24patternTuple = do ps <- parens (commaSep patternExpr)
24patternTuple = do ps <- parens (commaSep patternExpr)
25 return $ case ps of { [p] -> p; _ -> ptuple ps }
25 return $ case ps of { [p] -> p; _ -> ptuple ps }
26
26
27−patternCons :: Monad m => ParsecT [Char] u m Pattern
28−patternCons = do
29− p <- patternTerm
30− colon <- optionMaybe (char ':' <?> "more complicated pattern")
31− case colon of
32− Just ':' -> pcons p <$> patternExpr
33− Nothing -> return p
34−
35patternList :: Monad m => ParsecT [Char] u m Pattern
27patternList :: Monad m => ParsecT [Char] u m Pattern
36patternList = plist <$> braces (commaSep patternExpr)
28patternList = plist <$> braces (commaSep patternExpr)
37
29
@@ -39,4 +31,4 @@ patternTerm :: Monad m => ParsecT [Char] u m Pattern
39patternTerm = patternTuple <|> patternList <|> patternBasic <?> "pattern"
31patternTerm = patternTuple <|> patternList <|> patternBasic <?> "pattern"
40
32
41patternExpr :: Monad m => ParsecT [Char] u m Pattern
33patternExpr :: Monad m => ParsecT [Char] u m Pattern
42−patternExpr = patternTuple <|> patternList <|> patternCons <?> "pattern"
34+patternExpr = foldl1 pcons <$> consSep1 patternTerm <?> "pattern"