Skip to content

Commit a8f435c

Browse files
SoupstrawSoupstraw
committed
Reduce code duplication
1 parent c055a28 commit a8f435c

File tree

5 files changed

+70
-128
lines changed
  • eras
    • alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary
    • conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary
    • dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Binary
  • libs
    • cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary
    • cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary

5 files changed

+70
-128
lines changed

‎eras/alonzo/impl/testlib/Test/Cardano/Ledger/Alonzo/Binary/Golden.hs‎

Lines changed: 17 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -69,20 +69,29 @@ expectSuccessOnEmptyFieldRaw version k =
6969
txWitsDecodingFailsOnInvalidField :: forall era. AlonzoEraTest era => Version -> [Int] -> Spec
7070
txWitsDecodingFailsOnInvalidField version validFields =
7171
prop "Invalid field" $ \n ->
72-
n `notElem` validFields ==> expectFailureOnTxWitsEmptyField @era version n $
73-
DecoderErrorDeserialiseFailure
74-
(Binary.label $ Proxy @(Annotator (TxWits era)))
75-
( DeserialiseFailure 2 $
76-
"An error occurred while decoding (Int,Void) not a valid key:.\nError: " <> show n
77-
)
72+
n
73+
`notElem` validFields
74+
==> expectFailureOnTxWitsEmptyField @era version n
75+
$ if n >= 0
76+
then
77+
DecoderErrorDeserialiseFailure
78+
lbl
79+
( DeserialiseFailure (if n >= 24 then 3 else 2) $
80+
-- TODO fix the `occured` typo in the produced value
81+
"An error occured while decoding (Int,Void) not a valid key:.\nError: " <> show n
82+
)
83+
else
84+
DecoderErrorDeserialiseFailure lbl (DeserialiseFailure 1 "expected word")
85+
where
86+
lbl = Binary.label $ Proxy @(Annotator (TxWits era))
7887

7988
spec ::
8089
forall era.
8190
(AlonzoEraTest era, ShelleyEraTxCert era) =>
8291
Spec
8392
spec = do
8493
describe "TxWits" $ do
85-
forEachEraVersion @era $ \version ->
94+
forEachEraVersion @era $ \version -> do
8695
describe "Empty fields allowed" $ do
8796
it "addrTxWits" $ expectSuccessOnEmptyFieldRaw @era version 0
8897
it "nativeScripts" $ expectSuccessOnEmptyFieldRaw @era version 1
@@ -95,5 +104,6 @@ spec = do
95104
-- from there onwards
96105
it "plutusV2Script" $ expectSuccessOnEmptyFieldRaw @era version 6
97106
it "plutusV3Script" $ expectSuccessOnEmptyFieldRaw @era version 7
107+
txWitsDecodingFailsOnInvalidField @era version [0 .. 7]
98108
describe "TxCerts" $ do
99109
forEachEraVersion @era $ allegraDecodeDuplicateDelegCertSucceeds @era

‎eras/conway/impl/testlib/Test/Cardano/Ledger/Conway/Binary/Golden.hs‎

Lines changed: 22 additions & 47 deletions
Original file line numberDiff line numberDiff line change
@@ -117,67 +117,42 @@ spec = do
117117
describe "TxWits" $
118118
describe "Empty fields not allowed" $ do
119119
forEachEraVersion @era $ \version -> do
120-
describe "Untagged" $ do
121-
it "addrTxWits" . expectFailureOnTxWitsEmptyField @era version 0 $
120+
let
121+
decoderFailure n msg =
122122
DecoderErrorDeserialiseFailure
123123
(Binary.label $ Proxy @(Annotator (TxWits era)))
124-
(DeserialiseFailure 4 "Empty list found, expected non-empty")
124+
(DeserialiseFailure n msg)
125+
describe "Untagged" $ do
126+
it "addrTxWits" . expectFailureOnTxWitsEmptyField @era version 0 $
127+
decoderFailure 4 "Empty list found, expected non-empty"
125128
it "nativeScripts" . expectFailureOnTxWitsEmptyField @era version 1 $
126-
DecoderErrorDeserialiseFailure
127-
(Binary.label $ Proxy @(Annotator (TxWits era)))
128-
(DeserialiseFailure 4 "Empty list found, expected non-empty")
129+
decoderFailure 4 "Empty list found, expected non-empty"
129130
it "bootstrapWitness" . expectFailureOnTxWitsEmptyField @era version 2 $
130-
DecoderErrorDeserialiseFailure
131-
(Binary.label $ Proxy @(Annotator (TxWits era)))
132-
(DeserialiseFailure 4 "Empty list found, expected non-empty")
131+
decoderFailure 4 "Empty list found, expected non-empty"
133132
it "plutusV1Script" . expectFailureOnTxWitsEmptyField @era version 3 $
134-
DecoderErrorDeserialiseFailure
135-
(Binary.label $ Proxy @(Annotator (TxWits era)))
136-
(DeserialiseFailure 4 "Empty list of scripts is not allowed")
133+
decoderFailure 4 "Empty list of scripts is not allowed"
137134
it "plutusData" . expectFailureOnTxWitsEmptyField @era version 4 $
138-
DecoderErrorDeserialiseFailure
139-
(Binary.label $ Proxy @(Annotator (TxWits era)))
140-
(DeserialiseFailure 4 "Empty list found, expected non-empty")
135+
decoderFailure 4 "Empty list found, expected non-empty"
141136
it "redeemers" . expectFailureOnTxWitsEmptyField @era version 5 $
142-
DecoderErrorDeserialiseFailure
143-
(Binary.label $ Proxy @(Annotator (TxWits era)))
144-
(DeserialiseFailure 4 "Empty list found, expected non-empty")
137+
decoderFailure 4 "Empty list found, expected non-empty"
145138
it "plutusV2Script" . expectFailureOnTxWitsEmptyField @era version 6 $
146-
DecoderErrorDeserialiseFailure
147-
(Binary.label $ Proxy @(Annotator (TxWits era)))
148-
(DeserialiseFailure 4 "Empty list of scripts is not allowed")
139+
decoderFailure 4 "Empty list of scripts is not allowed"
149140
it "plutusV3Script" . expectFailureOnTxWitsEmptyField @era version 7 $
150-
DecoderErrorDeserialiseFailure
151-
(Binary.label $ Proxy @(Annotator (TxWits era)))
152-
(DeserialiseFailure 4 "Empty list of scripts is not allowed")
153-
txWitsDecodingFailsOnInvalidField @era version [0 .. 7]
141+
decoderFailure 4 "Empty list of scripts is not allowed"
154142
describe "Tagged" $ do
155-
it "addrTxWits" . expectFailureOnTxWitsEmptyField @era version 0 $
156-
DecoderErrorDeserialiseFailure
157-
(Binary.label $ Proxy @(Annotator (TxWits era)))
158-
(DeserialiseFailure 7 "Empty list found, expected non-empty")
143+
it "addrTxWits" . expectFailureOnTxWitsEmptyFieldWithTag @era version 0 $
144+
decoderFailure 7 "Empty list found, expected non-empty"
159145
it "nativeScripts" . expectFailureOnTxWitsEmptyFieldWithTag @era version 1 $
160-
DecoderErrorDeserialiseFailure
161-
(Binary.label $ Proxy @(Annotator (TxWits era)))
162-
(DeserialiseFailure 7 "Empty list found, expected non-empty")
146+
decoderFailure 7 "Empty list found, expected non-empty"
163147
it "bootstrapWitness" . expectFailureOnTxWitsEmptyFieldWithTag @era version 2 $
164-
DecoderErrorDeserialiseFailure
165-
(Binary.label $ Proxy @(Annotator (TxWits era)))
166-
(DeserialiseFailure 7 "Empty list found, expected non-empty")
148+
decoderFailure 7 "Empty list found, expected non-empty"
167149
it "plutusV1Script" . expectFailureOnTxWitsEmptyFieldWithTag @era version 3 $
168-
DecoderErrorDeserialiseFailure
169-
(Binary.label $ Proxy @(Annotator (TxWits era)))
170-
(DeserialiseFailure 7 "Empty list of scripts is not allowed")
150+
decoderFailure 7 "Empty list of scripts is not allowed"
171151
it "plutusData" . expectFailureOnTxWitsEmptyFieldWithTag @era version 4 $
172-
DecoderErrorDeserialiseFailure
173-
(Binary.label $ Proxy @(Annotator (TxWits era)))
174-
(DeserialiseFailure 7 "Empty list found, expected non-empty")
152+
decoderFailure 7 "Empty list found, expected non-empty"
175153
it "plutusV2Script" . expectFailureOnTxWitsEmptyFieldWithTag @era version 6 $
176-
DecoderErrorDeserialiseFailure
177-
(Binary.label $ Proxy @(Annotator (TxWits era)))
178-
(DeserialiseFailure 7 "Empty list of scripts is not allowed")
154+
decoderFailure 7 "Empty list of scripts is not allowed"
179155
it "plutusV3Script" . expectFailureOnTxWitsEmptyFieldWithTag @era version 7 $
180-
DecoderErrorDeserialiseFailure
181-
(Binary.label $ Proxy @(Annotator (TxWits era)))
182-
(DeserialiseFailure 7 "Empty list of scripts is not allowed")
156+
decoderFailure 7 "Empty list of scripts is not allowed"
157+
txWitsDecodingFailsOnInvalidField @era version [0 .. 7]
183158
describe "TxCerts" . forEachEraVersion @era $ conwayDecodeDuplicateDelegCertFails @era

‎eras/dijkstra/impl/testlib/Test/Cardano/Ledger/Dijkstra/Binary/Golden.hs‎

Lines changed: 29 additions & 56 deletions
Original file line numberDiff line numberDiff line change
@@ -35,7 +35,7 @@ import qualified Data.Set as Set
3535
import Lens.Micro
3636
import Test.Cardano.Ledger.Alonzo.Arbitrary (alwaysSucceedsLang)
3737
import Test.Cardano.Ledger.Binary.Plain.Golden (Enc (..))
38-
import Test.Cardano.Ledger.Common (Small (..), Spec, describe, it, prop, (==>))
38+
import Test.Cardano.Ledger.Common (Spec, describe, it)
3939
import Test.Cardano.Ledger.Conway.Binary.Golden hiding (spec)
4040
import Test.Cardano.Ledger.Core.KeyPair (mkKeyPair, mkWitnessVKey)
4141
import Test.Cardano.Ledger.Core.Utils (mkDummySafeHash)
@@ -61,71 +61,44 @@ spec = describe "Golden" . forEachEraVersion @era $ \version -> do
6161
goldenEmptyFields :: forall era. DijkstraEraTest era => Version -> Spec
6262
goldenEmptyFields version =
6363
describe "Empty fields not allowed" $ do
64-
describe "Untagged" $ do
65-
let
66-
it "addrTxWits" . expectFailureOnTxWitsEmptyField @era version 0 $
64+
let
65+
decoderFailure n msg =
6766
DecoderErrorDeserialiseFailure
6867
(Binary.label $ Proxy @(Annotator (TxWits era)))
69-
(DeserialiseFailure 4 "Set cannot be empty")
68+
(DeserialiseFailure n msg)
69+
describe "Untagged" $ do
70+
it "addrTxWits" . expectFailureOnTxWitsEmptyField @era version 0 $
71+
decoderFailure 4 "Empty list found, expected non-empty"
7072
it "nativeScripts" . expectFailureOnTxWitsEmptyField @era version 1 $
71-
DecoderErrorCustom "Annotator" "Empty script Set is not allowed"
73+
decoderFailure 4 "Empty list found, expected non-empty"
7274
it "bootstrapWitness" . expectFailureOnTxWitsEmptyField @era version 2 $
73-
DecoderErrorDeserialiseFailure
74-
(Binary.label $ Proxy @(Annotator (TxWits era)))
75-
(DeserialiseFailure 4 "Set cannot be empty")
75+
decoderFailure 4 "Empty list found, expected non-empty"
7676
it "plutusV1Script" . expectFailureOnTxWitsEmptyField @era version 3 $
77-
DecoderErrorDeserialiseFailure
78-
"Annotator (MemoBytes (AlonzoTxWitsRaw DijkstraEra))"
79-
(DeserialiseFailure 4 "Empty list of scripts is not allowed")
77+
decoderFailure 4 "Empty list of scripts is not allowed"
8078
it "plutusData" . expectFailureOnTxWitsEmptyField @era version 4 $
81-
DecoderErrorCustom "Annotator" "Empty script Set is not allowed"
79+
decoderFailure 4 "Empty list found, expected non-empty"
8280
it "redeemers" . expectFailureOnTxWitsEmptyField @era version 5 $
83-
DecoderErrorDeserialiseFailure
84-
"Annotator (MemoBytes (AlonzoTxWitsRaw DijkstraEra))"
85-
(DeserialiseFailure 2 "List encoding of redeemers not supported starting with PV 12")
81+
decoderFailure 2 "List encoding of redeemers not supported starting with PV 12"
8682
it "plutusV2Script" . expectFailureOnTxWitsEmptyField @era version 6 $
87-
DecoderErrorDeserialiseFailure
88-
"Annotator (MemoBytes (AlonzoTxWitsRaw DijkstraEra))"
89-
(DeserialiseFailure 4 "Empty list of scripts is not allowed")
83+
decoderFailure 4 "Empty list of scripts is not allowed"
9084
it "plutusV3Script" . expectFailureOnTxWitsEmptyField @era version 7 $
91-
DecoderErrorDeserialiseFailure
92-
"Annotator (MemoBytes (AlonzoTxWitsRaw DijkstraEra))"
93-
(DeserialiseFailure 4 "Empty list of scripts is not allowed")
94-
-- TODO replace this with `plutusV4Script` once that is added
95-
txWitsDecodingFailsOnInvalidField @era version [0 .. 7]
85+
decoderFailure 4 "Empty list of scripts is not allowed"
9686
describe "Tagged" $ do
97-
let
98-
it "addrTxWits" . expectFailureOnTxWitsEmptyField @era version 0 $
99-
DecoderErrorDeserialiseFailure
100-
(Binary.label $ Proxy @(Annotator (TxWits era)))
101-
(DeserialiseFailure 7 "Set cannot be empty")
102-
it "nativeScripts" . expectFailureOnTxWitsEmptyField @era version 1 $
103-
DecoderErrorCustom "Annotator" "Empty script Set is not allowed"
104-
it "bootstrapWitness" . expectFailureOnTxWitsEmptyField @era version 2 $
105-
DecoderErrorDeserialiseFailure
106-
(Binary.label $ Proxy @(Annotator (TxWits era)))
107-
(DeserialiseFailure 7 "Set cannot be empty")
108-
it "plutusV1Script" . expectFailureOnTxWitsEmptyField @era version 3 $
109-
DecoderErrorDeserialiseFailure
110-
(Binary.label $ Proxy @(Annotator (TxWits era)))
111-
(DeserialiseFailure 7 "Empty list of scripts is not allowed")
112-
it "plutusData" . expectFailureOnTxWitsEmptyField @era version 4 $
113-
DecoderErrorCustom "Annotator" "Empty script Set is not allowed"
114-
it "plutusV2Script" . expectFailureOnTxWitsEmptyField @era version 6 $
115-
DecoderErrorDeserialiseFailure
116-
(Binary.label $ Proxy @(Annotator (TxWits era)))
117-
(DeserialiseFailure 7 "Empty list of scripts is not allowed")
118-
it "plutusV3Script" . expectFailureOnTxWitsEmptyField @era version 7 $
119-
DecoderErrorDeserialiseFailure
120-
(Binary.label $ Proxy @(Annotator (TxWits era)))
121-
(DeserialiseFailure 7 "Empty list of scripts is not allowed")
122-
prop "other fields" $ \(Small idx) ->
123-
idx `notElem` [0 .. 7] ==> expectFailureOnTxWitsEmptyField @era version idx $
124-
DecoderErrorDeserialiseFailure
125-
(Binary.label $ Proxy @(Annotator (TxWits era)))
126-
( DeserialiseFailure 2 $
127-
"An error occurred while decoding (Int,Void) not a valid key:.\nError: " <> show idx
128-
)
87+
it "addrTxWits" . expectFailureOnTxWitsEmptyFieldWithTag @era version 0 $
88+
decoderFailure 7 "Empty list found, expected non-empty"
89+
it "nativeScripts" . expectFailureOnTxWitsEmptyFieldWithTag @era version 1 $
90+
decoderFailure 7 "Empty list found, expected non-empty"
91+
it "bootstrapWitness" . expectFailureOnTxWitsEmptyFieldWithTag @era version 2 $
92+
decoderFailure 7 "Empty list found, expected non-empty"
93+
it "plutusV1Script" . expectFailureOnTxWitsEmptyFieldWithTag @era version 3 $
94+
decoderFailure 7 "Empty list of scripts is not allowed"
95+
it "plutusData" . expectFailureOnTxWitsEmptyFieldWithTag @era version 4 $
96+
decoderFailure 7 "Empty list found, expected non-empty"
97+
it "plutusV2Script" . expectFailureOnTxWitsEmptyFieldWithTag @era version 6 $
98+
decoderFailure 7 "Empty list of scripts is not allowed"
99+
it "plutusV3Script" . expectFailureOnTxWitsEmptyFieldWithTag @era version 7 $
100+
decoderFailure 7 "Empty list of scripts is not allowed"
101+
txWitsDecodingFailsOnInvalidField @era version [0 .. 7]
129102

130103
witsDuplicateVKeyWits :: Enc
131104
witsDuplicateVKeyWits =

‎libs/cardano-ledger-binary/testlib/Test/Cardano/Ledger/Binary/Golden.hs‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -69,7 +69,7 @@ expectDecoderFailureAnn ::
6969
Expectation
7070
expectDecoderFailureAnn version enc expectedErr =
7171
case decodeEnc @a version enc of
72-
Left err -> expectedErr `shouldBe` err
72+
Left err -> err `shouldBe` expectedErr
7373
Right x ->
7474
expectationFailure $
7575
"Expected a failure, but decoder succeeded:\n" <> show (toExpr x)

‎libs/cardano-ledger-core/testlib/Test/Cardano/Ledger/Core/Binary/Golden.hs‎

Lines changed: 1 addition & 17 deletions
Original file line numberDiff line numberDiff line change
@@ -23,14 +23,13 @@ import Cardano.Ledger.Binary (
2323
import qualified Cardano.Ledger.Binary as Binary
2424
import Data.Typeable (Proxy (..))
2525
import GHC.Stack (HasCallStack)
26+
import Test.Cardano.Ledger.Binary.Golden (expectDecoderFailureAnn)
2627
import Test.Cardano.Ledger.Binary.Plain.Golden (Enc)
2728
import Test.Cardano.Ledger.Binary.RoundTrip (embedTripAnnExpectation)
2829
import Test.Cardano.Ledger.Common (
2930
Expectation,
3031
diffExprString,
3132
expectationFailure,
32-
shouldBe,
33-
showExpr,
3433
)
3534
import Test.Cardano.Ledger.TreeDiff (ToExpr, expectExprEqualWithMessage)
3635

@@ -57,21 +56,6 @@ expectDecoderSuccessAnn ::
5756
(ToExpr a, DecCBOR (Annotator a), Eq a, HasCallStack) => Version -> Enc -> a -> Expectation
5857
expectDecoderSuccessAnn = expectDecoderSuccessAnnWith (==)
5958

60-
expectDecoderFailureAnn ::
61-
forall a.
62-
(ToExpr a, DecCBOR (Annotator a), HasCallStack) =>
63-
Version ->
64-
Enc ->
65-
DecoderError ->
66-
Expectation
67-
expectDecoderFailureAnn version enc expectedErr =
68-
case decodeEnc @a version enc of
69-
Left err -> expectedErr `shouldBe` err
70-
Right x ->
71-
expectationFailure $
72-
"Expected a failure, but decoder succeeded:\n"
73-
<> showExpr x
74-
7559
expectDecoderResultOn ::
7660
forall a b.
7761
(ToExpr b, DecCBOR (Annotator a), Eq b, HasCallStack) =>

0 commit comments

Comments
 (0)