From 067f70622fc35073748e948719e3a328d61eecd3 Mon Sep 17 00:00:00 2001
From: Nikolaj Gade <nikolaj@ingemanngade.net>
Date: Sun, 6 Oct 2024 15:30:00 +0200
Subject: [PATCH] :)

---
 a4/src/APL/InterpPure.hs   | 19 +++++++++----------
 a4/src/APL/Interp_Tests.hs | 31 ++++++++++++++++++++++++++-----
 2 files changed, 35 insertions(+), 15 deletions(-)

diff --git a/a4/src/APL/InterpPure.hs b/a4/src/APL/InterpPure.hs
index 84cdc27..3a6c5e5 100644
--- a/a4/src/APL/InterpPure.hs
+++ b/a4/src/APL/InterpPure.hs
@@ -23,14 +23,13 @@ runEval = runEval' envEmpty stateInitial
         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' r s (Free (TransactionOp l m)) =
+      let (p, resl) = runEval (do l >> getState)
+      in case resl of
+        Right s' ->
+          let (ps, resm) = runEval' r s' m
+          in (p ++ ps, resm)
+        Left _ ->
+          let (ps, resm) = runEval' r s m
+          in (p ++ ps, resm)
     runEval' _ _ (Free (ErrorOp e)) = ([], Left e)
diff --git a/a4/src/APL/Interp_Tests.hs b/a4/src/APL/Interp_Tests.hs
index 2d4d769..c675ffa 100644
--- a/a4/src/APL/Interp_Tests.hs
+++ b/a4/src/APL/Interp_Tests.hs
@@ -79,7 +79,7 @@ pureTests =
         eval' (TryCatch (Div (CstInt 1) (CstInt 0)) (CstInt 1))
           @?= ([], Right (ValInt 1)),
       --
-      testCase "TryCatch catch1" $
+      testCase "TryCatch catch2" $
         eval' (TryCatch (Div (CstInt 1) (CstInt 0)) (Div (CstInt 1) (CstInt 0)))
           @?= ([], Left "Division by zero"),
       --
@@ -100,16 +100,37 @@ pureTests =
           @?= ([], Left "Cannot find key: ValInt 1"),
       --
       testCase "TransactionOp 1" $
-        runEval (transaction (evalKvPut (ValInt 0) (ValInt 1)))
+        let goodPut = (evalKvPut (ValInt 0) (ValInt 1)) in
+        runEval (transaction goodPut)
           @?= ([], Right ()),
       --
       testCase "TransactionOp 2" $
-        runEval ((transaction (evalKvPut (ValInt 0) (ValInt 1))) >> (eval (KvGet (CstInt 0))))
+        let goodPut = evalKvPut (ValInt 0) (ValInt 1) in
+        let get0 = eval (KvGet (CstInt 0)) in
+        runEval (transaction goodPut >> get0)
           @?= ([], 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")
+        let badPut = (evalKvPut (ValInt 0) (ValInt 1)) >> (failure "die") in
+        let get0 = eval (KvGet (CstInt 0)) in
+        runEval (transaction badPut >> get0)
+          @?= ([], Left "Cannot find key: ValInt 0"),
+      --
+      testCase "TransactionOp Propagation" $
+        let badPut = (evalKvPut (ValInt 0) (ValInt 1)) >> (failure "die") in
+        runEval (transaction badPut)
+          @?= ([], Right ()),
+      --
+      testCase "TransactionOp Printing" $
+        runEval (transaction (evalPrint "weee" >> failure "oh shit"))
+          @?= (["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
+        runEval (transaction (goodPut >> transaction badPut) >> get0)
+          @?= ([], Right (ValInt 1))
     ]
 
 ioTests :: TestTree