Skip to content

Commit 26db89d

Browse files
lehinslehins
authored
Merge pull request #4997 from IntersectMBO/nm/4976-internal-modules
Move `TxBody` `Internal` modules to public ones
2 parents 4962396 + 54da61f commit 26db89d

File tree

20 files changed

+2633
-2870
lines changed

20 files changed

+2633
-2870
lines changed

‎eras/allegra/impl/cardano-ledger-allegra.cabal

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -31,7 +31,6 @@ library
3131
Cardano.Ledger.Allegra.Tx
3232
Cardano.Ledger.Allegra.TxAuxData
3333
Cardano.Ledger.Allegra.TxBody
34-
Cardano.Ledger.Allegra.TxBody.Internal
3534

3635
hs-source-dirs: src
3736
other-modules:

‎eras/allegra/impl/src/Cardano/Ledger/Allegra/TxBody.hs

Lines changed: 349 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,22 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE DeriveAnyClass #-}
3+
{-# LANGUAGE DeriveGeneric #-}
4+
{-# LANGUAGE DerivingVia #-}
5+
{-# LANGUAGE FlexibleContexts #-}
6+
{-# LANGUAGE FlexibleInstances #-}
7+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8+
{-# LANGUAGE MultiParamTypeClasses #-}
9+
{-# LANGUAGE OverloadedStrings #-}
10+
{-# LANGUAGE PatternSynonyms #-}
11+
{-# LANGUAGE ScopedTypeVariables #-}
12+
{-# LANGUAGE StandaloneDeriving #-}
13+
{-# LANGUAGE TypeApplications #-}
14+
{-# LANGUAGE TypeFamilies #-}
15+
{-# LANGUAGE UndecidableInstances #-}
16+
{-# LANGUAGE UndecidableSuperClasses #-}
17+
{-# LANGUAGE ViewPatterns #-}
18+
{-# OPTIONS_GHC -Wno-orphans #-}
19+
120
module Cardano.Ledger.Allegra.TxBody (
221
AllegraEraTxBody (..),
322
AllegraTxBody (
@@ -19,4 +38,333 @@ module Cardano.Ledger.Allegra.TxBody (
1938
)
2039
where
2140

22-
import Cardano.Ledger.Allegra.TxBody.Internal
41+
import Cardano.Ledger.Allegra.Era (AllegraEra)
42+
import Cardano.Ledger.Allegra.Scripts (ValidityInterval (..))
43+
import Cardano.Ledger.Allegra.TxCert ()
44+
import Cardano.Ledger.Allegra.TxOut ()
45+
import Cardano.Ledger.BaseTypes (SlotNo, StrictMaybe (SJust, SNothing))
46+
import Cardano.Ledger.Binary (DecCBOR (..), EncCBOR (..), ToCBOR)
47+
import Cardano.Ledger.Binary.Coders (
48+
Decode (..),
49+
Encode (..),
50+
Field,
51+
decode,
52+
encode,
53+
encodeKeyedStrictMaybe,
54+
field,
55+
invalidField,
56+
ofield,
57+
(!>),
58+
)
59+
import Cardano.Ledger.Coin (Coin (..))
60+
import Cardano.Ledger.Compactible (Compactible (..))
61+
import Cardano.Ledger.Core
62+
import Cardano.Ledger.MemoBytes (
63+
EqRaw,
64+
MemoBytes,
65+
MemoHashIndex,
66+
Memoized (RawType),
67+
getMemoRawType,
68+
getMemoSafeHash,
69+
lensMemoRawType,
70+
mkMemoizedEra,
71+
)
72+
import Cardano.Ledger.Shelley.Core
73+
import Cardano.Ledger.Shelley.PParams (Update (..), upgradeUpdate)
74+
import Cardano.Ledger.Shelley.TxBody (getShelleyGenesisKeyHashCountTxBody)
75+
import Cardano.Ledger.TxIn (TxIn (..))
76+
import Control.DeepSeq (NFData (..))
77+
import qualified Data.Map.Strict as Map
78+
import Data.Sequence.Strict (StrictSeq, fromList)
79+
import Data.Set (Set, empty)
80+
import GHC.Generics (Generic)
81+
import Lens.Micro
82+
import NoThunks.Class (NoThunks (..))
83+
84+
class EraTxBody era => AllegraEraTxBody era where
85+
vldtTxBodyL :: Lens' (TxBody era) ValidityInterval
86+
87+
-- =======================================================
88+
89+
data AllegraTxBodyRaw ma era = AllegraTxBodyRaw
90+
{ atbrInputs :: !(Set TxIn)
91+
, atbrOutputs :: !(StrictSeq (TxOut era))
92+
, atbrCerts :: !(StrictSeq (TxCert era))
93+
, atbrWithdrawals :: !Withdrawals
94+
, atbrFee :: !Coin
95+
, atbrValidityInterval :: !ValidityInterval
96+
, atbrUpdate :: !(StrictMaybe (Update era))
97+
, atbrAuxDataHash :: !(StrictMaybe TxAuxDataHash)
98+
, atbrMint :: !ma
99+
}
100+
101+
deriving instance
102+
(Era era, NFData (TxOut era), NFData (TxCert era), NFData (PParamsUpdate era), NFData ma) =>
103+
NFData (AllegraTxBodyRaw ma era)
104+
105+
deriving instance
106+
(Era era, Eq (PParamsUpdate era), Eq (TxOut era), Eq (TxCert era), Eq ma) =>
107+
Eq (AllegraTxBodyRaw ma era)
108+
109+
deriving instance
110+
(Era era, Show (TxOut era), Show (TxCert era), Show (PParamsUpdate era), Show ma) =>
111+
Show (AllegraTxBodyRaw ma era)
112+
113+
deriving instance Generic (AllegraTxBodyRaw ma era)
114+
115+
deriving instance
116+
(Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era), NoThunks ma) =>
117+
NoThunks (AllegraTxBodyRaw ma era)
118+
119+
instance (DecCBOR ma, Monoid ma, AllegraEraTxBody era) => DecCBOR (AllegraTxBodyRaw ma era) where
120+
decCBOR =
121+
decode
122+
( SparseKeyed
123+
"AllegraTxBodyRaw"
124+
emptyAllegraTxBodyRaw
125+
bodyFields
126+
[(0, "atbrInputs"), (1, "atbrOutputs"), (2, "atbrFee")]
127+
)
128+
129+
-- Sparse encodings of AllegraTxBodyRaw, the key values are fixed by backward compatibility
130+
-- concerns as we want the ShelleyTxBody to deserialise as AllegraTxBody.
131+
-- txXparse and bodyFields should be Duals, visual inspection helps ensure this.
132+
instance
133+
(EraTxOut era, EraTxCert era, Eq ma, EncCBOR ma, Monoid ma) =>
134+
EncCBOR (AllegraTxBodyRaw ma era)
135+
where
136+
encCBOR (AllegraTxBodyRaw inp out cert wdrl fee (ValidityInterval bot top) up hash frge) =
137+
encode $
138+
Keyed
139+
( \i o f topx c w u h botx forg ->
140+
AllegraTxBodyRaw i o c w f (ValidityInterval botx topx) u h forg
141+
)
142+
!> Key 0 (To inp) -- We don't have to send these in TxBodyX order
143+
!> Key 1 (To out) -- Just hack up a fake constructor with the lambda.
144+
!> Key 2 (To fee)
145+
!> encodeKeyedStrictMaybe 3 top
146+
!> Omit null (Key 4 (To cert))
147+
!> Omit (null . unWithdrawals) (Key 5 (To wdrl))
148+
!> encodeKeyedStrictMaybe 6 up
149+
!> encodeKeyedStrictMaybe 7 hash
150+
!> encodeKeyedStrictMaybe 8 bot
151+
!> Omit (== mempty) (Key 9 (To frge))
152+
153+
bodyFields :: (DecCBOR ma, EraTxOut era, EraTxCert era) => Word -> Field (AllegraTxBodyRaw ma era)
154+
bodyFields 0 = field (\x tx -> tx {atbrInputs = x}) From
155+
bodyFields 1 = field (\x tx -> tx {atbrOutputs = x}) From
156+
bodyFields 2 = field (\x tx -> tx {atbrFee = x}) From
157+
bodyFields 3 =
158+
ofield
159+
( \x tx ->
160+
tx
161+
{ atbrValidityInterval =
162+
(atbrValidityInterval tx) {invalidHereafter = x}
163+
}
164+
)
165+
From
166+
bodyFields 4 = field (\x tx -> tx {atbrCerts = x}) From
167+
bodyFields 5 = field (\x tx -> tx {atbrWithdrawals = x}) From
168+
bodyFields 6 = ofield (\x tx -> tx {atbrUpdate = x}) From
169+
bodyFields 7 = ofield (\x tx -> tx {atbrAuxDataHash = x}) From
170+
bodyFields 8 =
171+
ofield
172+
( \x tx ->
173+
tx
174+
{ atbrValidityInterval =
175+
(atbrValidityInterval tx) {invalidBefore = x}
176+
}
177+
)
178+
From
179+
bodyFields 9 = field (\x tx -> tx {atbrMint = x}) From
180+
bodyFields n = invalidField n
181+
182+
emptyAllegraTxBodyRaw :: Monoid ma => AllegraTxBodyRaw ma era
183+
emptyAllegraTxBodyRaw =
184+
AllegraTxBodyRaw
185+
empty
186+
(fromList [])
187+
(fromList [])
188+
(Withdrawals Map.empty)
189+
(Coin 0)
190+
(ValidityInterval SNothing SNothing)
191+
SNothing
192+
SNothing
193+
mempty
194+
195+
-- ===========================================================================
196+
-- Wrap it all up in a newtype, hiding the insides with a pattern construtor.
197+
198+
newtype AllegraTxBody e = MkAllegraTxBody (MemoBytes (AllegraTxBodyRaw () e))
199+
deriving newtype (SafeToHash, ToCBOR, DecCBOR)
200+
201+
instance Memoized (AllegraTxBody era) where
202+
type RawType (AllegraTxBody era) = AllegraTxBodyRaw () era
203+
204+
deriving instance
205+
(Era era, Eq (PParamsUpdate era), Eq (TxOut era), Eq (TxCert era)) =>
206+
Eq (AllegraTxBody era)
207+
208+
deriving instance
209+
(Era era, Show (TxOut era), Show (TxCert era), Compactible (Value era), Show (PParamsUpdate era)) =>
210+
Show (AllegraTxBody era)
211+
212+
deriving instance Generic (AllegraTxBody era)
213+
214+
deriving newtype instance
215+
(Era era, NoThunks (TxOut era), NoThunks (TxCert era), NoThunks (PParamsUpdate era)) =>
216+
NoThunks (AllegraTxBody era)
217+
218+
deriving newtype instance
219+
( NFData (TxOut era)
220+
, NFData (TxCert era)
221+
, NFData (PParamsUpdate era)
222+
, Era era
223+
) =>
224+
NFData (AllegraTxBody era)
225+
226+
-- | Encodes memoized bytes created upon construction.
227+
instance Era era => EncCBOR (AllegraTxBody era)
228+
229+
type instance MemoHashIndex (AllegraTxBodyRaw c era) = EraIndependentTxBody
230+
231+
instance Era era => HashAnnotated (AllegraTxBody era) EraIndependentTxBody where
232+
hashAnnotated = getMemoSafeHash
233+
234+
-- | A pattern to keep the newtype and the MemoBytes hidden
235+
pattern AllegraTxBody ::
236+
forall era.
237+
(EraTxOut era, EraTxCert era) =>
238+
Set TxIn ->
239+
StrictSeq (TxOut era) ->
240+
StrictSeq (TxCert era) ->
241+
Withdrawals ->
242+
Coin ->
243+
ValidityInterval ->
244+
StrictMaybe (Update era) ->
245+
StrictMaybe TxAuxDataHash ->
246+
AllegraTxBody era
247+
pattern AllegraTxBody
248+
{ atbInputs
249+
, atbOutputs
250+
, atbCerts
251+
, atbWithdrawals
252+
, atbTxFee
253+
, atbValidityInterval
254+
, atbUpdate
255+
, atbAuxDataHash
256+
} <-
257+
( getMemoRawType ->
258+
AllegraTxBodyRaw
259+
{ atbrInputs = atbInputs
260+
, atbrOutputs = atbOutputs
261+
, atbrCerts = atbCerts
262+
, atbrWithdrawals = atbWithdrawals
263+
, atbrFee = atbTxFee
264+
, atbrValidityInterval = atbValidityInterval
265+
, atbrUpdate = atbUpdate
266+
, atbrAuxDataHash = atbAuxDataHash
267+
}
268+
)
269+
where
270+
AllegraTxBody
271+
inputs
272+
outputs
273+
certs
274+
withdrawals
275+
txFee
276+
validityInterval
277+
update
278+
auxDataHash =
279+
mkMemoizedEra @era $
280+
AllegraTxBodyRaw
281+
{ atbrInputs = inputs
282+
, atbrOutputs = outputs
283+
, atbrCerts = certs
284+
, atbrWithdrawals = withdrawals
285+
, atbrFee = txFee
286+
, atbrValidityInterval = validityInterval
287+
, atbrUpdate = update
288+
, atbrAuxDataHash = auxDataHash
289+
, atbrMint = ()
290+
}
291+
292+
{-# COMPLETE AllegraTxBody #-}
293+
294+
instance EraTxBody AllegraEra where
295+
type TxBody AllegraEra = AllegraTxBody AllegraEra
296+
297+
mkBasicTxBody = mkMemoizedEra @AllegraEra emptyAllegraTxBodyRaw
298+
299+
inputsTxBodyL =
300+
lensMemoRawType @AllegraEra atbrInputs $
301+
\txBodyRaw inputs -> txBodyRaw {atbrInputs = inputs}
302+
{-# INLINEABLE inputsTxBodyL #-}
303+
304+
outputsTxBodyL =
305+
lensMemoRawType @AllegraEra atbrOutputs $
306+
\txBodyRaw outputs -> txBodyRaw {atbrOutputs = outputs}
307+
{-# INLINEABLE outputsTxBodyL #-}
308+
309+
feeTxBodyL =
310+
lensMemoRawType @AllegraEra atbrFee $ \txBodyRaw fee -> txBodyRaw {atbrFee = fee}
311+
{-# INLINEABLE feeTxBodyL #-}
312+
313+
auxDataHashTxBodyL =
314+
lensMemoRawType @AllegraEra atbrAuxDataHash $
315+
\txBodyRaw auxDataHash -> txBodyRaw {atbrAuxDataHash = auxDataHash}
316+
{-# INLINEABLE auxDataHashTxBodyL #-}
317+
318+
spendableInputsTxBodyF = inputsTxBodyL
319+
{-# INLINE spendableInputsTxBodyF #-}
320+
321+
allInputsTxBodyF = inputsTxBodyL
322+
{-# INLINEABLE allInputsTxBodyF #-}
323+
324+
withdrawalsTxBodyL =
325+
lensMemoRawType @AllegraEra atbrWithdrawals $
326+
\txBodyRaw withdrawals -> txBodyRaw {atbrWithdrawals = withdrawals}
327+
{-# INLINEABLE withdrawalsTxBodyL #-}
328+
329+
certsTxBodyL =
330+
lensMemoRawType @AllegraEra atbrCerts $
331+
\txBodyRaw certs -> txBodyRaw {atbrCerts = certs}
332+
{-# INLINEABLE certsTxBodyL #-}
333+
334+
getGenesisKeyHashCountTxBody = getShelleyGenesisKeyHashCountTxBody
335+
336+
upgradeTxBody txBody = do
337+
certs <- traverse upgradeTxCert (txBody ^. certsTxBodyL)
338+
pure $
339+
AllegraTxBody
340+
{ atbInputs = txBody ^. inputsTxBodyL
341+
, atbOutputs = upgradeTxOut <$> (txBody ^. outputsTxBodyL)
342+
, atbCerts = certs
343+
, atbWithdrawals = txBody ^. withdrawalsTxBodyL
344+
, atbTxFee = txBody ^. feeTxBodyL
345+
, atbValidityInterval = ttlToValidityInterval (txBody ^. ttlTxBodyL)
346+
, atbUpdate = upgradeUpdate () <$> (txBody ^. updateTxBodyL)
347+
, atbAuxDataHash = txBody ^. auxDataHashTxBodyL
348+
}
349+
where
350+
ttlToValidityInterval :: SlotNo -> ValidityInterval
351+
ttlToValidityInterval ttl = ValidityInterval SNothing (SJust ttl)
352+
353+
instance ShelleyEraTxBody AllegraEra where
354+
ttlTxBodyL = notSupportedInThisEraL
355+
{-# INLINEABLE ttlTxBodyL #-}
356+
357+
updateTxBodyL =
358+
lensMemoRawType @AllegraEra atbrUpdate $
359+
\txBodyRaw update -> txBodyRaw {atbrUpdate = update}
360+
{-# INLINEABLE updateTxBodyL #-}
361+
362+
instance AllegraEraTxBody AllegraEra where
363+
vldtTxBodyL =
364+
lensMemoRawType @AllegraEra atbrValidityInterval $
365+
\txBodyRaw vldt -> txBodyRaw {atbrValidityInterval = vldt}
366+
{-# INLINEABLE vldtTxBodyL #-}
367+
368+
instance
369+
(Era era, Eq (PParamsUpdate era), Eq (TxOut era), Eq (TxCert era)) =>
370+
EqRaw (AllegraTxBody era)

0 commit comments

Comments
 (0)