Fix match

4 files changed, 70 insertions, 49 deletions

diff --git a/examples/test.lisp b/examples/test.lisp
index 3b9fa5e..9930181 100644
--- a/examples/test.lisp
+++ b/examples/test.lisp
@@ -1,15 +1,34 @@
 ;; (let map (\[f lst]
 ;;     (match lst
 ;;         [] []
-;;         (prepend (f head lst) (map f (tail lst))))))
+;;         (prepend (f (head lst)) (map f (tail lst))))))
 
 ;; (map (+ 1) [1 2 3])
 
-(let mapinc (\[vec]
-    (match vec
-        [] []
-        (prepend
-            (+ 1 (head vec))
-            (mapinc (tail vec))))))
-(env)
-(mapinc [1 2 3])
+;; (let mapinc (\[vec]
+;;     (match vec
+;;         [] []
+;;         (prepend
+;;             (+ 1 (head vec))
+;;             (mapinc (tail vec))))))
+;; (env)
+;; (mapinc [1 2 3])
+
+;; (let fibo (\[n]
+;;     ;; (let fibo-1 (\[] (fibo (sub2 n 1))))
+;;     ;; (let fibo-2 (\[] (fibo (sub2 n 2))))
+;;     (match n
+;;         0  0
+;;         1  1
+;;         (+
+;;             (fibo (- n 1))
+;;             (fibo (- n 2))))))
+
+;; (fibo 10)
+
+(let foldr (\[f accumulator lst]
+    (match lst
+        []  accumulator
+        (f (foldr f accumulator (tail lst)) (head lst)))))
+
+(foldr + 0 [1 2 3])
diff --git a/src/Builtins.hs b/src/Builtins.hs
index 1c1dd1b..ce47ac9 100644
--- a/src/Builtins.hs
+++ b/src/Builtins.hs
@@ -15,9 +15,9 @@ builtinEnv = M.fromList [
 
 builtinAdd2 :: AST
 builtinAdd2 =
-    let outer ast1 = do
+    let outer _ ast1 = do
             (ASTInteger a) <- assertIsASTInteger ast1
-            let inner ast2 = do
+            let inner _ ast2 = do
                     (ASTInteger b) <- assertIsASTInteger ast2
                     return $ ASTInteger $ a + b
             return $ ASTFunction $ inner
@@ -25,9 +25,9 @@ builtinAdd2 =
 
 builtinSubtract2 :: AST
 builtinSubtract2 =
-    let outer ast1 = do
+    let outer _ ast1 = do
             (ASTInteger a) <- assertIsASTInteger ast1
-            let inner ast2 = do
+            let inner _ ast2 = do
                     (ASTInteger b) <- assertIsASTInteger ast2
                     return $ ASTInteger $ a - b
             return $ ASTFunction $ inner
@@ -35,7 +35,7 @@ builtinSubtract2 =
 
 builtinHead :: AST
 builtinHead =
-    let outer ast = do
+    let outer _ ast = do
             (ASTVector vec) <- assertIsASTVector ast
             when (length vec == 0) $ throwError $ LException $ "head of empty vector"
             return $ head vec
@@ -43,7 +43,7 @@ builtinHead =
 
 builtinTail :: AST
 builtinTail =
-    let outer ast = do
+    let outer _ ast = do
             (ASTVector vec) <- assertIsASTVector ast
             when (length vec == 0) $ throwError $ LException $ "tail of empty vector"
             return $ ASTVector $ tail vec
@@ -51,8 +51,8 @@ builtinTail =
 
 builtinPrepend :: AST
 builtinPrepend =
-    let outer ast1 = do
-            let inner ast2 = do
+    let outer _ ast1 = do
+            let inner _ ast2 = do
                     (ASTVector vec) <- assertIsASTVector ast2
                     return $ ASTVector $ ast1 : vec
             return $ ASTFunction $ inner
diff --git a/src/Lib.hs b/src/Lib.hs
index 0f81331..b48a95c 100644
--- a/src/Lib.hs
+++ b/src/Lib.hs
@@ -125,18 +125,18 @@ _parse acc (token:rest) =
 parse :: [String] -> LContext [AST]
 parse = _parse []
 
-_curryCall :: [AST] -> (AST -> LContext AST) -> LContext AST
-_curryCall [] f = return $ ASTFunction f
-_curryCall (arg:[]) f = f arg
-_curryCall (arg:rest) f = do
-    g <- _curryCall rest f
+_curryCall :: Env -> [AST] -> LFunction -> LContext AST
+_curryCall env [] f = return $ ASTFunction f
+_curryCall env (arg:[]) f = f env arg
+_curryCall env (arg:rest) f = do
+    g <- _curryCall env rest f
     case g of
-        ASTFunction f' -> f' arg
+        ASTFunction f' -> f' env arg
         other -> throwError $ LException $ "cannot call value " ++ show other ++ " as a function"
 
-curryCall :: [AST] -> (AST -> LContext AST) -> LContext AST
-curryCall [] f = f ASTUnit
-curryCall args f = _curryCall args f
+curryCall :: Env -> [AST] -> LFunction -> LContext AST
+curryCall env [] f = f env ASTUnit
+curryCall env args f = _curryCall env args f
 
 traverseAndReplace :: String -> AST -> AST -> AST
 traverseAndReplace param arg ast@(ASTSymbol sym)
@@ -153,27 +153,27 @@ traverseAndReplace param arg (ASTHashMap hmap) =
         .> asPairs .> M.fromList
 traverseAndReplace _ _ other = other
 
-makeUserDefFn :: Env -> AST -> AST -> AST -> LContext AST
-makeUserDefFn env (ASTSymbol param) body =
-    let fn :: AST -> LContext AST
-        fn arg = do
+makeUserDefFn :: AST -> AST -> LFunction
+makeUserDefFn (ASTSymbol param) body =
+    let fn :: LFunction
+        fn env arg = do
             let newBody = traverseAndReplace param arg body
             (_, ret) <- evaluate env newBody
             return ret
      in fn
-makeUserDefFn _ _ _ = error $ "unreachable: makeUserDefFn"
+makeUserDefFn _ _ = error $ "unreachable: makeUserDefFn"
 
-curriedMakeUserDefFn :: Env -> [AST] -> AST -> AST -> LContext AST
-curriedMakeUserDefFn env [] body = makeUserDefFn env (ASTSymbol "_") body
-curriedMakeUserDefFn env (param:[]) body = makeUserDefFn env param body
-curriedMakeUserDefFn env ((ASTSymbol param):rest) body =
-    let fn :: AST -> LContext AST
-        fn arg = do
+curriedMakeUserDefFn :: [AST] -> AST -> LFunction
+curriedMakeUserDefFn [] body = makeUserDefFn (ASTSymbol "_") body
+curriedMakeUserDefFn (param:[]) body = makeUserDefFn param body
+curriedMakeUserDefFn ((ASTSymbol param):rest) body =
+    let fn :: LFunction
+        fn _ arg = do
             let newBody = traverseAndReplace param arg body
-            let ret = curriedMakeUserDefFn env rest newBody
+            let ret = curriedMakeUserDefFn rest newBody
             return $ ASTFunction $ ret
      in fn
-curriedMakeUserDefFn _ _ _ = error $ "unreachable: curriedMakeUserDefFn"
+curriedMakeUserDefFn _ _ = error $ "unreachable: curriedMakeUserDefFn"
 
 evaluate :: Env -> AST -> LContext (Env, AST)
 evaluate env (ASTFunctionCall (first:args))
@@ -183,9 +183,7 @@ evaluate env (ASTFunctionCall (first:args))
                 _ -> throwError $ LException $ "\\ called with " ++ show (length args) ++ " arguments"
         (ASTVector params') <- assertIsASTVector arg1
         params <- mapM assertIsASTSymbol params'
-        -- when (length params == 0) $ throwError $ LException $ "Function must have > 0 parameters"
-        body <- assertIsASTFunctionCall arg2
-        let fn = curriedMakeUserDefFn env params body
+        let fn = curriedMakeUserDefFn params arg2
         return $ (env, ASTFunction fn)
     | first == ASTSymbol "match" = do
         (cond, rest) <- case args of
@@ -194,19 +192,21 @@ evaluate env (ASTFunctionCall (first:args))
                 (cond':rest') -> return (cond', rest')
         if length rest `mod` 2 == 0
             then do
-                caseMatchers <- oddElems rest $> mapM (evaluate env)
+                caseMatchers' <- oddElems rest $> mapM (evaluate env)
+                let caseMatchers = map (\(_, a) -> a) caseMatchers'
                 let caseBranches = evenElems rest
                 let caseMap = M.fromList $ L.zip caseMatchers caseBranches
-                evaledCond <- evaluate env cond
+                (_, evaledCond) <- evaluate env cond
                 case M.lookup evaledCond caseMap of
                     Just branch -> evaluate env branch
                     Nothing -> throwError $ LException $ "matching case not found, condition " ++ show cond
             else do
                 let (defaultBranch:revCases) = reverse rest
-                caseMatchers <- oddElems (reverse revCases) $> mapM (evaluate env)
+                caseMatchers' <- oddElems (reverse revCases) $> mapM (evaluate env)
+                let caseMatchers = map (\(_, a) -> a) caseMatchers'
                 let caseBranches = evenElems (reverse revCases)
                 let caseMap = M.fromList $ L.zip caseMatchers caseBranches
-                evaledCond <- evaluate env cond
+                (_, evaledCond) <- evaluate env cond
                 case M.lookup evaledCond caseMap of
                     Just branch -> evaluate env branch
                     Nothing -> evaluate env defaultBranch
@@ -229,13 +229,13 @@ evaluate env (ASTFunctionCall (first:args))
         (ASTFunction fn) <- assertIsASTFunction fnEvaled
         evaledArgs' <- mapM (evaluate env) args
         let evaledArgs = map (\(_, a) -> a) evaledArgs'
-        result <- curryCall (reverse evaledArgs) fn
+        result <- curryCall env (reverse evaledArgs) fn
         return (env, result)
 evaluate env (ASTSymbol sym) = do
     let val = M.lookup sym env
     case val of
         Just ast -> return (env, ast)
-        Nothing -> throwError $ LException $ "Symbol " ++ sym ++ " not defined in environment"
+        Nothing -> throwError $ LException $ "symbol " ++ sym ++ " not defined in environment"
 evaluate env ast = return (env, ast)
 
 runScriptFile :: Env -> String -> LContext Env
diff --git a/src/Types.hs b/src/Types.hs
index 515910b..08736cc 100644
--- a/src/Types.hs
+++ b/src/Types.hs
@@ -18,6 +18,8 @@ type LContext a = ReaderT Config (ExceptT LException IO) a
 
 type Env = M.Map String AST
 
+type LFunction = (Env -> AST -> LContext AST)
+
 data AST
     = ASTInteger Int
     | ASTDouble Double
@@ -27,7 +29,7 @@ data AST
     | ASTVector [AST]
     | ASTFunctionCall [AST]
     | ASTHashMap (M.Map AST AST)
-    | ASTFunction (AST -> LContext AST)
+    | ASTFunction LFunction
     | ASTUnit
 
 instance (Show AST) where