Add kinds of fixes and stuff

8 files changed, 90 insertions, 34 deletions

diff --git a/app/Main.hs b/app/Main.hs
index 0fe5551..d31fef2 100644
--- a/app/Main.hs
+++ b/app/Main.hs
@@ -17,6 +17,8 @@ parseArgs config args =
             config { configShowHelp = True } rest
         ("-e":rest) -> parseArgs
             config { configPrintEvaled = True } rest
+        ("-s":rest) -> parseArgs
+            config { configPrintCallStack = True } rest
         _ -> config
 
 repl :: Config -> Env -> InputT IO ()
@@ -42,7 +44,8 @@ main = do
         configScriptFileName = Nothing,
         configVerboseMode = False,
         configShowHelp = False,
-        configPrintEvaled = False
+        configPrintEvaled = False,
+        configPrintCallStack = False
     }
 
     let config = parseArgs initialConfig args
@@ -52,6 +55,7 @@ main = do
         putStrLn $ "       " ++ progName ++ " -i scriptFile   # to run script file"
         putStrLn $ "       " ++ progName ++ " -h              # to show this help"
         putStrLn $ "       " ++ progName ++ " -e              # to automatically print results of evaluated expressions to stdout"
+        putStrLn $ "       " ++ progName ++ " -s              # to automatically print call stack of evaluated expressions to stdout"
     else do
         when (configVerboseMode config) $ do
             putStrLn $ "configScriptFileName:\t" ++ (show $ configScriptFileName config)
diff --git a/examples/maybe.lisp b/examples/maybe.lisp
index ce2cd03..c72e114 100644
--- a/examples/maybe.lisp
+++ b/examples/maybe.lisp
@@ -5,24 +5,45 @@
 (let nothing (\[]
     ["maybe" "nothing"]))
 
-(let at (\[n seq]
+(let unsafe-at (\[n seq]
     (match seq
-        [] (nothing)
+        []
+            (error "unsafe-at out of bounds")
         (match n
-            0 (head seq)
-            (at (- n 1) (tail seq))))))
+            0
+                (head seq)
+            (unsafe-at (- n 1) (tail seq))))))
 
-(let from-just (at 2))
-(let kind (at 1))
+(let unpack-just (unsafe-at 2))
+(let kind (unsafe-at 1))
 
 (let map (\[f m]
     (match (kind m)
-        "just" (just (f (from-just m)))
-        "nothing")))
+        "just" (just (f (unpack-just m)))
+        "nothing" (nothing))))
+
+(let and-then (\[f m]
+    (match (kind m)
+        "just" (f (unpack-just m))
+        "nothing" (nothing))))
 
 ; TESTING
 
+(let print-line! (\[s]
+    (print! (concat s "\n"))))
+
 (let m (just 10))
 (match (kind m)
-    "just" (from-just m)
-    "nothing" "nothing")
+    "just"
+        (print-line! (fmt "found just {0}!" [(unpack-just m)]))
+    "nothing"
+        (print-line! "found nothing!"))
+
+;; (export [
+;;     just
+;;     nothing
+;;     unpack-just
+;;     kind
+;;     map
+;;     and-then
+;; ])
\ No newline at end of file
diff --git a/lang.cabal b/lang.cabal
index bb88c6e..5954937 100644
--- a/lang.cabal
+++ b/lang.cabal
@@ -43,6 +43,7 @@ library
     , haskeline ==0.8.2
     , mtl
     , regex-tdfa ==1.3.2
+    , text
   default-language: Haskell2010
 
 executable lang-exe
@@ -60,6 +61,7 @@ executable lang-exe
     , lang
     , mtl
     , regex-tdfa ==1.3.2
+    , text
   default-language: Haskell2010
 
 test-suite lang-test
@@ -79,4 +81,5 @@ test-suite lang-test
     , lang
     , mtl
     , regex-tdfa ==1.3.2
+    , text
   default-language: Haskell2010
diff --git a/package.yaml b/package.yaml
index c17363e..1736775 100644
--- a/package.yaml
+++ b/package.yaml
@@ -23,6 +23,7 @@ dependencies:
 - base >= 4.7 && < 5
 - containers
 - mtl
+- text
 - haskeline == 0.8.2
 - regex-tdfa == 1.3.2
 - HUnit == 1.6.2.0
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
diff --git a/test/TestUtils.hs b/test/TestUtils.hs
index e51d97b..7247ef5 100644
--- a/test/TestUtils.hs
+++ b/test/TestUtils.hs
@@ -8,7 +8,8 @@ testConfig = Config {
     configScriptFileName = Nothing,
     configVerboseMode = False,
     configShowHelp = False,
-    configPrintEvaled = False
+    configPrintEvaled = False,
+    configPrintCallStack = False
 }
 
 testRunL :: LContext a -> IO (Either LException a)