:(

a4/src/APL/InterpPure.hs

@@ -20,7 +20,17 @@ runEval = runEval' envEmpty stateInitial
     runEval' r s (Free (KvGetOp key k)) =
       case (lookup key s) of
         Just val -> runEval' r s $ k val
-        Nothing -> ([], Left "Cannot find key :)")
+        Nothing -> ([], Left ("Cannot find key: "++(show key)))
     runEval' r s (Free (KvPutOp key val m)) =
       runEval' r ((key,val):s) m
+    runEval' r s (Free (TransactionOp l m)) = do
+      (p, resl) <- (runEval' r s l)
+      case (runEval' r s l) of
+        Right _ -> do
+          s' <- getState
+          (ps, resm) <- (runEval' r s' m)
+          return (p ++ ps, resm)
+        Left _ -> do
+          (ps, resm) <- runEval' r s m
+          return (p ++ ps, resm)
     runEval' _ _ (Free (ErrorOp e)) = ([], Left e)

a4/src/APL/Interp_Tests.hs

@@ -97,7 +97,19 @@ pureTests =
       --
       testCase "KvGetOp fail" $
         eval' (KvGet (CstInt 1))
-          @?= ([], Left "Cannot find key :)")
+          @?= ([], Left "Cannot find key: ValInt 1"),
+      --
+      testCase "TransactionOp 1" $
+        runEval (transaction (evalKvPut (ValInt 0) (ValInt 1)))
+          @?= ([], Right ()),
+      --
+      testCase "TransactionOp 2" $
+        runEval ((transaction (evalKvPut (ValInt 0) (ValInt 1))) >> (eval (KvGet (CstInt 0))))
+          @?= ([], Right (ValInt 1)),
+      --
+      testCase "TransactionOp Fail" $
+        runEval ((transaction ((evalKvPut (ValInt 0) (ValInt 1)) >> (failure "die"))) >> (eval (KvGet (CstInt 0))))
+          @?= ([], Left "Cannot find key: ValInt 0")
     ]
 
 ioTests :: TestTree

a4/src/APL/Monad.hs

@@ -79,6 +79,7 @@ data EvalOp a
   | TryCatchOp a a
   | KvGetOp Val (Val -> a)
   | KvPutOp Val Val a
+  | TransactionOp (EvalM ()) a
 
 instance Functor EvalOp where
   fmap f (ReadOp k) = ReadOp $ f . k
@@ -89,6 +90,7 @@ instance Functor EvalOp where
   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)
+  fmap f (TransactionOp l m) = TransactionOp l (f m)
 
 type EvalM a = Free EvalOp a
 
@@ -132,4 +134,4 @@ evalKvPut :: Val -> Val -> EvalM ()
 evalKvPut v1 v2 = Free $ KvPutOp v1 v2 $ pure ()
 
 transaction :: EvalM () -> EvalM ()
-transaction = error "TODO"
+transaction v = Free $ TransactionOp v $ pure ()