From d9e1a7bdc1f8060903fed4a1ee6ac95578ed0d5d Mon Sep 17 00:00:00 2001 From: darkf Date: Tue, 22 Oct 2013 15:59:05 -0700 Subject: [PATCH] remove curried functions; multiple arguments use tuples --- ast.hs | 5 ++-- interp.hs | 71 ++++++++++++++++++++----------------------------------- parser.hs | 25 ++++++++++---------- 3 files changed, 42 insertions(+), 59 deletions(-) diff --git a/ast.hs b/ast.hs index f219df1..1f4bfac 100644 --- a/ast.hs +++ b/ast.hs @@ -9,12 +9,12 @@ data AST = Add AST AST | Mul AST AST | Div AST AST | Block [AST] - | FunDef String ([Pattern], AST) + | FunDef String (Pattern, AST) | Defun String AST | Def String AST | Var String | Lambda [(Pattern, AST)] - | Call String [AST] + | Call String AST | UnitConst | Cons AST AST | TupleConst [AST] @@ -27,5 +27,6 @@ data Pattern = VarP String | IntP Integer | UnitP | ConsP Pattern Pattern + | TupleP [Pattern] | ListP [Pattern] deriving (Show, Eq) \ No newline at end of file diff --git a/interp.hs b/interp.hs index d1ea083..1ae4f08 100644 --- a/interp.hs +++ b/interp.hs @@ -126,35 +126,14 @@ eval (Var var) = get >>= \(_,env) -> 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 oldpatterns = oldfn - newfn = merge fn (Lambda oldpatterns) in - put (s, bind env name newfn) >> return newfn - -- newfn = FnV (oldpats ++ [(pat, body)]) in - where - -- takes a lambda and a list of patterns and merges their - ------- patterns recursively, forming a new function - mergePatterns :: AST -> AST -> Value - mergePatterns (Lambda [newpat]) (Lambda oldpatterns@(oldpat:oldpats)) = - if fst newpat /= fst oldpat then - -- we've diverged, so let's add it here - FnV (oldpatterns ++ [newpat]) - else - -- we're still equal, keep going - mergePatterns (snd newpat) (snd oldpat) - mergePatterns _ (Lambda b) = FnV b - mergePatterns a@(Lambda _) _ = error "k" - - merge = mergePatterns - - {- - mergePatterns(a, b): - if any pats(b) == pat(a), - just \(pats(b) ++ (pat(a) -> bod(a))) - else, nothing -} + 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 (oldpats ++ [(pat, body)]) in + put (s, bind env name newfn) >> return newfn eval (Def name v') = do v <- eval v' @@ -170,15 +149,14 @@ eval (Sub l r) = do { l <- eval l; r <- eval r; return $ l -$ r } eval (Mul l r) = do { l <- eval l; r <- eval r; return $ l *$ r } eval (Div l r) = do { l <- eval l; r <- eval r; return $ l /$ r } -eval (Call name args) = get >>= \(_,env) -> +eval (Call name arg) = get >>= \(_,env) -> case lookup env name of - Just fn@(FnV _) -> - do - xargs <- mapM eval args - applyMany fn xargs - Just fn@(Builtin _) -> mapM eval args >>= applyMany fn + Just fn@(FnV _) -> eval arg >>= apply fn + Just fn@(Builtin _) -> eval arg >>= apply fn Nothing -> error $ "call: name " ++ name ++ " doesn't exist or is not a function" +eval x = error $ "eval: unhandled: " ++ show x + patternBindings :: Pattern -> Value -> Maybe Env patternBindings (VarP n) v = Just $ M.fromList [(n, v)] @@ -198,6 +176,7 @@ patternBindings (ConsP xp xsp) (ListV (x:xs)) = Just $ M.union xe xse patternBindings (ConsP _ _) _ = Nothing +-- lists patternBindings (ListP []) (ListV (x:xs)) = Nothing -- not enough patterns patternBindings (ListP (_:_)) (ListV []) = Nothing -- not enough values patternBindings (ListP []) (ListV []) = Just M.empty -- base case @@ -208,16 +187,16 @@ patternBindings (ListP (x:xs)) (ListV (y:ys)) = Just $ M.union env' env patternBindings (ListP _) _ = Nothing -- not a list --- applies many arguments to a function -applyMany :: Value -> [Value] -> InterpState Value -applyMany fn@(FnV _) (arg:xs) = - apply fn arg >>= \value -> - applyMany value xs -applyMany (Builtin (BIF fn)) (arg:xs) = - fn arg >>= \value -> - applyMany value xs -applyMany value [] = return value -applyMany _ xs = error "couldn't apply all arguments" +-- tuples +patternBindings (TupleP []) (TupleV (x:_)) = Nothing -- not enough patterns +patternBindings (TupleP (_:_)) (TupleV []) = Nothing -- not enough values +patternBindings (TupleP []) (TupleV []) = Just M.empty -- base case +patternBindings (TupleP (x:xs)) (TupleV (y:ys)) = + do + env <- patternBindings x y + env' <- patternBindings (TupleP xs) (TupleV ys) + Just $ M.union env' env +patternBindings (TupleP _) _ = Nothing -- not a tuple -- applies a function apply :: Value -> Value -> InterpState Value @@ -235,6 +214,8 @@ apply (FnV pats) arg = Nothing -> -- doesn't satisfy this pattern apply' xs +apply (Builtin (BIF fn)) arg = fn arg + evalProgram :: [AST] -> Value -- fold the state from each node and return the result evalProgram nodes = evalState (foldr1 (>>) $ map eval nodes) initialState diff --git a/parser.hs b/parser.hs index 86116f6..9866915 100644 --- a/parser.hs +++ b/parser.hs @@ -89,6 +89,8 @@ consPattern = do return $ ConsP x y pattern = try consPattern + <|> try (emptyTuple TupleP) + <|> try (tupleSeq pattern TupleP) <|> listPattern <|> varPattern <|> intPattern @@ -99,27 +101,26 @@ funDef = do name <- identifier symbol "(" pats <- patterns - let pats' = if pats == [] then [UnitP] else pats -- at least Unit + let pat = (case pats of + [] -> UnitP + [a] -> a + otherwise -> TupleP pats) symbol ")" symbol "->" - lst <- exprparser - return $ rewriteFun (FunDef name (pats', lst)) - --- curry FunDef to a definition of lambdas -rewriteFun (FunDef name (patterns, body)) = - Defun name lam - where - -- curry it - lam = foldr (\pat lam -> Lambda [(pat, lam)]) body patterns + body <- exprparser + return $ Defun name $ Lambda [(pat, body)] call = do name <- identifier whiteSpace symbol "(" args <- sepBy exprparser (symbol ",") - let args' = if args == [] then [UnitConst] else args -- at least Unit + let arg = (case args of + [] -> UnitConst + [a] -> a + otherwise -> TupleConst args) symbol ")" - return $ Call name args' + return $ Call name arg consExpr = do x <- expr'