git.iko.soy/elk
on master help sign in
Many bug fixes for new parser. Mainly dealing with spacing issues which cause botched parses.
c6a5ef4evancz
elm/src/Parse/Binops.hs+8−5
compare with master
unifiedsplit
@@ -27,10 +27,14 @@ sortOps = sortBy (\(i,_,_) (j,_,_) -> compare i j)
27
27
28binops term anyOp = do
28binops term anyOp = do
29 e <- term
29 e <- term
30− (ops,es) <- liftM unzip $ many (do { op <- lexeme anyOp; e <- term; return (op,e) })
30+ (ops,es) <- liftM unzip $
31+ many (try $ do { whitespace
32+ ; op <- anyOp
33+ ; whitespace
34+ ; e <- term; return (op,e) })
31 case binopOf Map.empty (sortOps table) ops (e:es) of
35 case binopOf Map.empty (sortOps table) ops (e:es) of
32 Right e -> return e
36 Right e -> return e
33− Left msg -> mzero
37+ Left msg -> fail msg
34
38
35binopSplit seen opTable i ops es =
39binopSplit seen opTable i ops es =
36 case (splitAt i ops, splitAt (i+1) es) of
40 case (splitAt i ops, splitAt (i+1) es) of
@@ -40,8 +44,7 @@ binopSplit seen opTable i ops es =
40 return $ Binop op e1 e2
44 return $ Binop op e1 e2
41
45
42binopOf _ _ _ [e] = return e
46binopOf _ _ _ [e] = return e
43−binopOf _ [] ops es =
47+binopOf seen [] ops es = binopOf seen [(9,L,head ops)] ops es
44− return $ foldl' (flip ($)) (head es) $ zipWith Binop ops (tail es)
45
48
46binopOf seen (tbl@((lvl, L, op):rest)) ops es =
49binopOf seen (tbl@((lvl, L, op):rest)) ops es =
47 case elemIndices op ops of
50 case elemIndices op ops of
@@ -54,7 +57,7 @@ binopOf seen (tbl@((lvl, assoc, op):rest)) ops es =
54 case elemIndices op ops of
57 case elemIndices op ops of
55 [] -> binopOf seen rest ops es
58 [] -> binopOf seen rest ops es
56 i:_ -> case Map.lookup lvl seen of
59 i:_ -> case Map.lookup lvl seen of
57− Nothing -> binopSplit (Map.insert lvl (R,op) seen) tbl i ops es
60+ Nothing -> binopSplit (Map.insert lvl (assoc,op) seen) tbl i ops es
58 Just (assoc',op') ->
61 Just (assoc',op') ->
59 if assoc == assoc' && assoc /= N then
62 if assoc == assoc' && assoc /= N then
60 binopSplit seen tbl i ops es
63 binopSplit seen tbl i ops es
elm/src/Parse/ParseLib.hs+45−22
@@ -2,6 +2,7 @@
2module ParseLib where
2module ParseLib where
3
3
4import Ast
4import Ast
5+import Control.Applicative ((<$>))
5import Control.Monad
6import Control.Monad
6import Data.Char (isSymbol)
7import Data.Char (isSymbol)
7import Text.Parsec hiding (newline,spaces)
8import Text.Parsec hiding (newline,spaces)
@@ -17,7 +18,7 @@ backslashed = do { char '\\'; c <- anyChar
17 ; return . read $ ['\'','\\',c,'\''] }
18 ; return . read $ ['\'','\\',c,'\''] }
18
19
19var :: (Monad m) => ParsecT [Char] u m String
20var :: (Monad m) => ParsecT [Char] u m String
20−var = makeVar $ letter <|> char '_'
21+var = makeVar (letter <|> char '_' <?> "variable")
21
22
22lowVar :: (Monad m) => ParsecT [Char] u m String
23lowVar :: (Monad m) => ParsecT [Char] u m String
23lowVar = makeVar (lower <?> "lower case variable")
24lowVar = makeVar (lower <?> "lower case variable")
@@ -26,7 +27,7 @@ capVar = makeVar (upper <?> "upper case variable")
26
27
27makeVar p = do
28makeVar p = do
28 c <- p
29 c <- p
29− cs <- many $ alphaNum <|> char '_' <|> char '\''
30+ cs <- many (alphaNum <|> char '_' <|> char '\'' <?> "")
30 guard $ c:cs `notElem` reserved
31 guard $ c:cs `notElem` reserved
31 return $ c:cs
32 return $ c:cs
32
33
@@ -34,64 +35,86 @@ makeVar p = do
34anyOp :: (Monad m) => ParsecT [Char] u m String
35anyOp :: (Monad m) => ParsecT [Char] u m String
35anyOp = betwixt '`' '`' var <|>
36anyOp = betwixt '`' '`' var <|>
36 (do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
37 (do op <- many1 (satisfy isSymbol <|> oneOf "+-/*=.$<>:&|^?%#@~!")
37− guard (op `notElem` [ "=", "..", "->" ])
38+ guard (op `notElem` [ "=", "..", "->", "--" ])
38 return op) <?> "infix operator"
39 return op) <?> "infix operator"
39
40
40−lexeme p = do whitespace ; p
41+arrow :: (Monad m) => ParsecT [Char] u m String
42+arrow = string "->" <|> string "\8594" <?> "arrow (->)"
41
43
42−symbol :: (Monad m) => String -> ParsecT [Char] u m String
44+commaSep :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
43−symbol s = whitespace >> string s
45+commaSep p = do
46+ x <- optionMaybe p
47+ case x of
48+ Just a -> (a:) <$> many (try (whitespace >> char ',' >> whitespace >> p))
49+ Nothing -> return []
44
50
45−arrow :: (Monad m) => ParsecT [Char] u m String
51+semiSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
46−arrow = symbol "->" <|> symbol "\8594"
52+semiSep1 p = do a <- p
53+ (a:) <$> many (try (whitespace >> char ';' >> whitespace >> p))
54+
55+pipeSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
56+pipeSep1 p = do a <- p
57+ (a:) <$> many (try (whitespace >> char '|' >> whitespace >> p))
47
58
48−commaSep p = p `sepBy` lexeme (char ',')
59+spaceSep1 :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m [a]
60+spaceSep1 p = do a <- p
61+ (a:) <$> many (try (forcedWS >> p))
49
62
50−
51betwixt a b c = do char a ; out <- c
63betwixt a b c = do char a ; out <- c
52 char b <?> "closing '" ++ [b] ++ "'" ; return out
64 char b <?> "closing '" ++ [b] ++ "'" ; return out
53−betwixtSpcs a b c = do char a ; whitespace ; out <- c ; whitespace
54− char b <?> "closing '" ++ [b] ++ "'" ; return out
55
65
56−listOf p = betwixtSpcs '[' ']' $ p `sepBy` lexeme (char ',')
66+surround a z name p = do
67+ char a ; whitespace ; a <- p ; whitespace
68+ char z <?> unwords ["closing", name, show z]
69+ return a
70+
71+braces :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a
72+braces = surround '[' ']' "brace"
73+
74+parens :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a
75+parens = surround '(' ')' "paren"
76+
77+brackets :: (Monad m) => ParsecT [Char] u m a -> ParsecT [Char] u m a
78+brackets = surround '{' '}' "bracket"
57
79
58accessible expr = do
80accessible expr = do
59 e <- expr
81 e <- expr
60− access <- optionMaybe (char '.')
82+ access <- optionMaybe . try $
83+ (do { char '.' ; notFollowedBy (char '.') } <?> "field access (e.g. List.map)")
61 case access of
84 case access of
62− Just '.' -> accessible (Access e `liftM` var)
85+ Just _ -> accessible (Access e `liftM` var <?> "field access (e.g. List.map)")
63 Nothing -> return e
86 Nothing -> return e
64
87
65
88
66spaces :: (Monad m) => ParsecT [Char] u m String
89spaces :: (Monad m) => ParsecT [Char] u m String
67−spaces = many1 ((multiComment <|> string " ") >> return ' ') <?> "spaces"
90+spaces = many1 ((multiComment <|> string " " <?> "") >> return ' ') <?> "spaces"
68
91
69forcedWS :: (Monad m) => ParsecT [Char] u m [String]
92forcedWS :: (Monad m) => ParsecT [Char] u m [String]
70forcedWS = try (do { spaces; many nl_space }) <|> try (many1 nl_space)
93forcedWS = try (do { spaces; many nl_space }) <|> try (many1 nl_space)
71 where nl_space = try $ many1 newline >> spaces
94 where nl_space = try $ many1 newline >> spaces
72
95
73whitespace :: (Monad m) => ParsecT [Char] u m ()
96whitespace :: (Monad m) => ParsecT [Char] u m ()
74−whitespace = optional forcedWS <?> "whitespace"
97+whitespace = optional forcedWS <?> ""
75
98
76freshLine :: (Monad m) => ParsecT [Char] u m [[String]]
99freshLine :: (Monad m) => ParsecT [Char] u m [[String]]
77−freshLine = try (do { many1 newline; many space_nl }) <|> try (many1 space_nl) <?> "fresh line"
100+freshLine = try (do { many1 newline; many space_nl }) <|> try (many1 space_nl) <?> ""
78 where space_nl = try $ spaces >> many1 newline
101 where space_nl = try $ spaces >> many1 newline
79
102
80newline :: (Monad m) => ParsecT [Char] u m String
103newline :: (Monad m) => ParsecT [Char] u m String
81−newline = simpleNewline <|> lineComment <?> "newline"
104+newline = simpleNewline <|> lineComment <?> ""
82
105
83simpleNewline :: (Monad m) => ParsecT [Char] u m String
106simpleNewline :: (Monad m) => ParsecT [Char] u m String
84simpleNewline = try (string "\r\n") <|> string "\n"
107simpleNewline = try (string "\r\n") <|> string "\n"
85
108
86lineComment :: (Monad m) => ParsecT [Char] u m String
109lineComment :: (Monad m) => ParsecT [Char] u m String
87−lineComment = do try $ string "--"
110+lineComment = do try (string "--")
88 manyTill anyChar $ simpleNewline <|> (eof >> return "\n")
111 manyTill anyChar $ simpleNewline <|> (eof >> return "\n")
89
112
90multiComment :: (Monad m) => ParsecT [Char] u m String
113multiComment :: (Monad m) => ParsecT [Char] u m String
91−multiComment = do { try $ string "{-"; closeComment }
114+multiComment = do { try (string "{-"); closeComment }
92
115
93closeComment :: (Monad m) => ParsecT [Char] u m String
116closeComment :: (Monad m) => ParsecT [Char] u m String
94closeComment = manyTill anyChar . choice $
117closeComment = manyTill anyChar . choice $
95− [ try $ string "-}"
118+ [ try (string "-}") <?> "close comment"
96 , do { try $ string "{-"; closeComment; closeComment }
119 , do { try $ string "{-"; closeComment; closeComment }
97 ]
120 ]
elm/src/Parse/ParseTypes.hs+12−11
@@ -9,7 +9,7 @@ import Data.List (lookup)
9import Text.Parsec
9import Text.Parsec
10
10
11import ParseLib
11import ParseLib
12−import Types
12+import Types hiding (string,parens)
13import Guid
13import Guid
14
14
15data ParseType = VarPT String
15data ParseType = VarPT String
@@ -23,10 +23,10 @@ typeVar :: (Monad m) => ParsecT [Char] u m ParseType
23typeVar = VarPT <$> lowVar <?> "type variable"
23typeVar = VarPT <$> lowVar <?> "type variable"
24
24
25typeList :: (Monad m) => ParsecT [Char] u m ParseType
25typeList :: (Monad m) => ParsecT [Char] u m ParseType
26−typeList = listPT <$> betwixtSpcs '[' ']' typeExpr
26+typeList = listPT <$> braces typeExpr
27
27
28typeTuple :: (Monad m) => ParsecT [Char] u m ParseType
28typeTuple :: (Monad m) => ParsecT [Char] u m ParseType
29−typeTuple = do ts <- betwixtSpcs '(' ')' (commaSep typeExpr)
29+typeTuple = do ts <- parens (commaSep typeExpr)
30 return $ case ts of { [t] -> t ; _ -> tuplePT ts }
30 return $ case ts of { [t] -> t ; _ -> tuplePT ts }
31
31
32typeUnambiguous :: (Monad m) => ParsecT [Char] u m ParseType
32typeUnambiguous :: (Monad m) => ParsecT [Char] u m ParseType
@@ -44,22 +44,23 @@ typeApp = do name <- capVar
44
44
45typeExpr :: (Monad m) => ParsecT [Char] u m ParseType
45typeExpr :: (Monad m) => ParsecT [Char] u m ParseType
46typeExpr = do
46typeExpr = do
47− whitespace
48 t1 <- typeVar <|> typeApp <|> typeUnambiguous
47 t1 <- typeVar <|> typeApp <|> typeUnambiguous
49− arrow <- optionMaybe arrow
48+ whitespace ; arrow <- optionMaybe arrow ; whitespace
50 case arrow of Just _ -> LambdaPT t1 <$> typeExpr
49 case arrow of Just _ -> LambdaPT t1 <$> typeExpr
51 Nothing -> return t1
50 Nothing -> return t1
52
51
53typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType])
52typeConstructor :: (Monad m) => ParsecT [Char] u m (String, [ParseType])
54−typeConstructor = do name <- capVar
53+typeConstructor = do
54+ name <- capVar
55− args <- many (typeSimple <|> typeUnambiguous)
55+ args <- many (try (forcedWS >> (typeSimple <|> typeUnambiguous)))
56− return $ (,) name args
56+ return $ (,) name args
57
57
58datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], GuidCounter [Type])
58datatype :: (Monad m) => ParsecT [Char] u m ([String], [Expr], GuidCounter [Type])
59datatype = do
59datatype = do
60− symbol "data" <?> "datatype definition"
60+ string "data" <?> "datatype definition (data T = A | B | ...)"
61− name <- capVar ; args <- many lowVar ; symbol "="
61+ forcedWS ; name <- capVar ; args <- many (try (forcedWS >> lowVar))
62+ whitespace ; string "=" ; whitespace
62− tcs <- typeConstructor `sepBy1` symbol "|"
63+ tcs <- pipeSep1 typeConstructor
63 return $ (map fst tcs , map toFunc tcs , toTypes name args tcs)
64 return $ (map fst tcs , map toFunc tcs , toTypes name args tcs)
64
65
65beta = liftM VarT guid
66beta = liftM VarT guid
elm/src/Parse/Parser.hs+35−30
@@ -37,27 +37,28 @@ chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\'')) <?> "char
37
37
38-------- Complex Terms --------
38-------- Complex Terms --------
39
39
40−listTerm = expecting "list" . betwixtSpcs '[' ']' $ choice
40+listTerm = braces $ choice
41+ [ try $ do { lo <- expr; whitespace; string ".." ; whitespace
41− [ try $ do { lo <- expr; symbol ".." ; Range lo <$> expr }
42+ ; Range lo <$> expr }
42 , list <$> commaSep expr
43 , list <$> commaSep expr
43 ]
44 ]
44
45
45−parensTerm = expecting "parenthesized expression" . betwixtSpcs '(' ')' $ choice
46+parensTerm = parens $ choice
46 [ do op <- anyOp
47 [ do op <- anyOp
47 return . Lambda "x" . Lambda "y" $ Binop op (Var "x") (Var "y")
48 return . Lambda "x" . Lambda "y" $ Binop op (Var "x") (Var "y")
48 , do es <- commaSep expr
49 , do es <- commaSep expr
49 return $ case es of { [e] -> e; _ -> tuple es }
50 return $ case es of { [e] -> e; _ -> tuple es }
50 ]
51 ]
51
52
52−term = lexeme (choice [ numTerm, strTerm, chrTerm
53+term = choice [ numTerm, strTerm, chrTerm
53− , accessible varTerm
54+ , accessible varTerm
54− , listTerm, parensTerm ])
55+ , listTerm, parensTerm ]
55 <?> "basic term (number, variable, etc.)"
56 <?> "basic term (number, variable, etc.)"
56
57
57-------- Applications --------
58-------- Applications --------
58
59
59appExpr = do
60appExpr = do
60− tlist <- many1 (try term)
61+ tlist <- spaceSep1 term
61 return $ case tlist of
62 return $ case tlist of
62 t:[] -> t
63 t:[] -> t
63 t:ts -> foldl' App t ts
64 t:ts -> foldl' App t ts
@@ -66,20 +67,20 @@ appExpr = do
66
67
67binaryExpr = binops appExpr anyOp
68binaryExpr = binops appExpr anyOp
68
69
69−ifExpr = expecting "if expression" $
70+ifExpr = do string "if" ; forcedWS ; e1 <- expr ; forcedWS
70− do symbol "if" ; e1 <- expr
71+ string "then" ; forcedWS ; e2 <- expr ; (forcedWS <?> "an 'else' branch")
71− symbol "then" ; e2 <- expr
72− expecting "else branch" $ do
73− symbol "else" ; If e1 e2 <$> expr
72+ string "else" <?> "an 'else' branch" ; forcedWS ; If e1 e2 <$> expr
74
73
75−lambdaExpr = do lexeme $ oneOf "\\\x03BB"
74+lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
75+ whitespace
76− args <- patternTerm `endBy1` whitespace
76+ args <- spaceSep1 patternTerm
77− arrow
77+ whitespace ; arrow ; whitespace
78 e <- expr
78 e <- expr
79 return $ makeFunction args e
79 return $ makeFunction args e
80
80
81assignExpr = do
81assignExpr = do
82− patterns <- (patternTerm <?> "definition") `endBy1` whitespace; symbol "="; exp <- expr
82+ patterns <- spaceSep1 (patternTerm <?> "the definition of a variable (x = ...)")
83+ whitespace; string "="; whitespace; exp <- expr
83 case patterns of
84 case patterns of
84 PVar f : args -> return (f, makeFunction args exp)
85 PVar f : args -> return (f, makeFunction args exp)
85 [PData x ps] -> if "Tuple" == take 5 x && all isDigit (drop 5 x) then
86 [PData x ps] -> if "Tuple" == take 5 x && all isDigit (drop 5 x) then
@@ -90,32 +91,36 @@ assignExpr = do
90 "only named variables, named functions, and tuples are okay."
91 "only named variables, named functions, and tuples are okay."
91
92
92letExpr = do
93letExpr = do
94+ string "let"
93− symbol "let"; brace <- optionMaybe . lexeme $ char '{'
95+ brace <- optionMaybe . try $ do
96+ whitespace
97+ char '{' <?> "a set of definitions { x = ... ; y = ... }"
94 case brace of
98 case brace of
95− Nothing -> do f <- assignExpr; symbol "in"; e <- expr; return (Let [f] e)
99+ Nothing -> do forcedWS; f <- assignExpr; forcedWS; string "in"; forcedWS;
96− Just '{' -> do fs <- assignExpr `sepBy1` symbol ";"
100+ Let [f] <$> expr
97− symbol "}" ; symbol "in"; e <- expr
101+ Just '{' -> do whitespace ; fs <- semiSep1 assignExpr ; whitespace
102+ string "}" <?> "closing bracket '}'"
103+ whitespace; string "in"; forcedWS; e <- expr
98 return (Let fs e)
104 return (Let fs e)
99
105
100caseExpr = do
106caseExpr = do
101− symbol "case"; e <- expr; symbol "of"
107+ string "case"; forcedWS; e <- expr; forcedWS; string "of"; whitespace
102− betwixtSpcs '{' '}' $ Case e <$> case_ `sepBy1` symbol ";"
108+ Case e <$> brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
103− where case_ = do p <- patternExpr; whitespace; arrow; e <- expr; return (p,e)
109+ where case_ = do p <- patternExpr; whitespace; arrow; whitespace
110+ (,) p <$> expr
104
111
105
112
106−expr = choice [ ifExpr, letExpr, caseExpr, lambdaExpr, binaryExpr ]
113+expr = choice [ ifExpr, letExpr, caseExpr, lambdaExpr, binaryExpr ] <?> "expression"
107
114
108def = do (f,e) <- assignExpr
115def = do (f,e) <- assignExpr
109 return ([f], [e], guid >>= \x -> return [VarT x])
116 return ([f], [e], guid >>= \x -> return [VarT x])
110
117
111−manyDefs = try (do { d <- anyDef ; ds <- many freshDef ; return (d:ds) })
118+defs1 = do optional freshLine
112− <|> try (many1 freshDef)
119+ d <- datatype <|> def
113− where freshDef = try $ many1 freshLine >> anyDef
120+ (d:) <$> many (try (freshLine >> (datatype <|> def)))
114− anyDef = def <|> datatype
115
121
116defs = do
122defs = do
117− ds <- manyDefs
118− let (fss,ess,tss) = unzip3 ds
123+ (fss,ess,tss) <- unzip3 <$> defs1
119 let (fs,es,ts) = (concat fss, concat ess, concat `liftM` sequence tss)
124 let (fs,es,ts) = (concat fss, concat ess, concat `liftM` sequence tss)
120 optional freshLine ; optional whitespace ; eof
125 optional freshLine ; optional whitespace ; eof
121 return (Let (zip fs es) (Var "main"), liftM (zip fs) ts)
126 return (Let (zip fs es) (Var "main"), liftM (zip fs) ts)
elm/src/Parse/Patterns.hs+3−3
@@ -21,19 +21,19 @@ patternBasic =
21 ]
21 ]
22
22
23patternTuple :: Monad m => ParsecT [Char] u m Pattern
23patternTuple :: Monad m => ParsecT [Char] u m Pattern
24−patternTuple = do ps <- betwixtSpcs '(' ')' $ patternExpr `sepBy` lexeme (char ',')
24+patternTuple = 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
27patternCons :: Monad m => ParsecT [Char] u m Pattern
27patternCons :: Monad m => ParsecT [Char] u m Pattern
28patternCons = do
28patternCons = do
29 p <- patternTerm
29 p <- patternTerm
30− colon <- optionMaybe (char ':')
30+ colon <- optionMaybe (char ':' <?> "more complicated pattern")
31 case colon of
31 case colon of
32 Just ':' -> pcons p <$> patternExpr
32 Just ':' -> pcons p <$> patternExpr
33 Nothing -> return p
33 Nothing -> return p
34
34
35patternList :: Monad m => ParsecT [Char] u m Pattern
35patternList :: Monad m => ParsecT [Char] u m Pattern
36−patternList = plist <$> listOf patternExpr
36+patternList = plist <$> braces (commaSep patternExpr)
37
37
38patternTerm :: Monad m => ParsecT [Char] u m Pattern
38patternTerm :: Monad m => ParsecT [Char] u m Pattern
39patternTerm = patternTuple <|> patternList <|> patternBasic <?> "pattern"
39patternTerm = patternTuple <|> patternList <|> patternBasic <?> "pattern"