@@ -1,115 +1,114 @@
11module Parser 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 Guid
9−import Lexer
10−import ParserLib
11−import ParseTypes (datatype)
12−import ParsePatterns
13−import Tokens
14−import Types (Type (VarT))
8+import Text.Parsec
9+
10+import ParseLib
11+import Patterns
12+import Binop
1513
1614-------- Basic Terms --------
1715
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 } }
16+numTerm :: (Monad m) => ParsecT [Char] u m Expr
17+numTerm = liftM (Number . read) (many1 digit) <?> "number"
18+
19+strTerm :: (Monad m) => ParsecT [Char] u m Expr
20+strTerm = expecting "string" . liftM Str . betwixt '"' '"' . many $ noneOf "\""
2321
24−varTerm = Var `liftM` var
25−chrTerm = Chr `liftM` chr
22+varTerm :: (Monad m) => ParsecT [Char] u m Expr
23+varTerm = toVar <$> var <?> "variable"
2624
27−trueTerm = do { t TRUE; return $ Boolean True }
28−falseTerm = do { t FALSE; return $ Boolean False }
25+toVar v = case v of "True" -> Boolean True
26+ "False" -> Boolean False
27+ _ -> Var v
28+
29+chrTerm :: (Monad m) => ParsecT [Char] u m Expr
30+chrTerm = Chr <$> betwixt '\'' '\'' anyChar <?> "character"
2931
3032
3133-------- Complex Terms --------
3234
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 })
37−
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 } })
43−
44−term = select [ numTerm
45− , strTerm
46− , accessible varTerm
47− , chrTerm
48− , trueTerm
49− , falseTerm
50− , listTerm
51− , accessible parensTerm
52− ]
35+listTerm = expecting "list" . betwixtSpcs '[' ']' $ choice
36+ [ try $ do { lo <- expr; string ".." ; Range lo <$> expr }
37+ , list <$> expr `sepBy` lexeme (char ',')
38+ ]
39+
40+parensTerm = expecting "parenthesized expression" . betwixtSpcs '(' ')' $ choice
41+ [ do op <- anyOp
42+ return . Lambda "x" . Lambda "y" $ Binop op (Var "x") (Var "y")
43+ , do es <- expr `sepBy` lexeme (char ',')
44+ return $ case es of { [e] -> e; _ -> tuple es }
45+ ]
46+
47+term = lexeme (choice [ numTerm, strTerm, chrTerm
48+ , accessible varTerm
49+ , listTerm, parensTerm ])
50+ <?> "basic term (number, variable, etc.)"
5351
5452-------- Applications --------
5553
5654appExpr = do
57− tlist <- plus term
55+ tlist <- many1 (try term)
5856 return $ case tlist of
5957 t:[] -> t
6058 t:ts -> foldl' App t ts
6159
62−
63−-------- Expressions with infix operators --------
60+-------- Normal Expressions --------
6461
6562binaryExpr = binops appExpr anyOp
6663
64+ifExpr = expecting "if expression" $
65+ do symbol "if" ; e1 <- expr
66+ symbol "then" ; e2 <- expr
67+ expecting "else branch" $ do
68+ symbol "else" ; If e1 e2 <$> expr
69+
70+lambdaExpr = do lexeme $ oneOf "\\\x03BB"
71+ args <- patternTerm `endBy1` whitespace
72+ arrow
73+ e <- expr
74+ return $ makeFunction args e
75+
76+assignExpr = do
77+ patterns <- patternTerm `endBy1` whitespace; symbol "="; exp <- expr
78+ case patterns of
79+ PVar f : args -> return (f, makeFunction args exp)
80+ [PData x ps] -> if "Tuple" == take 5 x && all isDigit (drop 5 x) then
81+ fail "matching tuples is not yet supported in this context"
82+ else fail $ "Only tuples can be matched in this context, " ++
83+ "not other abstract data types such as lists."
84+ _ -> fail $ "Variables in assign statement are not acceptable: " ++
85+ "only named variables, named functions, and tuples are okay."
6786
68−-------- Normal Expressions --------
87+letExpr = do
88+ symbol "let"; brace <- optionMaybe . lexeme $ char '{'
89+ case brace of
90+ Nothing -> do f <- assignExpr; symbol "in"; e <- expr; return (Let [f] e)
91+ Just '{' -> do fs <- assignExpr `sepBy1` symbol ";"
92+ symbol "}" ; symbol "in"; e <- expr
93+ return (Let fs e)
6994
70−ifExpr = do { t IF; e1 <- expr; t THEN; e2 <- expr; t ELSE; e3 <- expr
71− ; return $ If e1 e2 e3 }
95+caseExpr = do
96+ symbol "case"; e <- expr; symbol "of"
97+ betwixtSpcs '{' '}' $ Case e <$> case_ `sepBy1` symbol ";"
98+ where case_ = do p <- patternExpr; whitespace; arrow; e <- expr; return (p,e)
7299
73−lambdaExpr = do { t LAMBDA; vs <- plus var; t ARROW; e <- expr
74− ; return $ foldr Lambda e vs }
75100
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
101+expr = choice [ ifExpr, letExpr, caseExpr, lambdaExpr, binaryExpr ]
86102
87−letExpr = do
88− t LET; brace <- optional $ t LBRACE
89− 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)
103+aoeu = parse (between whitespace eof expr) ""
93104
94−caseExpr = 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
105+symbol = lexeme . try . string
106+arrow = symbol "->" <|> symbol "\8594"
107+
108+def = do (f,e) <- assignExpr
111109 return ([f], [e], guid >>= \x -> return [VarT x])
112110
111+{--
113112defs = do
114113 (fss,ess,tss) <- unzip3 `liftM` plus (whitespace >> plus (sat (==NEWLINE)) >> def +|+ datatype)
115114 let (fs,es,ts) = (concat fss, concat ess, concat `liftM` sequence tss)
@@ -117,5 +116,5 @@ defs = do
117116 return (Let (zip fs es) (Var "main"), liftM (zip fs) ts)
118117
119118err = "Parse Error: Better error messages to come!"
120−toExpr = extractResult err . parse expr
121−toDefs = extractResult err . parse defs . (NEWLINE:)
119+toDefs = parse defs . ('\n':)
120+--}