🔑 key-value pairs

a2/a2-handout/src/APL/AST.hs

@@ -22,4 +22,6 @@ data Exp
   | Apply Exp Exp
   | TryCatch Exp Exp
   | Print String Exp
+  | KvPut Exp Exp
+  | KvGet Exp
   deriving (Eq, Show)

a2/a2-handout/src/APL/Eval.hs

@@ -17,13 +17,13 @@ data Val
 
 type Env = [(VName, Val)]
 
-type State = [String]
+type State = ([(Val,Val)],[String])
 
 envEmpty :: Env
 envEmpty = []
 
 stateEmpty :: State
-stateEmpty = []
+stateEmpty = ([],[])
 
 envExtend :: VName -> Val -> Env -> Env
 envExtend v val env = (v, val) : env
@@ -65,11 +65,13 @@ catch (EvalM m1) (EvalM m2) = EvalM $ \env state ->
     (state', Left _) -> m2 env state'
     (state', Right x) -> (state', Right x)
 
-runEval :: EvalM a -> (State, Either Error a)
-runEval (EvalM m) = m envEmpty stateEmpty
+runEval :: EvalM a -> ([String], Either Error a)
+runEval (EvalM m) = do
+  case m envEmpty stateEmpty of
+    ((_,s),v) -> (s,v)
 
 evalPrint :: String -> EvalM ()
-evalPrint a = EvalM $ \_env state -> (state ++ [a], Right ())
+evalPrint a = EvalM $ \_env (k,s) -> ((k,s++[a]), Right ())
 
 evalIntBinOp :: (Integer -> Integer -> EvalM Integer) -> Exp -> Exp -> EvalM Val
 evalIntBinOp f e1 e2 = do
@@ -85,6 +87,15 @@ evalIntBinOp' f e1 e2 =
   where
     f' x y = pure $ f x y
 
+evalKvGet :: Val -> EvalM Val
+evalKvGet a = EvalM $ \_env (k,s) -> do
+  case lookup a k of
+    (Just v) -> ((k,s), Right v)
+    (Nothing) -> ((k,s), Left ("Invalid key: "++(show a)))
+
+evalKvPut :: Val -> Val -> EvalM ()
+evalKvPut a b = EvalM $ \_env (k,s) -> (((a,b):k,s), Right ())
+
 eval :: Exp -> EvalM Val
 eval (CstInt x) = pure $ ValInt x
 eval (CstBool b) = pure $ ValBool b
@@ -147,3 +158,11 @@ eval (Print s e1) = do
     (ValFun _ _ _) -> do
       evalPrint (s++": #<fun>")
       pure $ v1
+eval (KvPut e1 e2) = do
+  v1 <- eval e1
+  v2 <- eval e2
+  evalKvPut v1 v2
+  pure $ v2
+eval (KvGet e) = do
+  v <- eval e
+  evalKvGet v

a2/a2-handout/src/APL/Eval_Tests.hs

@@ -92,7 +92,17 @@ evalTests =
       testCase "PrintFun" $
         eval'
           (Print "Test" (Lambda "x" (Mul (Var "x") (Var "x"))))
-          @?= (["Test: #<fun>"], Right (ValFun [] "x" (Mul (Var "x") (Var "x"))))
+          @?= (["Test: #<fun>"], Right (ValFun [] "x" (Mul (Var "x") (Var "x")))),
+      --
+      testCase "KvPut" $
+        eval'
+          (KvPut (CstInt 1) (CstInt 2))
+          @?= ([], Right (ValInt 2)),
+      --
+      testCase "KvGet" $
+        eval'
+          (Let "x" (KvPut (CstInt 0) (CstBool True)) (Let "y" (KvPut (CstInt 0) (CstBool False)) (KvGet (CstInt 0))))
+          @?= ([], Right (ValBool False))
     ]
 
 tests :: TestTree