Some experiment

cardano-api/cardano-api.cabal

@@ -213,6 +213,7 @@ library internal
     scientific,
     serialise,
     small-steps ^>=1.1,
+    some,
     sop-core,
     stm,
     strict-sop-core,

cardano-api/internal/Cardano/Api/Eon/ShelleyBasedEra.hs

@@ -14,7 +14,6 @@ module Cardano.Api.Eon.ShelleyBasedEra
   ( -- * Shelley-based eras
     ShelleyBasedEra(..)
   , IsShelleyBasedEra(..)
-  , AnyShelleyBasedEra(..)
   , InAnyShelleyBasedEra(..)
   , inAnyShelleyBasedEra
   , inEonForShelleyBasedEra
@@ -56,8 +55,7 @@ import           Ouroboros.Consensus.Shelley.Eras as Consensus (StandardAllegra,
 import qualified Ouroboros.Consensus.Shelley.Ledger as Consensus
 
 import           Control.DeepSeq
-import           Data.Aeson (FromJSON (..), ToJSON, toJSON, withText)
-import qualified Data.Text as Text
+import           Data.Aeson (ToJSON, toJSON)
 import           Data.Type.Equality (TestEquality (..), (:~:) (Refl))
 import           Data.Typeable (Typeable)
 import           Text.Pretty (Pretty (..))
@@ -232,60 +230,54 @@ shelleyBasedEraConstraints = \case
   ShelleyBasedEraBabbage -> id
   ShelleyBasedEraConway  -> id
 
-data AnyShelleyBasedEra where
-  AnyShelleyBasedEra
-    :: Typeable era
-    => ShelleyBasedEra era
-    -> AnyShelleyBasedEra
-
-deriving instance Show AnyShelleyBasedEra
-
-instance Eq AnyShelleyBasedEra where
-    AnyShelleyBasedEra sbe == AnyShelleyBasedEra sbe' =
-      case testEquality sbe sbe' of
-        Nothing   -> False
-        Just Refl -> True -- since no constructors share types
-
-instance Bounded AnyShelleyBasedEra where
-   minBound = AnyShelleyBasedEra ShelleyBasedEraShelley
-   maxBound = AnyShelleyBasedEra ShelleyBasedEraConway
-
-instance Enum AnyShelleyBasedEra where
-   enumFrom e = enumFromTo e maxBound
-
-   fromEnum = \case
-      AnyShelleyBasedEra ShelleyBasedEraShelley  -> 1
-      AnyShelleyBasedEra ShelleyBasedEraAllegra  -> 2
-      AnyShelleyBasedEra ShelleyBasedEraMary     -> 3
-      AnyShelleyBasedEra ShelleyBasedEraAlonzo   -> 4
-      AnyShelleyBasedEra ShelleyBasedEraBabbage  -> 5
-      AnyShelleyBasedEra ShelleyBasedEraConway   -> 6
-
-   toEnum = \case
-      1 -> AnyShelleyBasedEra ShelleyBasedEraShelley
-      2 -> AnyShelleyBasedEra ShelleyBasedEraAllegra
-      3 -> AnyShelleyBasedEra ShelleyBasedEraMary
-      4 -> AnyShelleyBasedEra ShelleyBasedEraAlonzo
-      5 -> AnyShelleyBasedEra ShelleyBasedEraBabbage
-      6 -> AnyShelleyBasedEra ShelleyBasedEraConway
-      n ->
-         error $
-            "AnyShelleyBasedEra.toEnum: " <> show n
-            <> " does not correspond to any known enumerated era."
-
-instance ToJSON AnyShelleyBasedEra where
-   toJSON (AnyShelleyBasedEra sbe) = toJSON sbe
-
-instance FromJSON AnyShelleyBasedEra where
-   parseJSON = withText "AnyShelleyBasedEra"
-     $ \case
-        "Shelley" -> pure $ AnyShelleyBasedEra ShelleyBasedEraShelley
-        "Allegra" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAllegra
-        "Mary" -> pure $ AnyShelleyBasedEra ShelleyBasedEraMary
-        "Alonzo" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAlonzo
-        "Babbage" -> pure $ AnyShelleyBasedEra ShelleyBasedEraBabbage
-        "Conway" -> pure $ AnyShelleyBasedEra ShelleyBasedEraConway
-        wrong -> fail $ "Failed to parse unknown shelley-based era: " <> Text.unpack wrong
+-- deriving instance Show AnyShelleyBasedEra
+
+-- instance Eq AnyShelleyBasedEra where
+--     AnyShelleyBasedEra sbe == AnyShelleyBasedEra sbe' =
+--       case testEquality sbe sbe' of
+--         Nothing   -> False
+--         Just Refl -> True -- since no constructors share types
+
+-- instance Bounded AnyShelleyBasedEra where
+--    minBound = AnyShelleyBasedEra ShelleyBasedEraShelley
+--    maxBound = AnyShelleyBasedEra ShelleyBasedEraConway
+
+-- instance Enum AnyShelleyBasedEra where
+--    enumFrom e = enumFromTo e maxBound
+
+--    fromEnum = \case
+--       AnyShelleyBasedEra ShelleyBasedEraShelley  -> 1
+--       AnyShelleyBasedEra ShelleyBasedEraAllegra  -> 2
+--       AnyShelleyBasedEra ShelleyBasedEraMary     -> 3
+--       AnyShelleyBasedEra ShelleyBasedEraAlonzo   -> 4
+--       AnyShelleyBasedEra ShelleyBasedEraBabbage  -> 5
+--       AnyShelleyBasedEra ShelleyBasedEraConway   -> 6
+
+--    toEnum = \case
+--       1 -> AnyShelleyBasedEra ShelleyBasedEraShelley
+--       2 -> AnyShelleyBasedEra ShelleyBasedEraAllegra
+--       3 -> AnyShelleyBasedEra ShelleyBasedEraMary
+--       4 -> AnyShelleyBasedEra ShelleyBasedEraAlonzo
+--       5 -> AnyShelleyBasedEra ShelleyBasedEraBabbage
+--       6 -> AnyShelleyBasedEra ShelleyBasedEraConway
+--       n ->
+--          error $
+--             "AnyShelleyBasedEra.toEnum: " <> show n
+--             <> " does not correspond to any known enumerated era."
+
+-- instance ToJSON AnyShelleyBasedEra where
+--    toJSON (AnyShelleyBasedEra sbe) = toJSON sbe
+
+-- instance FromJSON AnyShelleyBasedEra where
+--    parseJSON = withText "AnyShelleyBasedEra"
+--      $ \case
+--         "Shelley" -> pure $ AnyShelleyBasedEra ShelleyBasedEraShelley
+--         "Allegra" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAllegra
+--         "Mary" -> pure $ AnyShelleyBasedEra ShelleyBasedEraMary
+--         "Alonzo" -> pure $ AnyShelleyBasedEra ShelleyBasedEraAlonzo
+--         "Babbage" -> pure $ AnyShelleyBasedEra ShelleyBasedEraBabbage
+--         "Conway" -> pure $ AnyShelleyBasedEra ShelleyBasedEraConway
+--         wrong -> fail $ "Failed to parse unknown shelley-based era: " <> Text.unpack wrong
 
 -- | This pairs up some era-dependent type with a 'ShelleyBasedEra' value that
 -- tells us what era it is, but hides the era type. This is useful when the era

cardano-api/internal/Cardano/Api/Governance/Actions/VotingProcedure.hs

@@ -31,7 +31,9 @@ import           Cardano.Ledger.Core (EraCrypto)
 import qualified Cardano.Ledger.Core as L
 
 import           Control.Monad (foldM)
+import           Data.Map (Map)
 import qualified Data.Map as Map
+import           Data.Set (Set)
 import qualified Data.Set as Set
 import           Data.Text (Text)
 import qualified Data.Text.Encoding as Text
@@ -156,6 +158,39 @@ singletonVotingProcedures _ voter govActionId votingProcedure =
     $ Map.singleton voter
     $ Map.singleton govActionId votingProcedure
 
+-- | Lax voting procedures that do not enforce any constraints on the voting procedures.
+-- In particular this allows for conflicting voting procedures to be merged.
+newtype LaxVotingProcedures era = LaxVotingProcedures
+  { unGovActionIdsByVoter ::
+      Map
+        (L.Voter (EraCrypto (ShelleyLedgerEra era)))
+        (Map
+          (L.GovActionId (EraCrypto (ShelleyLedgerEra era)))
+          (Set (L.VotingProcedure (ShelleyLedgerEra era))))
+  }
+
+instance Semigroup (LaxVotingProcedures era) where
+  LaxVotingProcedures a <> LaxVotingProcedures b =
+    LaxVotingProcedures $ Map.unionWith (Map.unionWith Set.union) a b
+
+instance Monoid (LaxVotingProcedures era) where
+  mempty = LaxVotingProcedures Map.empty
+
+votingProceduresToLax :: ConwayEraOnwards era -> VotingProcedures era -> LaxVotingProcedures era
+votingProceduresToLax eon (VotingProcedures vp) =
+  conwayEraOnwardsConstraints eon
+    $ LaxVotingProcedures
+    $ Map.map (Map.map Set.singleton)
+    $ L.unVotingProcedures vp
+
+votingProceduresFromLax :: LaxVotingProcedures era -> (LaxVotingProcedures era, VotingProcedures era)
+votingProceduresFromLax (LaxVotingProcedures vp) =
+  let
+    votingProcedures = VotingProcedures
+      $ L.VotingProcedures
+      $ Map.map (Map.map Set.findMin) vp
+  in (LaxVotingProcedures vp, votingProcedures)
+
 -- | A voter, and the conflicting votes of this voter (i.e. votes with the same governance action identifier)
 newtype VotesMergingConflict era =
   VotesMergingConflict

cardano-api/internal/Cardano/Api/LedgerState.hs

@@ -251,7 +251,7 @@ data LedgerStateError
   -- ^ The ledger state condition you were interested in was not met
   -- prior to the termination epoch.
   | UnexpectedLedgerState
-      AnyShelleyBasedEra
+      (Some ShelleyBasedEra)
       -- ^ Expected era
       (Consensus.CardanoLedgerState Consensus.StandardCrypto)
       -- ^ Ledgerstate from an unexpected era
@@ -1044,7 +1044,7 @@ getNewEpochState
   -> Consensus.CardanoLedgerState Consensus.StandardCrypto
   -> Either LedgerStateError (ShelleyAPI.NewEpochState (ShelleyLedgerEra era))
 getNewEpochState era x = do
-  let err = UnexpectedLedgerState (shelleyBasedEraConstraints era $ AnyShelleyBasedEra era) x
+  let err = UnexpectedLedgerState (shelleyBasedEraConstraints era $ Some era) x
   case era of
     ShelleyBasedEraShelley ->
       case x of

cardano-api/internal/Cardano/Api/Orphans.hs

@@ -93,6 +93,8 @@ import           GHC.Stack (HasCallStack)
 import           GHC.TypeLits
 import           Lens.Micro
 
+deriving instance Ord (L.VotingProcedure era)
+
 deriving instance Generic (L.ApplyTxError era)
 deriving instance Generic (L.Registration.TooLarge a)
 deriving instance Generic L.ApplicationNameError

cardano-api/internal/Cardano/Api/SerialiseLedgerCddl.hs

@@ -61,6 +61,7 @@ import qualified Data.ByteString.Lazy as LBS
 import           Data.Data (Data)
 import           Data.Either.Combinators (mapLeft)
 import qualified Data.List as List
+import           Data.Some
 import           Data.Text (Text)
 import qualified Data.Text as T
 
@@ -264,11 +265,11 @@ deserialiseFromTextEnvelopeCddlAnyOf types teCddl =
         Left (TextEnvelopeCddlTypeError expectedTypes actualType)
 
       Just (FromCDDLTx ttoken f) -> do
-        AnyShelleyBasedEra era <- cddlTypeToEra ttoken
+        Some era <- cddlTypeToEra ttoken
         f . InAnyShelleyBasedEra era <$> mapLeft textEnvelopeErrorToTextEnvelopeCddlError (deserialiseTxLedgerCddl era teCddl)
 
       Just (FromCDDLWitness ttoken f) -> do
-         AnyShelleyBasedEra era <- cddlTypeToEra ttoken
+         Some era <- cddlTypeToEra ttoken
          f . InAnyShelleyBasedEra era <$> deserialiseWitnessLedgerCddl era teCddl
   where
    actualType :: Text
@@ -284,26 +285,26 @@ deserialiseFromTextEnvelopeCddlAnyOf types teCddl =
 -- Parse the text into types because this will increase code readability and
 -- will make it easier to keep track of the different Cddl descriptions via
 -- a single sum data type.
-cddlTypeToEra :: Text -> Either TextEnvelopeCddlError AnyShelleyBasedEra
+cddlTypeToEra :: Text -> Either TextEnvelopeCddlError (Some ShelleyBasedEra)
 cddlTypeToEra = \case
-  "Witnessed Tx ShelleyEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraShelley
-  "Witnessed Tx AllegraEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAllegra
-  "Witnessed Tx MaryEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraMary
-  "Witnessed Tx AlonzoEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAlonzo
-  "Witnessed Tx BabbageEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraBabbage
-  "Witnessed Tx ConwayEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraConway
-  "Unwitnessed Tx ShelleyEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraShelley
-  "Unwitnessed Tx AllegraEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAllegra
-  "Unwitnessed Tx MaryEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraMary
-  "Unwitnessed Tx AlonzoEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAlonzo
-  "Unwitnessed Tx BabbageEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraBabbage
-  "Unwitnessed Tx ConwayEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraConway
-  "TxWitness ShelleyEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraShelley
-  "TxWitness AllegraEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAllegra
-  "TxWitness MaryEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraMary
-  "TxWitness AlonzoEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraAlonzo
-  "TxWitness BabbageEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraBabbage
-  "TxWitness ConwayEra" -> return $ AnyShelleyBasedEra ShelleyBasedEraConway
+  "Witnessed Tx ShelleyEra" -> return $ Some ShelleyBasedEraShelley
+  "Witnessed Tx AllegraEra" -> return $ Some ShelleyBasedEraAllegra
+  "Witnessed Tx MaryEra" -> return $ Some ShelleyBasedEraMary
+  "Witnessed Tx AlonzoEra" -> return $ Some ShelleyBasedEraAlonzo
+  "Witnessed Tx BabbageEra" -> return $ Some ShelleyBasedEraBabbage
+  "Witnessed Tx ConwayEra" -> return $ Some ShelleyBasedEraConway
+  "Unwitnessed Tx ShelleyEra" -> return $ Some ShelleyBasedEraShelley
+  "Unwitnessed Tx AllegraEra" -> return $ Some ShelleyBasedEraAllegra
+  "Unwitnessed Tx MaryEra" -> return $ Some ShelleyBasedEraMary
+  "Unwitnessed Tx AlonzoEra" -> return $ Some ShelleyBasedEraAlonzo
+  "Unwitnessed Tx BabbageEra" -> return $ Some ShelleyBasedEraBabbage
+  "Unwitnessed Tx ConwayEra" -> return $ Some ShelleyBasedEraConway
+  "TxWitness ShelleyEra" -> return $ Some ShelleyBasedEraShelley
+  "TxWitness AllegraEra" -> return $ Some ShelleyBasedEraAllegra
+  "TxWitness MaryEra" -> return $ Some ShelleyBasedEraMary
+  "TxWitness AlonzoEra" -> return $ Some ShelleyBasedEraAlonzo
+  "TxWitness BabbageEra" -> return $ Some ShelleyBasedEraBabbage
+  "TxWitness ConwayEra" -> return $ Some ShelleyBasedEraConway
   unknownCddlType -> Left $ TextEnvelopeCddlErrUnknownType unknownCddlType
 
 readFileTextEnvelopeCddlAnyOf

cardano-api/src/Cardano/Api.hs

@@ -85,7 +85,6 @@ module Cardano.Api (
 
     ShelleyBasedEra(..),
     IsShelleyBasedEra(..),
-    AnyShelleyBasedEra(..),
     InAnyShelleyBasedEra(..),
     inAnyShelleyBasedEra,
     shelleyBasedEraConstraints,

cardano-api/test/cardano-api-test/Test/Cardano/Api/Eras.hs

@@ -21,7 +21,7 @@ import           Test.Tasty.Hedgehog (testProperty)
 prop_maxBound_CardanoMatchesShelley :: Property
 prop_maxBound_CardanoMatchesShelley = property $ do
   AnyCardanoEra era <- forAll $ Gen.element [maxBound]
-  AnyShelleyBasedEra sbe <- forAll $ Gen.element [maxBound]
+  Some sbe <- forAll $ Gen.element [maxBound]
 
   fromEnum (anyCardanoEra era) === fromEnum (anyCardanoEra (toCardanoEra sbe))
 
@@ -30,7 +30,7 @@ prop_maxBound_CardanoMatchesShelley = property $ do
 
 prop_roundtrip_JSON_Shelley :: Property
 prop_roundtrip_JSON_Shelley = property $ do
-  anySbe <- forAll $ Gen.element $ id @[AnyShelleyBasedEra] [minBound..maxBound]
+  anySbe <- forAll $ Gen.element $ id @[Some ShelleyBasedEra] [minBound..maxBound]
 
   H.tripping anySbe encode decode
 
@@ -42,9 +42,9 @@ prop_roundtrip_JSON_Cardano = property $ do
 
 prop_toJSON_CardanoMatchesShelley :: Property
 prop_toJSON_CardanoMatchesShelley = property $ do
-  AnyShelleyBasedEra sbe <- forAll $ Gen.element [minBound..maxBound]
+  Some sbe <- forAll $ Gen.element [minBound..maxBound]
 
-  toJSON (AnyShelleyBasedEra sbe) === toJSON (anyCardanoEra (toCardanoEra sbe))
+  toJSON (Some sbe) === toJSON (anyCardanoEra (toCardanoEra sbe))
 
 tests :: TestTree
 tests = testGroup "Test.Cardano.Api.Json"

cardano-api/test/cardano-api-test/Test/Cardano/Api/Typed/CBOR.hs

@@ -31,19 +31,19 @@ import           Test.Tasty.Hedgehog (testProperty)
 
 prop_roundtrip_txbody_CBOR :: Property
 prop_roundtrip_txbody_CBOR = H.property $ do
-  AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound..maxBound]
+  Some era <- H.forAll $ Gen.element [minBound..maxBound]
   x <- H.forAll $ makeSignedTransaction [] <$> genTxBody era
   H.tripping x (serialiseTxLedgerCddl era) (deserialiseTxLedgerCddl era)
 
 prop_roundtrip_tx_CBOR :: Property
 prop_roundtrip_tx_CBOR = H.property $ do
-  AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound..maxBound]
+  Some era <- H.forAll $ Gen.element [minBound..maxBound]
   x <- H.forAll $ genTx era
   shelleyBasedEraConstraints era $ H.trippingCbor (proxyToAsType Proxy) x
 
 prop_roundtrip_witness_CBOR :: Property
 prop_roundtrip_witness_CBOR = H.property $ do
-  AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound..maxBound]
+  Some era <- H.forAll $ Gen.element [minBound..maxBound]
   x <- H.forAll $ genCardanoKeyWitness era
   shelleyBasedEraConstraints era $ H.trippingCbor (AsKeyWitness (proxyToAsType Proxy)) x
 
@@ -170,13 +170,13 @@ prop_roundtrip_UpdateProposal_CBOR = H.property $ do
 
 prop_roundtrip_Tx_Cddl :: Property
 prop_roundtrip_Tx_Cddl = H.property $ do
-  AnyShelleyBasedEra era <- H.forAll $ Gen.element [minBound..maxBound]
+  Some era <- H.forAll $ Gen.element [minBound..maxBound]
   x <- forAll $ genTx era
   H.tripping x (serialiseTxLedgerCddl era) (deserialiseTxLedgerCddl era)
 
 prop_roundtrip_TxWitness_Cddl :: Property
 prop_roundtrip_TxWitness_Cddl = H.property $ do
-  AnyShelleyBasedEra sbe <- H.forAll $ Gen.element [minBound..maxBound]
+  Some sbe <- H.forAll $ Gen.element [minBound..maxBound]
   x <- forAll $ genShelleyKeyWitness sbe
   tripping x (serialiseWitnessLedgerCddl sbe) (deserialiseWitnessLedgerCddl sbe)