Skip to content

Commit 92bf043

Browse files
AnteproperispomenonAnteproperispomenon
committed
Flattened case statements.
Since `assertFailure` throws an error, you don't actually have to case the rest of the do-block.
1 parent e2a0217 commit 92bf043

File tree

1 file changed

+83
-86
lines changed

1 file changed

+83
-86
lines changed

‎test/Spec/BotPlutusInterface/Balance.hs‎

Lines changed: 83 additions & 86 deletions
Original file line numberDiff line numberDiff line change
@@ -228,31 +228,27 @@ dontAddChangeToDatum = do
228228
<> Constraints.mustSpendPubKeyOutput txOutRef7
229229
eunbalancedTx = Constraints.mkTx @Void scrLkups txConsts
230230

231-
case eunbalancedTx of
232-
Left mkTxErr -> assertFailure ("MkTx Error: " <> show mkTxErr)
233-
Right unbalancedTx -> do
234-
let (eRslt, _finalState) = runPABEffectPure initState (balanceTxIO @() @'[PABEffect ()] pabConf pkh3 unbalancedTx)
235-
case eRslt of
236-
(Left txt) -> assertFailure ("PAB effect error: " <> Text.unpack txt)
237-
(Right (Left txt)) -> assertFailure $ "Balancing error: " <> Text.unpack txt
238-
(Right (Right trx)) -> do
239-
let scrTxOut'' = scrTxOut' & Ledger.ciTxOutValue <>~ Ada.lovelaceValueOf 500
240-
scrTxOutExpected = Ledger.toTxOut scrTxOut''
241-
isScrUtxo :: TxOut -> Bool
242-
isScrUtxo utxo = txOutAddress utxo == txOutAddress scrTxOutExpected
243-
(balScrUtxos, balOtherUtxos) = partition isScrUtxo (txOutputs trx)
244-
assertBool
245-
( "Expected UTxO not in output Tx."
246-
<> "\nExpected UTxO: "
247-
<> show scrTxOutExpected
248-
<> "\nBalanced Script UTxOs: "
249-
<> show balScrUtxos
250-
<> "\nOther Balanced UTxOs: "
251-
<> show balOtherUtxos
252-
<> "\nUnbalanced UTxOs: "
253-
<> show (txOutputs (unbalancedTx ^. OffChain.tx))
254-
)
255-
(scrTxOutExpected `elem` txOutputs trx)
231+
unbalancedTx <- liftAssertFailure eunbalancedTx (\err -> "MkTx Error: " <> show err)
232+
let (eRslt, _finalState) = runPABEffectPure initState (balanceTxIO @() @'[PABEffect ()] pabConf pkh3 unbalancedTx)
233+
eRslt' <- liftAssertFailure eRslt (\txt -> "PAB effect error: " <> Text.unpack txt)
234+
trx <- liftAssertFailure eRslt' (\txt -> "Balancing error: " <> Text.unpack txt)
235+
let scrTxOut'' = scrTxOut' & Ledger.ciTxOutValue <>~ Ada.lovelaceValueOf 500
236+
scrTxOutExpected = Ledger.toTxOut scrTxOut''
237+
isScrUtxo :: TxOut -> Bool
238+
isScrUtxo utxo = txOutAddress utxo == txOutAddress scrTxOutExpected
239+
(balScrUtxos, balOtherUtxos) = partition isScrUtxo (txOutputs trx)
240+
assertBool
241+
( "Expected UTxO not in output Tx."
242+
<> "\nExpected UTxO: "
243+
<> show scrTxOutExpected
244+
<> "\nBalanced Script UTxOs: "
245+
<> show balScrUtxos
246+
<> "\nOther Balanced UTxOs: "
247+
<> show balOtherUtxos
248+
<> "\nUnbalanced UTxOs: "
249+
<> show (txOutputs (unbalancedTx ^. OffChain.tx))
250+
)
251+
(scrTxOutExpected `elem` txOutputs trx)
256252

257253
-- Like the first one, but
258254
-- only has inputs from the script.
@@ -297,64 +293,65 @@ dontAddChangeToDatum2 = do
297293
<> Constraints.mustSpendScriptOutput txOutRef6 Ledger.unitRedeemer
298294
eunbalancedTx = Constraints.mkTx @Void scrLkups txConsts
299295

300-
case eunbalancedTx of
301-
Left mkTxErr -> assertFailure ("MkTx Error: " <> show mkTxErr)
302-
Right unbalancedTx -> do
303-
let (eRslt, _finalState) = runPABEffectPure initState (balanceTxIO @() @'[PABEffect ()] pabConf pkh3 unbalancedTx)
304-
case eRslt of
305-
(Left txt) -> assertFailure ("PAB effect error: " <> Text.unpack txt)
306-
(Right (Left txt)) -> assertFailure $ "Balancing error: " <> Text.unpack txt
307-
(Right (Right trx)) -> do
308-
let scrTxOut'' = scrTxOut' & Ledger.ciTxOutValue .~ scrValue'
309-
scrTxOutExpected = Ledger.toTxOut scrTxOut''
310-
isScrUtxo :: TxOut -> Bool
311-
isScrUtxo utxo = txOutAddress utxo == txOutAddress scrTxOutExpected
312-
(balScrUtxos, balOtherUtxos) = partition isScrUtxo (txOutputs trx)
313-
-- Check that the expected script UTxO
314-
-- is in the output.
315-
assertBool
316-
( "Expected UTxO not in output Tx."
317-
<> "\nExpected UTxO: "
318-
<> show scrTxOutExpected
319-
<> "\nBalanced Script UTxOs: "
320-
<> show balScrUtxos
321-
<> "\nOther Balanced UTxOs: "
322-
<> show balOtherUtxos
323-
<> "\nUnbalanced UTxOs: "
324-
<> show (txOutputs (unbalancedTx ^. OffChain.tx))
325-
)
326-
(scrTxOutExpected `elem` txOutputs trx)
327-
-- Check that the output has the remaining change
328-
let trxFee = txFee trx
329-
adaChange' :: Integer
330-
adaChange' = ((-) `on` (lovelaceInValue . txOutValue)) scrTxOut scrTxOutExpected
331-
adaChange :: Integer
332-
adaChange = adaChange' - lovelaceInValue trxFee
333-
tokChange :: Integer
334-
tokChange = ((-) `on` (acValueOf tokenAsset . txOutValue)) scrTxOut scrTxOutExpected
335-
remainingTxOuts :: [TxOut]
336-
remainingTxOuts = delete scrTxOutExpected (txOutputs trx)
337-
remainingValue :: Value.Value
338-
remainingValue = foldMap txOutValue remainingTxOuts
339-
-- Check for ADA change
340-
assertBool
341-
( "Other UTxOs do not contain expected ADA change."
342-
<> "\nExpected Amount : "
343-
<> show adaChange
344-
<> " Lovelace"
345-
<> "\nActual Amount : "
346-
<> show (lovelaceInValue remainingValue)
347-
<> " Lovelace"
348-
)
349-
(adaChange == lovelaceInValue remainingValue)
350-
-- Check for Token change
351-
assertBool
352-
( "Other UTxOs do not contain expected Token change."
353-
<> "\nExpected Amount : "
354-
<> show tokChange
355-
<> " tokens"
356-
<> "\nActual Amount : "
357-
<> show (acValueOf tokenAsset remainingValue)
358-
<> " tokens"
359-
)
360-
(tokChange == acValueOf tokenAsset remainingValue)
296+
unbalancedTx <- liftAssertFailure eunbalancedTx (\err -> "MkTx Error: " <> show err)
297+
let (eRslt, _finalState) = runPABEffectPure initState (balanceTxIO @() @'[PABEffect ()] pabConf pkh3 unbalancedTx)
298+
eRslt' <- liftAssertFailure eRslt (\txt -> "PAB effect error: " <> Text.unpack txt)
299+
trx <- liftAssertFailure eRslt' (\txt -> "Balancing error: " <> Text.unpack txt)
300+
let scrTxOut'' = scrTxOut' & Ledger.ciTxOutValue .~ scrValue'
301+
scrTxOutExpected = Ledger.toTxOut scrTxOut''
302+
isScrUtxo :: TxOut -> Bool
303+
isScrUtxo utxo = txOutAddress utxo == txOutAddress scrTxOutExpected
304+
(balScrUtxos, balOtherUtxos) = partition isScrUtxo (txOutputs trx)
305+
-- Check that the expected script UTxO
306+
-- is in the output.
307+
assertBool
308+
( "Expected UTxO not in output Tx."
309+
<> "\nExpected UTxO: "
310+
<> show scrTxOutExpected
311+
<> "\nBalanced Script UTxOs: "
312+
<> show balScrUtxos
313+
<> "\nOther Balanced UTxOs: "
314+
<> show balOtherUtxos
315+
<> "\nUnbalanced UTxOs: "
316+
<> show (txOutputs (unbalancedTx ^. OffChain.tx))
317+
)
318+
(scrTxOutExpected `elem` txOutputs trx)
319+
-- Check that the output has the remaining change
320+
let trxFee = txFee trx
321+
adaChange' :: Integer
322+
adaChange' = ((-) `on` (lovelaceInValue . txOutValue)) scrTxOut scrTxOutExpected
323+
adaChange :: Integer
324+
adaChange = adaChange' - lovelaceInValue trxFee
325+
tokChange :: Integer
326+
tokChange = ((-) `on` (acValueOf tokenAsset . txOutValue)) scrTxOut scrTxOutExpected
327+
remainingTxOuts :: [TxOut]
328+
remainingTxOuts = delete scrTxOutExpected (txOutputs trx)
329+
remainingValue :: Value.Value
330+
remainingValue = foldMap txOutValue remainingTxOuts
331+
-- Check for ADA change
332+
assertBool
333+
( "Other UTxOs do not contain expected ADA change."
334+
<> "\nExpected Amount : "
335+
<> show adaChange
336+
<> " Lovelace"
337+
<> "\nActual Amount : "
338+
<> show (lovelaceInValue remainingValue)
339+
<> " Lovelace"
340+
)
341+
(adaChange == lovelaceInValue remainingValue)
342+
-- Check for Token change
343+
assertBool
344+
( "Other UTxOs do not contain expected Token change."
345+
<> "\nExpected Amount : "
346+
<> show tokChange
347+
<> " tokens"
348+
<> "\nActual Amount : "
349+
<> show (acValueOf tokenAsset remainingValue)
350+
<> " tokens"
351+
)
352+
(tokChange == acValueOf tokenAsset remainingValue)
353+
354+
-- | Lift an `Either` value into an `assertFailure`.
355+
liftAssertFailure :: Either a b -> (a -> String) -> IO b
356+
liftAssertFailure (Left err) fstr = assertFailure (fstr err)
357+
liftAssertFailure (Right rslt) _ = return rslt

0 commit comments

Comments
 (0)