:clown: KV-store

a4/src/APL/InterpPure.hs

@@ -15,6 +15,12 @@ runEval = runEval' envEmpty stateInitial
        in (p : ps, res)
     runEval' r s (Free (TryCatchOp m l)) =
       case (runEval' r s m) of
-        (_, Left e) -> runEval' r s l
+        (_, Left _) -> runEval' r s l
         a -> a
+    runEval' r s (Free (KvGetOp key k)) =
+      case (lookup key s) of
+        Just val -> runEval' r s $ k val
+        Nothing -> ([], Left "Cannot find key :)")
+    runEval' r s (Free (KvPutOp key val m)) =
+      runEval' r ((key,val):s) m
     runEval' _ _ (Free (ErrorOp e)) = ([], Left e)

a4/src/APL/Interp_Tests.hs

@@ -81,7 +81,23 @@ pureTests =
       --
       testCase "TryCatch catch1" $
         eval' (TryCatch (Div (CstInt 1) (CstInt 0)) (Div (CstInt 1) (CstInt 0)))
-          @?= ([], Left "Division by zero")
+          @?= ([], Left "Division by zero"),
+      --
+      testCase "KvPutOp" $
+        eval' (KvPut (CstInt 1) (CstInt 2))
+          @?= ([], Right (ValInt 2)),
+      --
+      testCase "KvGetOp" $
+        eval' (Let "_" (KvPut (CstInt 1) (CstInt 2)) (KvGet (CstInt 1)))
+          @?= ([], Right (ValInt 2)),
+      --
+      testCase "KvGetOp shadowing" $
+        eval' (Let "_" (KvPut (CstInt 1) (CstInt 2)) (Let "_" (KvPut (CstInt 1) (CstInt 3)) (KvGet (CstInt 1))))
+          @?= ([], Right (ValInt 3)),
+      --
+      testCase "KvGetOp fail" $
+        eval' (KvGet (CstInt 1))
+          @?= ([], Left "Cannot find key :)")
     ]
 
 ioTests :: TestTree
@@ -96,16 +112,13 @@ ioTests =
             runEvalIO $ do
               evalPrint s1
               evalPrint s2
-        (out, res) @?= ([s1, s2], Right ())
+        (out, res) @?= ([s1, s2], Right ()),
-        -- NOTE: This test will give a runtime error unless you replace the
+        testCase "print 2" $ do
-        -- version of `eval` in `APL.Eval` with a complete version that supports
+           (out, res) <-
-        -- `Print`-expressions. Uncomment at your own risk.
+             captureIO [] $
-        -- testCase "print 2" $ do
+               evalIO' $
-        --    (out, res) <-
+                 Print "This is also 1" $
-        --      captureIO [] $
+                   Print "This is 1" $
-        --        evalIO' $
+                     CstInt 1
-        --          Print "This is also 1" $
+           (out, res) @?= (["This is 1: 1", "This is also 1: 1"], Right $ ValInt 1)
-        --            Print "This is 1" $
-        --              CstInt 1
-        --    (out, res) @?= (["This is 1: 1", "This is also 1: 1"], Right $ ValInt 1)
     ]

a4/src/APL/Monad.hs

@@ -77,6 +77,8 @@ data EvalOp a
   | PrintOp String a
   | ErrorOp Error
   | TryCatchOp a a
+  | KvGetOp Val (Val -> a)
+  | KvPutOp Val Val a
 
 instance Functor EvalOp where
   fmap f (ReadOp k) = ReadOp $ f . k
@@ -85,6 +87,8 @@ instance Functor EvalOp where
   fmap f (PrintOp p m) = PrintOp p $ f m
   fmap _ (ErrorOp e) = ErrorOp e
   fmap f (TryCatchOp m1 m2) = TryCatchOp (f m1) (f m2)
+  fmap f (KvGetOp v k) = KvGetOp v (f . k)
+  fmap f (KvPutOp v1 v2 m) = KvPutOp v1 v2 (f m)
 
 type EvalM a = Free EvalOp a
 
@@ -122,10 +126,10 @@ catch :: EvalM a -> EvalM a -> EvalM a
 catch m1 m2 = Free $ TryCatchOp m1 m2
 
 evalKvGet :: Val -> EvalM Val
-evalKvGet = error "TODO"
+evalKvGet v = Free $ KvGetOp v $ \w -> pure w
 
 evalKvPut :: Val -> Val -> EvalM ()
-evalKvPut = error "TODO"
+evalKvPut v1 v2 = Free $ KvPutOp v1 v2 $ pure ()
 
 transaction :: EvalM () -> EvalM ()
 transaction = error "TODO"