✨

a4/src/APL/InterpIO.hs

@@ -93,9 +93,20 @@ runEvalIO evalm = do
           writeDB db dbState'
           runEvalIO' r db m
         Left e -> pure $ Left e
-    runEvalIO' _ _ (Free (ErrorOp e)) = pure $ Left e
     runEvalIO' r db (Free (TryCatchOp m1 m2)) = do
       result <- runEvalIO' r db m1
       case result of
         Right x -> pure $ Right x
         Left _ -> runEvalIO' r db m2
+    runEvalIO' r db (Free (TransactionOp l m)) = do
+      withTempDB transactionDB
+      runEvalIO' r db m
+      where
+        transactionDB :: (FilePath -> IO ())
+        transactionDB db' = do
+          copyDB db db'
+          resl <- runEvalIO' r db (do l)
+          case resl of
+            Right _ -> pure ()
+            Left _ -> copyDB db' db
+    runEvalIO' _ _ (Free (ErrorOp e)) = pure $ Left e

a4/src/APL/InterpPure.hs

@@ -24,7 +24,7 @@ runEval = runEval' envEmpty stateInitial
     runEval' r s (Free (KvPutOp key val m)) =
       runEval' r ((key,val):s) m
     runEval' r s (Free (TransactionOp l m)) =
-      let (p, resl) = runEval (do l >> getState)
+      let (p, resl) = runEval' r s (do l >> getState)
       in case resl of
         Right s' ->
           let (ps, resm) = runEval' r s' m

a4/src/APL/Interp_Tests.hs

@@ -110,6 +110,13 @@ pureTests =
         runEval (transaction goodPut >> get0)
           @?= ([], Right (ValInt 1)),
       --
+      testCase "TransactionOp 3" $
+        let oPut = (evalKvPut (ValInt 1) (ValInt 2)) in
+        let okayPut = ((evalKvGet (ValInt 1) >> evalKvPut (ValInt 0) (ValInt 1))) in
+        let get0 = eval (KvGet (CstInt 0)) in
+        runEval (oPut >> (transaction okayPut) >> get0)
+          @?= ([], Right (ValInt 1)),
+      --
       testCase "TransactionOp Fail" $
         let badPut = (evalKvPut (ValInt 0) (ValInt 1)) >> (failure "die") in
         let get0 = eval (KvGet (CstInt 0)) in
@@ -218,5 +225,49 @@ ioTests =
         (_, r) <-
           captureIO ["ValInt 1","ValInt 2","ValInt 3"] $
             evalIO' (Let "_" (KvPut (CstInt 3) (CstInt 2)) (KvGet (CstInt 4)))
-        r @?= Right (ValInt 2)
+        r @?= Right (ValInt 2),
+      --
+      testCase "TransactionOp 1" $
+        let goodPut = (evalKvPut (ValInt 0) (ValInt 1)) in do
+        r <- runEvalIO (transaction goodPut)
+        r @?= Right (),
+      --
+      testCase "TransactionOp 2" $
+        let goodPut = evalKvPut (ValInt 0) (ValInt 1) in
+        let get0 = eval (KvGet (CstInt 0)) in do
+        r <- runEvalIO (transaction goodPut >> get0)
+        r @?= Right (ValInt 1),
+      --
+      testCase "TransactionOp 3" $
+        let oPut = (evalKvPut (ValInt 1) (ValInt 2)) in
+        let okayPut = ((evalKvGet (ValInt 1) >> evalKvPut (ValInt 0) (ValInt 1))) in
+        let get0 = eval (KvGet (CstInt 0)) in do
+        r <- runEvalIO (oPut >> (transaction okayPut) >> get0)
+        r @?= Right (ValInt 1),
+      --
+      testCase "TransactionOp Fail" $
+        let badPut = (evalKvPut (ValInt 0) (ValInt 1)) >> (failure "die") in
+        let get0 = eval (KvGet (CstInt 0)) in do
+        (_, r) <-
+          captureIO [":)"] $
+            runEvalIO (transaction badPut >> get0)
+        r @?= Left "Invalid key: :)",
+      -- --
+      testCase "TransactionOp Propagation" $
+        let badPut = (evalKvPut (ValInt 0) (ValInt 1)) >> (failure "die") in do
+        r <- runEvalIO (transaction badPut)
+        r @?= Right (),
+      -- --
+      testCase "TransactionOp Printing" $ do
+        (p, r) <-
+          captureIO [] $
+            runEvalIO (transaction (evalPrint "weee" >> failure "oh shit"))
+        (p, r) @?= (["weee"], Right ()),
+      -- --
+      testCase "TransactionOp Nested" $
+        let badPut = (evalKvPut (ValInt 0) (ValInt 1)) >> (failure "die") in
+        let goodPut = evalKvPut (ValInt 0) (ValInt 1) in
+        let get0 = eval (KvGet (CstInt 0)) in do
+        r <- runEvalIO (transaction (goodPut >> transaction badPut) >> get0)
+        r @?= Right (ValInt 1)
     ]