Skip to content

Commit

Permalink
[ADP-3272] Remove cardano-api conversions from Arbitrary instance…
Browse files Browse the repository at this point in the history
… for `PartialTx era`. (#4558)

This PR redefines the `Arbitrary` instance for `PartialTx era` in terms
of the following generators and shrinkers that use ledger types:

```hs
genTxForBalancing :: IsRecentEra era => Gen (Tx era)
genTxOut          :: IsRecentEra era => Gen (TxOut era)
shrinkTx          :: IsRecentEra era => Tx era -> [Tx era]
```

Internally, these generators and shrinkers may still use conversions to
and from `cardano-api` types, but those conversions no longer leak out
into code that calls them.

Importantly, this allows the definition of `Arbitrary` for `PartialTx
era` to be completely free of conversions, which makes the flow of data
clearer.

## Issue

ADP-3272
  • Loading branch information
jonathanknowles authored Apr 22, 2024
2 parents cb21a8e + c4a8e69 commit 33a5aa7
Showing 1 changed file with 32 additions and 24 deletions.
56 changes: 32 additions & 24 deletions lib/balance-tx/test/spec/Internal/Cardano/Write/Tx/BalanceSpec.hs
Original file line number Diff line number Diff line change
Expand Up @@ -278,7 +278,6 @@ import Internal.Cardano.Write.Tx
, Value
, cardanoEra
, fromCardanoApiTx
, fromCardanoApiUTxO
, recentEra
, serializeTx
, toCardanoApiTx
Expand Down Expand Up @@ -2666,38 +2665,26 @@ instance Arbitrary (MixedSign Value) where

instance forall era. IsRecentEra era => Arbitrary (PartialTx era) where
arbitrary = do
tx <- CardanoApi.genTxForBalancing $ cardanoEra @era
tx <- genTxForBalancing
extraUTxO <- genExtraUTxO tx
return PartialTx
{ tx = fromCardanoApiTx tx
, extraUTxO = fromCardanoApiUTxO extraUTxO
, redeemers = []
, timelockKeyWitnessCounts = mempty
}
let redeemers = []
let timelockKeyWitnessCounts = mempty
pure PartialTx {tx, extraUTxO, redeemers, timelockKeyWitnessCounts}
where
genExtraUTxO :: Tx era -> Gen (UTxO era)
genExtraUTxO tx =
CardanoApi.UTxO . Map.fromList <$>
mapM (\i -> (i,) <$> genTxOut) (txInputs tx)
genTxOut =
-- NOTE: genTxOut does not generate quantities larger than
-- `maxBound :: Word64`, however users could supply these. We
-- should ideally test what happens, and make it clear what
-- code, if any, should validate.
CardanoApi.genTxOut (cardanoEra @era)
txInputs tx = fst <$> CardanoApi.txIns content
UTxO . Map.fromList <$>
mapM (\i -> (i,) <$> genTxOut) (Set.toList txInputs)
where
CardanoApi.Tx (CardanoApi.TxBody content) _ = tx
txInputs :: Set TxIn
txInputs = tx ^. bodyTxL . inputsTxBodyL
shrink partialTx@PartialTx {tx, extraUTxO} =
[ partialTx {extraUTxO = extraUTxO'}
| extraUTxO' <- shrinkInputResolution extraUTxO
] <>
[ restrictResolution (partialTx {tx = fromCardanoApiTx tx'})
| tx' <- shrinkCardanoApiTx (toCardanoApiTx tx)
[ restrictResolution (partialTx {tx = tx'})
| tx' <- shrinkTx tx
]
where
shrinkCardanoApiTx = case recentEra @era of
RecentEraBabbage -> shrinkTxBabbage
RecentEraConway -> \_ -> [] -- no shrinker implemented yet

instance Arbitrary StdGenSeed where
arbitrary = StdGenSeed . fromIntegral @Int <$> arbitrary
Expand Down Expand Up @@ -2816,6 +2803,19 @@ instance forall era. IsRecentEra era => Arbitrary (Wallet era) where

shrinkEntry _ = []

genTxForBalancing :: forall era. IsRecentEra era => Gen (Tx era)
genTxForBalancing =
fromCardanoApiTx <$> CardanoApi.genTxForBalancing (cardanoEra @era)

genTxOut :: forall era. IsRecentEra era => Gen (TxOut era)
genTxOut =
-- NOTE: genTxOut does not generate quantities larger than
-- `maxBound :: Word64`, however users could supply these. We
-- should ideally test what happens, and make it clear what
-- code, if any, should validate.
CardanoApi.toShelleyTxOut (Write.shelleyBasedEra @era)
<$> CardanoApi.genTxOut (cardanoEra @era)

-- | For writing shrinkers in the style of https://stackoverflow.com/a/14006575
prependOriginal :: (t -> [t]) -> t -> [t]
prependOriginal shrinker x = x : shrinker x
Expand Down Expand Up @@ -2875,6 +2875,14 @@ shrinkStrictMaybe = \case
SNothing -> []
SJust _ -> [SNothing]

shrinkTx :: forall era. IsRecentEra era => Tx era -> [Tx era]
shrinkTx =
shrinkMapBy fromCardanoApiTx toCardanoApiTx shrinkCardanoApiTx
where
shrinkCardanoApiTx = case recentEra @era of
RecentEraBabbage -> shrinkTxBabbage
RecentEraConway -> \_ -> [] -- no shrinker implemented yet

shrinkTxBabbage
:: CardanoApi.Tx CardanoApi.BabbageEra
-> [CardanoApi.Tx CardanoApi.BabbageEra]
Expand Down

0 comments on commit 33a5aa7

Please sign in to comment.