From 95fa4b4de7027749a6512def696d07ed64217b50 Mon Sep 17 00:00:00 2001
From: Jan Tuomi <jan.tuomi@valuemotive.com>
Date: Sat, 24 Sep 2022 14:36:37 +0300
Subject: Implement match

---
 src/Lib.hs   | 27 ++++++++++++++++++++++++---
 src/Utils.hs |  8 ++++++++
 2 files changed, 32 insertions(+), 3 deletions(-)

(limited to 'src')

diff --git a/src/Lib.hs b/src/Lib.hs
index 569d5f5..e5ea214 100644
--- a/src/Lib.hs
+++ b/src/Lib.hs
@@ -242,7 +242,7 @@ evaluate :: Env -> AST -> LContext AST
 evaluate env (ASTFunctionCall (first:args))
     | first == ASTSymbol "\\" = do
         (arg1, arg2) <- case args of
-                [a, b] -> return (a, b)
+                [arg1', arg2'] -> return (arg1', arg2')
                 _ -> throwError $ LException $ "\\ called with " ++ show (length args) ++ " arguments"
         (ASTVector params') <- assertVectorAST arg1
         params <- mapM assertSymbolAST params'
@@ -250,8 +250,29 @@ evaluate env (ASTFunctionCall (first:args))
         body <- assertFunctionCallAST arg2
         let fn = curriedMakeUserDefFn env params body
         return $ ASTFunction fn
-    | first == ASTSymbol "match" =
-        throwError $ LException "match not implemented"
+    | first == ASTSymbol "match" = do
+        (cond, rest) <- case args of
+                [] -> throwError $ LException $ "match called with no arguments"
+                (_:[]) -> throwError $ LException $ "Empty match cases"
+                (cond':rest') -> return (cond', rest')
+        if length rest `mod` 2 == 0
+            then do
+                caseMatchers <- oddElems rest $> mapM (evaluate env)
+                let caseBranches = evenElems rest
+                let caseMap = M.fromList $ L.zip caseMatchers caseBranches
+                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)
+                let caseBranches = evenElems (reverse revCases)
+                let caseMap = M.fromList $ L.zip caseMatchers caseBranches
+                evaledCond <- evaluate env cond
+                case M.lookup evaledCond caseMap of
+                    Just branch -> evaluate env branch
+                    Nothing -> evaluate env defaultBranch
     | otherwise = do
         fnEvaled <- evaluate env first
         (ASTFunction fn) <- assertFunctionAST fnEvaled
diff --git a/src/Utils.hs b/src/Utils.hs
index 227e120..d2068d4 100644
--- a/src/Utils.hs
+++ b/src/Utils.hs
@@ -6,3 +6,11 @@ module Utils where
 ($>) = flip ($)
 
 infixr 6 $>
+
+oddElems :: [a] -> [a]
+oddElems [] = []
+oddElems (x:xs) = x:evenElems xs
+
+evenElems :: [a] -> [a]
+evenElems [] = []
+evenElems (_:xs) = oddElems xs
-- 
cgit v1.3