diff --git a/a4/src/APL/InterpIO.hs b/a4/src/APL/InterpIO.hs index ba20de8..d19e935 100644 --- a/a4/src/APL/InterpIO.hs +++ b/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 diff --git a/a4/src/APL/InterpPure.hs b/a4/src/APL/InterpPure.hs index 3a6c5e5..4b3d02c 100644 --- a/a4/src/APL/InterpPure.hs +++ b/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 diff --git a/a4/src/APL/Interp_Tests.hs b/a4/src/APL/Interp_Tests.hs index c675ffa..55800c6 100644 --- a/a4/src/APL/Interp_Tests.hs +++ b/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) ]