diff options
| -rw-r--r-- | TODO.txt | 1 | ||||
| -rw-r--r-- | src/Interpreter.hs | 54 | ||||
| -rw-r--r-- | src/Utils.hs | 6 |
3 files changed, 25 insertions, 36 deletions
@@ -1,3 +1,2 @@ add a `Debug/break` builtin that allows simple interactive debugging -instead of evaling all args first and then curry calling fn, eval only one at a time write tests diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 9362d91..f8c45b0 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -19,19 +19,6 @@ import Builtins import Tokenizer ( tokenize' ) import Parser ( parse ) -curryCall :: [AST] -> ASTNode -> LContext AST -curryCall [] fnAstNode = return $ makeNonsenseAST fnAstNode -curryCall (arg:[]) (ASTFunction fPurity f) = do - checkPurity fPurity - f arg -curryCall (arg:rest) f = do - g <- curryCall rest f - case an g of - ASTFunction fPurity f' -> do - checkPurity fPurity - f' arg - other -> throwL (astPos g, "cannot call value " ++ show other ++ " as a function") - traverseAndReplace :: String -> AST -> AST -> AST traverseAndReplace param arg ast@AST { an = ASTSymbol sym } | sym == param = arg @@ -357,6 +344,13 @@ unsafeGetMemoMap sym = do Memoized memoMap _ -> return memoMap _ -> error $ "unreachable: unsafeGetMemoMap " ++ show env ++ ", " ++ sym +callFunction :: AST -> AST -> LContext AST +callFunction AST { an = ASTFunction fPurity f } argAst = do + checkPurity fPurity + evaledArg <- evaluate argAst + f evaledArg +callFunction other _ = throwL (astPos other, "cannot call non-function value: " ++ show other) + evaluateFunctionCall :: [AST] -> LContext AST evaluateFunctionCall children = do let fnAst = head children @@ -367,12 +361,9 @@ evaluateFunctionCall children = do case reifyRes of ReifyRegularFunction bound -> do evaledBound <- evaluate bound - AST { an = astFn@(ASTFunction fPurity _) } <- assertIsASTFunction evaledBound - - checkPurity fPurity + let fnCallComponents = evaledBound : args - evaledArgs <- mapM evaluate args - result <- curryCall (reverse evaledArgs) astFn + result <- fold1M callFunction fnCallComponents return $ fnAst { an = an result } ReifyMemoizedFunction sym bound -> do evaledArgs <- mapM evaluate args @@ -383,11 +374,9 @@ evaluateFunctionCall children = do Just hit -> return hit Nothing -> do evaledBound <- evaluate bound - AST { an = astFn@(ASTFunction fPurity _) } <- assertIsASTFunction evaledBound + let fnCallComponents = evaledBound : args - checkPurity fPurity - - result <- curryCall (reverse evaledArgs) astFn + result <- fold1M callFunction fnCallComponents possiblyUpdatedMemoMap <- unsafeGetMemoMap sym let newMemoMap = M.insert evaledArgs result possiblyUpdatedMemoMap @@ -398,17 +387,6 @@ evaluateFunctionCall children = do resolveSymbol :: String -> Env -> Maybe (Binding AST) resolveSymbol = M.lookup -evaluateSymbol :: AST -> LContext AST -evaluateSymbol ast@AST { an = ASTSymbol sym } = do - env <- getEnv - let bindingM = resolveSymbol sym env - case bindingM of - Just binding -> return $ case binding of - Regular v -> v - Memoized _ v -> v - Nothing -> throwL (astPos ast, "symbol " ++ sym ++ " not defined in environment") -evaluateSymbol ast = throwL (astPos ast, "unreachable: evaluateSymbol, ast: " ++ show ast) - evaluateDo :: [AST] -> LContext AST evaluateDo children = do let fnAst = head children @@ -481,8 +459,14 @@ evaluate ast@AST { an = fnc@(ASTFunctionCall args@(x:_)) } = updatePurity currentPurity return ret -evaluate ast@AST { an = (ASTSymbol _) } = - evaluateSymbol ast +evaluate ast@AST { an = ASTSymbol sym } = do + env <- getEnv + let bindingM = resolveSymbol sym env + case bindingM of + Just binding -> return $ case binding of + Regular v -> v + Memoized _ v -> v + Nothing -> throwL (astPos ast, "symbol " ++ sym ++ " not defined in environment") evaluate other = return other diff --git a/src/Utils.hs b/src/Utils.hs index 01ecb17..1eabd72 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -376,3 +376,9 @@ foldStackMessage (LException st) = case st of where fmtPos p = if useless p then "" else (" at " ++ p) useless p = "nonsense" `L.isPrefixOf` p || length p == 0 + +fold1M :: (Monad m) => (a -> a -> m a) -> [a] -> m a +fold1M _ (x:[]) = return x +fold1M f (x:y:xs) = do ret <- f x y + fold1M f (ret : xs) +fold1M _ [] = error $ "fold1M of empty list" |