diff --git a/ast.hs b/ast.hs index 57d9381..53dfdee 100644 --- a/ast.hs +++ b/ast.hs @@ -4,6 +4,7 @@ data AST = Add AST AST | Mul AST AST | Block [AST] | FunDef String ([Pattern], AST) + | Defun String AST | Def String AST | Var String | Lambda [(Pattern, [AST])] diff --git a/interp.hs b/interp.hs index 1919daf..710da04 100644 --- a/interp.hs +++ b/interp.hs @@ -82,6 +82,18 @@ eval (Var var) = get >>= \(_,env) -> Just v -> return v Nothing -> error $ "unbound variable " ++ var +eval (Defun name fn) = do + (s,env) <- get + case lookup env name of + Nothing -> -- bind new fn + eval fn >>= \fn' -> + put (s, bind env name fn') >> return fn' + Just oldfn -> -- add pattern to old fn + let FnV oldpats = oldfn + Lambda [(pat, body)] = fn + newfn = FnV ((pat, body):oldpats) in + put (s, bind env name newfn) >> return newfn + eval (Def name v') = do v <- eval v' (s,env) <- get diff --git a/parser.hs b/parser.hs index 6c0c0ad..06bea11 100644 --- a/parser.hs +++ b/parser.hs @@ -71,8 +71,7 @@ consPattern = do y <- pattern return $ ConsP x y -pattern = option UnitP $ - try consPattern +pattern = try consPattern <|> listPattern <|> varPattern <|> intPattern @@ -87,11 +86,11 @@ funDef = do symbol ")" symbol "->" lst <- exprparser - return $ rewriteFun (FunDef name (pats, lst)) + return $ rewriteFun (FunDef name (pats', lst)) -- curry FunDef to a definition of lambdas rewriteFun (FunDef name (patterns, body)) = - Def name lam + Defun name lam where -- curry it lam = foldr (\pat lam -> Lambda [(pat, [lam])]) body patterns