From 18c241ff7a53625c6f3c4e6f20ee8df5bb37ddf3 Mon Sep 17 00:00:00 2001
From: Jan Tuomi <jans.tuomi@gmail.com>
Date: Mon, 26 Sep 2022 23:28:51 +0300
Subject: Add kinds of fixes and stuff

---
 src/Builtins.hs  | 16 ++++++++++++++++
 src/Evaluator.hs | 51 ++++++++++++++++++++++++++++++---------------------
 src/Utils.hs     |  3 ++-
 3 files changed, 48 insertions(+), 22 deletions(-)

(limited to 'src')

diff --git a/src/Builtins.hs b/src/Builtins.hs
index f0b9be2..8dc96b2 100644
--- a/src/Builtins.hs
+++ b/src/Builtins.hs
@@ -2,6 +2,7 @@
 module Builtins where
 
 import qualified Data.Map as M
+import qualified Data.Text as T
 import Control.Monad.Except
 import Utils
 
@@ -16,6 +17,7 @@ builtinEnv = M.fromList [
     builtinPrepend,
     builtinPrint,
     builtinConcat,
+    builtinFmt,
     ("unit", ASTUnit)
     ]
 
@@ -131,3 +133,17 @@ builtinConcat = (name, ASTFunction outer) where
                 return $ ASTString $ str1 ++ str2
             inner _ ast2 = throwL $ argError2 name ast1 ast2
     outer _ ast1 = throwL $ argError1 name ast1
+
+builtinFmt :: (String, AST)
+builtinFmt = (name, ASTFunction outer) where
+    name = "fmt"
+    outer _ ast1@(ASTString str) =
+        return $ ASTFunction $ inner where
+            inner _ (ASTVector replacements) =
+                return $ ASTString $ T.unpack $ replaceAll (0 :: Int) replacements (T.pack str)
+            inner _ ast2 = throwL $ argError2 name ast1 ast2
+    outer _ ast1 = throwL $ argError1 name ast1
+    replaceAll _ [] text = text
+    replaceAll n (x:xs) text =
+        let text' = T.replace (T.pack $ "{" ++ show n ++ "}") (T.pack $ show x) text
+         in replaceAll (n + 1) xs text'
diff --git a/src/Evaluator.hs b/src/Evaluator.hs
index eef21f8..32f287a 100644
--- a/src/Evaluator.hs
+++ b/src/Evaluator.hs
@@ -6,7 +6,7 @@ module Evaluator (
 import qualified Data.Map as M
 import qualified Data.List as L
 import Data.Function ( on )
-import Control.Monad.Except
+import Control.Monad.Reader
 import Utils
 
 _curryCall :: Env -> [AST] -> LFunction -> LContext AST
@@ -105,7 +105,7 @@ evaluateFunctionDef env args = do
 
 evaluateMatch :: Env -> [AST] -> LContext (Env, AST)
 evaluateMatch env args = do
-    (cond, rest) <- case args of
+    (actual, rest) <- case args of
             [] -> throwL $ "match called with no arguments"
             (_:[]) -> throwL $ "empty match cases"
             (a:b) -> return (a, b)
@@ -115,10 +115,11 @@ evaluateMatch env args = do
             let caseMatchers = map snd caseMatchers'
             let caseBranches = evenElems rest
             let caseMap = M.fromList $ L.zip caseMatchers caseBranches
-            (_, evaledCond) <- evaluate env cond
-            case M.lookup evaledCond caseMap of
+            (_, evaledActual) <- evaluate env actual
+            case M.lookup evaledActual caseMap of
                 Just branch -> evaluate env branch
-                Nothing -> throwL $ "matching case not found when matching on value: " ++ show cond
+                Nothing -> throwL $ "matching case not found when matching on expression: " ++ show actual
+                           ++ " (actual value: " ++ show evaledActual ++ ")"
         else do
             let (defaultBranch, revCases) = case reverse rest of
                     (a:b) -> (a, b)
@@ -127,8 +128,8 @@ evaluateMatch env args = do
             let caseMatchers = map snd caseMatchers'
             let caseBranches = evenElems (reverse revCases)
             let caseMap = M.fromList $ L.zip caseMatchers caseBranches
-            (_, evaledCond) <- evaluate env cond
-            case M.lookup evaledCond caseMap of
+            (_, evaledActual) <- evaluate env actual
+            case M.lookup evaledActual caseMap of
                 Just branch -> evaluate env branch
                 Nothing -> evaluate env defaultBranch
 
@@ -149,9 +150,10 @@ evaluateEnv env = do
     return (env, ASTUnit)
 
 evaluateUserFunction :: Env -> [AST] -> LContext (Env, AST)
-evaluateUserFunction env args = do
-    let first = head args
-    (_, fnEvaled) <- evaluate env first
+evaluateUserFunction env children = do
+    let fnName = head children
+    let args = tail children
+    (_, fnEvaled) <- evaluate env fnName
     (ASTFunction fn) <- assertIsASTFunction fnEvaled
     evaledArgs' <- mapM (evaluate env) args
     let evaledArgs = map snd evaledArgs'
@@ -168,18 +170,25 @@ evaluateSymbol env sym = do
         Nothing -> throwL $ "symbol " ++ sym ++ " not defined in environment"
 
 evaluate :: Env -> AST -> LContext (Env, AST)
-evaluate env (ASTFunctionCall (first:args)) = case first of
-    ASTSymbol "\\" ->
-        evaluateFunctionDef env args
-    ASTSymbol "match" ->
-        evaluateMatch env args
-    ASTSymbol "let" ->
-        evaluateLet env args
-    ASTSymbol "env" ->
-        evaluateEnv env
-    _ ->
-        evaluateUserFunction env args
+evaluate env fnc@(ASTFunctionCall (first:args)) =
+     do config <- ask
+        when (configPrintCallStack config) $ liftIO $ putStrLn $ "fn call: " ++ show fnc
+        case first of
+            ASTSymbol "\\" ->
+                evaluateFunctionDef env args
+            ASTSymbol "match" ->
+                evaluateMatch env args
+            ASTSymbol "let" ->
+                evaluateLet env args
+            ASTSymbol "env" ->
+                evaluateEnv env
+            _ ->
+                evaluateUserFunction env (first:args)
 evaluate env (ASTSymbol sym) =
     evaluateSymbol env sym
+evaluate env (ASTVector vec) =
+     do rets <- mapM (evaluate env) vec
+        let vec' = map snd rets
+        return $ (env, ASTVector vec')
 evaluate env other =
     return (env, other)
diff --git a/src/Utils.hs b/src/Utils.hs
index e0695c3..56fd1a2 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -14,7 +14,8 @@ data Config = Config {
     configScriptFileName :: Maybe String,
     configVerboseMode :: Bool,
     configShowHelp :: Bool,
-    configPrintEvaled :: Bool
+    configPrintEvaled :: Bool,
+    configPrintCallStack :: Bool
 }
 
 type LContext a = ReaderT Config (ExceptT LException IO) a
-- 
cgit v1.3