From 5995f723058c5152980fb74034ad8f4d8bbd7a99 Mon Sep 17 00:00:00 2001
From: Jan Tuomi <jan.tuomi@valuemotive.com>
Date: Sat, 24 Sep 2022 13:55:27 +0300
Subject: Add head, tail builtins

---
 src/Lib.hs | 27 +++++++++++++++++++++++----
 1 file changed, 23 insertions(+), 4 deletions(-)

(limited to 'src')

diff --git a/src/Lib.hs b/src/Lib.hs
index 16ce782..569d5f5 100644
--- a/src/Lib.hs
+++ b/src/Lib.hs
@@ -161,7 +161,9 @@ type Env = M.Map String AST
 builtinEnv :: Env
 builtinEnv = M.fromList [
     ("+", builtinAdd2),
-    ("-", builtinSubtract2)
+    ("-", builtinSubtract2),
+    ("head", builtinHead),
+    ("tail", builtinTail)
     ]
 
 builtinAdd2 :: AST
@@ -184,6 +186,22 @@ builtinSubtract2 =
             return $ ASTFunction $ inner
      in ASTFunction outer
 
+builtinHead :: AST
+builtinHead =
+    let outer ast = do
+            (ASTVector vec) <- assertVectorAST ast
+            when (length vec == 0) $ throwError $ LException $ "head of empty vector"
+            return $ head vec
+     in ASTFunction outer
+
+builtinTail :: AST
+builtinTail =
+    let outer ast = do
+            (ASTVector vec) <- assertVectorAST ast
+            when (length vec == 0) $ throwError $ LException $ "tail of empty vector"
+            return $ ASTVector $ tail vec
+     in ASTFunction outer
+
 traverseAndReplace :: String -> AST -> AST -> AST
 traverseAndReplace param arg ast@(ASTSymbol sym)
     | sym == param = arg
@@ -221,10 +239,11 @@ curriedMakeUserDefFn env ((ASTSymbol param):rest) body =
 curriedMakeUserDefFn _ _ _ = error $ "unreachable"
 
 evaluate :: Env -> AST -> LContext AST
-evaluate env (ASTFunctionCall children@(first:args))
+evaluate env (ASTFunctionCall (first:args))
     | first == ASTSymbol "\\" = do
-        when (length args /= 2) $ throwError $ LException $ "\\ called with " ++ show (length args) ++ " arguments"
-        let [arg1, arg2] = args
+        (arg1, arg2) <- case args of
+                [a, b] -> return (a, b)
+                _ -> throwError $ LException $ "\\ called with " ++ show (length args) ++ " arguments"
         (ASTVector params') <- assertVectorAST arg1
         params <- mapM assertSymbolAST params'
         when (length params == 0) $ throwError $ LException $ "Function must have > 0 parameters"
-- 
cgit v1.3