@@ -1,121 +1,131 @@
1−module Parser where
1+module Parser (toDefs) where
22
33import Ast
4−import Binop (binops)
5−import Combinators
6−import Control.Monad (liftM)
4+import Control.Applicative ((<$>), (<*>))
5+import Control.Monad
6+import Data.Char (isSymbol, isDigit)
77import Data.List (foldl')
8+import Text.Parsec hiding (newline,spaces)
9+
10+import ParseLib
11+import Patterns
12+import Binops
13+import ParseTypes
14+
815import Guid
9−import Lexer
10−import ParserLib
11−import ParseTypes (datatype)
12−import ParsePatterns
13−import Tokens
1416import Types (Type (VarT))
1517
1618-------- Basic Terms --------
1719
18−numTerm = do { whitespace; t <- item
19− ; case t of { NUMBER n -> return $ Number n; _ -> zero } }
20−strTerm = do { whitespace; t <- item
21− ; case t of { STRING cs -> return $ Str cs
22− ; _ -> zero } }
20+numTerm :: (Monad m) => ParsecT [Char] u m Expr
21+numTerm = liftM (Number . read) (many1 digit) <?> "number"
22+
23+strTerm :: (Monad m) => ParsecT [Char] u m Expr
24+strTerm = liftM Str . expecting "string" . betwixt '"' '"' . many $
25+ backslashed <|> satisfy (/='"')
26+
27+varTerm :: (Monad m) => ParsecT [Char] u m Expr
28+varTerm = toVar <$> var <?> "variable"
2329
24−varTerm = Var `liftM` var
25−chrTerm = Chr `liftM` chr
30+toVar v = case v of "True" -> Boolean True
31+ "False" -> Boolean False
32+ _ -> Var v
2633
27−trueTerm = do { t TRUE; return $ Boolean True }
28−falseTerm = do { t FALSE; return $ Boolean False }
34+chrTerm :: (Monad m) => ParsecT [Char] u m Expr
35+chrTerm = Chr <$> betwixt '\'' '\'' (backslashed <|> satisfy (/='\''))
36+ <?> "character"
2937
3038
3139-------- Complex Terms --------
3240
33−listTerm = (do { t LBRACKET; start <- expr; t DOT2; end <- expr; t RBRACKET
34− ; return $ Range start end }) +|+
35− (do { t LBRACKET; es <- sepBy (t COMMA) expr; t RBRACKET
36− ; return $ list es })
41+listTerm = braces $ choice
42+ [ try $ do { lo <- expr; whitespace; string ".." ; whitespace
43+ ; Range lo <$> expr }
44+ , list <$> commaSep expr
45+ ]
3746
38−parensTerm = (do { t LPAREN; op <- anyOp; t RPAREN
39− ; return . Lambda "x" . Lambda "y" $
40− Binop op (Var "x") (Var "y") }) +|+
41− (do { t LPAREN; es <- sepBy (t COMMA) expr; t RPAREN
42− ; return $ case es of { [e] -> e; _ -> tuple es } })
47+parensTerm = parens $ choice
48+ [ do op <- anyOp
49+ return . Lambda "x" . Lambda "y" $ Binop op (Var "x") (Var "y")
50+ , do es <- commaSep expr
51+ return $ case es of { [e] -> e; _ -> tuple es }
52+ ]
4353
44−term = select [ numTerm
45− , strTerm
54+term = choice [ numTerm, strTerm, chrTerm
4655 , accessible varTerm
47− , chrTerm
48− , trueTerm
49− , falseTerm
50− , listTerm
51− , accessible parensTerm
52− ]
56+ , listTerm, parensTerm ]
57+ <?> "basic term (number, variable, etc.)"
5358
5459-------- Applications --------
5560
5661appExpr = do
57− tlist <- plus term
62+ tlist <- spaceSep1 term
5863 return $ case tlist of
5964 t:[] -> t
6065 t:ts -> foldl' App t ts
6166
62−
63−-------- Expressions with infix operators --------
64−
65−binaryExpr = binops appExpr anyOp
66−
67−
6867-------- Normal Expressions --------
6968
70−ifExpr = do { t IF; e1 <- expr; t THEN; e2 <- expr; t ELSE; e3 <- expr
71− ; return $ If e1 e2 e3 }
72−
73−lambdaExpr = do { t LAMBDA; vs <- plus var; t ARROW; e <- expr
74− ; return $ foldr Lambda e vs }
69+binaryExpr = binops appExpr anyOp
7570
76−assignExpr = whitespace >> assignExprNospace
77−assignExprNospace = do
78− p:ps <- plus patternTerm; assign; e <- expr
79− case p:ps of
80− PVar x : _ -> return (x, foldr func e ps)
81− where func PAnything e' = Lambda "_" e'
82− func (PVar x) e' = Lambda x e'
83− func p' e' = Lambda "_temp" (Case (Var "_temp") [(p', e')])
84−-- _ : [] -> return $ \hole -> Case e [(p,hole)]
85− _ -> zero
71+ifExpr = do reserved "if" ; whitespace ; e1 <- expr ; whitespace
72+ reserved "then" ; whitespace ; e2 <- expr ; (whitespace <?> "an 'else' branch")
73+ reserved "else" <?> "an 'else' branch" ; whitespace ; If e1 e2 <$> expr
74+
75+lambdaExpr = do char '\\' <|> char '\x03BB' <?> "anonymous function"
76+ whitespace
77+ args <- spaceSep1 patternTerm
78+ whitespace ; arrow ; whitespace
79+ e <- expr
80+ return $ makeFunction args e
81+
82+assignExpr = do
83+ patterns <- spaceSep1 (patternTerm <?> "the definition of a variable (x = ...)")
84+ whitespace; string "="; whitespace; exp <- expr
85+ case patterns of
86+ PVar f : args -> return (f, makeFunction args exp)
87+ [PData x ps] -> if "Tuple" == take 5 x && all isDigit (drop 5 x) then
88+ fail "matching tuples is not yet supported in this context"
89+ else fail $ "Only tuples can be matched in this context, " ++
90+ "not other abstract data types such as lists."
91+ _ -> fail $ "Left-hand side of assign statement is not acceptable: " ++
92+ "only named variables, named functions, and tuples are okay."
8693
8794letExpr = do
88− t LET; brace <- optional $ t LBRACE
95+ reserved "let"
96+ brace <- optionMaybe . try $ do
97+ whitespace
98+ char '{' <?> "a set of definitions { x = ... ; y = ... }"
8999 case brace of
90− Nothing -> do f <- assignExpr; t IN; e <- expr; return (Let [f] e)
91− Just LBRACE -> do fs <- sepBy1 (t SEMI) assignExpr; t RBRACE; t IN;
92− e <- expr; return (Let fs e)
100+ Nothing -> do whitespace; f <- assignExpr; whitespace; reserved "in"; whitespace
101+ Let [f] <$> expr
102+ Just '{' -> do whitespace ; fs <- semiSep1 assignExpr ; whitespace
103+ string "}" <?> "closing bracket '}'"
104+ whitespace; reserved "in"; whitespace; e <- expr
105+ return (Let fs e)
93106
94107caseExpr = do
95− t CASE; e <- expr; t OF; t LBRACE
96− cases <- sepBy1 (t SEMI)
97− (do { p <- patternExpr; t ARROW; e <- expr; return (p,e) })
98− t RBRACE
99− return $ Case e cases
100−
101−-------- All Expressions --------
102−
103−expr = select [ letExpr
104− , binaryExpr
105− , ifExpr
106− , caseExpr
107− , lambdaExpr
108− ]
109−
110−def = do (f,e) <- assignExprNospace
108+ reserved "case"; whitespace; e <- expr; whitespace; reserved "of"; whitespace
109+ Case e <$> brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
110+ where case_ = do p <- patternExpr; whitespace; arrow; whitespace
111+ (,) p <$> expr
112+
113+
114+expr = choice [ ifExpr, letExpr, caseExpr, lambdaExpr, binaryExpr ] <?> "expression"
115+
116+def = do (f,e) <- assignExpr
111117 return ([f], [e], guid >>= \x -> return [VarT x])
112118
119+defs1 = do optional freshLine
120+ d <- datatype <|> def
121+ (d:) <$> many (try (try freshLine >> (datatype <|> def)))
122+
113123defs = do
114− (fss,ess,tss) <- unzip3 `liftM` plus (whitespace >> plus (sat (==NEWLINE)) >> def +|+ datatype)
124+ (fss,ess,tss) <- unzip3 <$> defs1
115125 let (fs,es,ts) = (concat fss, concat ess, concat `liftM` sequence tss)
116− star $ sat (==NEWLINE) +|+ sat (==SPACES)
126+ optional freshLine ; optional spaces ; eof
117127 return (Let (zip fs es) (Var "main"), liftM (zip fs) ts)
118128
119−err = "Parse Error: Better error messages to come!"
120−toExpr = extractResult err . parse expr
121−toDefs = extractResult err . parse defs . (NEWLINE:)
129+toDefs source = case parse defs "" source of
130+ Right result -> Right result
131+ Left err -> Left $ "Parse error at " ++ show err