Initial work

IntersectMBO · Jan 31, 2025 · 167227d · 167227d
1 parent 72a3ec0
commit 167227d
Showing 1 changed file with 37 additions and 9 deletions.
diff --git a/cardano-api/internal/Cardano/Api/Tx/Body.hs b/cardano-api/internal/Cardano/Api/Tx/Body.hs
@@ -145,10 +145,10 @@ module Cardano.Api.Tx.Body
   , TxVotingProcedures (..)
   , mkTxVotingProcedures
   , indexTxVotingProcedures
-  , TxProposalProcedures (..)
+  , TxProposalProcedures (TxProposalProceduresNone)
+  , pattern TxProposalProcedures
   , mkTxProposalProcedures
   , indexTxProposalProcedures
-  , convProposalProcedures
 
     -- ** Building vs viewing transactions
   , BuildTxWith (..)
@@ -1471,7 +1471,7 @@ data TxProposalProcedures build era where
   TxProposalProceduresNone :: TxProposalProcedures build era
   -- | Create Tx proposal procedures. Prefer 'mkTxProposalProcedures' smart constructor to using this constructor
   -- directly.
-  TxProposalProcedures
+  UnsafeTxProposalProcedures
     :: Ledger.EraPParams (ShelleyLedgerEra era)
     => OSet (L.ProposalProcedure (ShelleyLedgerEra era))
     -- ^ a set of proposals
@@ -1484,6 +1484,35 @@ deriving instance Eq (TxProposalProcedures build era)
 
 deriving instance Show (TxProposalProcedures build era)
 
+x''' :: TxProposalProcedures BuildTx era -> ()
+x''' = \case
+  TxProposalProceduresNone -> ()
+  TxProposalProcedures _ _ -> ()
+
+{-# COMPLETE TxProposalProceduresNone, TxProposalProcedures #-}
+
+pattern TxProposalProcedures
+  :: Applicative (BuildTxWith build)
+  => OSet (L.ProposalProcedure (ShelleyLedgerEra era))
+  -> BuildTxWith build (Map (L.ProposalProcedure (ShelleyLedgerEra era)) (ScriptWitness WitCtxStake era))
+  -> TxProposalProcedures build era
+pattern TxProposalProcedures oset wits <- (unTxProposalProcedures -> (oset, wits))
+
+unTxProposalProcedures
+  :: Applicative (BuildTxWith build)
+  => TxProposalProcedures build era
+  -> ( OSet (L.ProposalProcedure (ShelleyLedgerEra era))
+     , BuildTxWith
+        build
+        (Map (L.ProposalProcedure (ShelleyLedgerEra era)) (ScriptWitness WitCtxStake era))
+     )
+unTxProposalProcedures pp =
+  ( convProposalProcedures pp
+  , case pp of
+      TxProposalProceduresNone -> pure Map.empty
+      UnsafeTxProposalProcedures _ wits -> wits
+  )
+
 -- | A smart constructor for 'TxProposalProcedures'. It makes sure that the value produced is consistent - the
 -- witnessed proposals are also present in the first constructor parameter.
 mkTxProposalProcedures
@@ -1497,7 +1526,7 @@ mkTxProposalProcedures proposalsWithWitnessesList = do
         bimap toList toList $
           Foldable.foldl' partitionProposals mempty proposalsWithWitnessesList
   shelleyBasedEraConstraints (shelleyBasedEra @era) $
-    TxProposalProcedures (fromList proposals) (pure $ fromList proposalsWithWitnesses)
+    UnsafeTxProposalProcedures (fromList proposals) (pure $ fromList proposalsWithWitnesses)
  where
   partitionProposals (ps, pws) (p, Nothing) =
     (DList.snoc ps p, pws) -- add a proposal to the list
@@ -1509,7 +1538,7 @@ indexTxProposalProcedures
   :: TxProposalProcedures BuildTx era
   -> [(ScriptWitnessIndex, L.ProposalProcedure (ShelleyLedgerEra era), ScriptWitness WitCtxStake era)]
 indexTxProposalProcedures TxProposalProceduresNone = []
-indexTxProposalProcedures txpp@(TxProposalProcedures _ (BuildTxWith witnesses)) = do
+indexTxProposalProcedures txpp@(UnsafeTxProposalProcedures _ (BuildTxWith witnesses)) = do
   let allProposalsList = toList $ convProposalProcedures txpp
   [ (ScriptWitnessIndexProposing $ fromIntegral ix, proposal, scriptWitness)
     | (proposal, scriptWitness) <- toList witnesses
@@ -2227,9 +2256,8 @@ fromLedgerProposalProcedures sbe body =
   forShelleyBasedEraInEonMaybe sbe $ \w ->
     conwayEraOnwardsConstraints w $
       Featured w $
-        TxProposalProcedures
-          (body ^. L.proposalProceduresTxBodyL)
-          ViewTx
+        mkTxProposalProcedures
+          (fmap (,Nothing) . toList $ body ^. L.proposalProceduresTxBodyL)
 
 fromLedgerVotingProcedures
   :: ()
@@ -2825,7 +2853,7 @@ convReferenceInputs txInsReference =
 convProposalProcedures
   :: TxProposalProcedures build era -> OSet (L.ProposalProcedure (ShelleyLedgerEra era))
 convProposalProcedures TxProposalProceduresNone = OSet.empty
-convProposalProcedures (TxProposalProcedures pp bWits) = do
+convProposalProcedures (UnsafeTxProposalProcedures pp bWits) = do
   let wits = fromMaybe mempty $ buildTxWithToMaybe bWits
   pp |>< fromList (Map.keys wits)