From 3f7d328d356c75c0ae57c67eb64fb5337361cce7 Mon Sep 17 00:00:00 2001
From: Jan Tuomi <jans.tuomi@gmail.com>
Date: Sun, 11 Dec 2022 13:51:04 +0200
Subject: Only evaluate fn arg when immediately calling function with that arg

---
 src/Interpreter.hs | 54 +++++++++++++++++++-----------------------------------
 src/Utils.hs       |  6 ++++++
 2 files changed, 25 insertions(+), 35 deletions(-)

(limited to 'src')

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"
-- 
cgit v1.3