polymorphic tests

shelley-ma/impl/src/Cardano/Ledger/ShelleyMA.hs

@@ -33,4 +33,4 @@ type family MAValue (x :: MaryOrAllegra) era :: Type where
  MAValue Allegra era = Coin
  MAValue Mary era = Value era
 
-type instance Core.Value (ShelleyMAEra m c) = MAValue m (ShelleyMAEra m c)
+type instance Core.VALUE (ShelleyMAEra m c) = MAValue m (ShelleyMAEra m c)

shelley/chain-and-ledger/executable-spec/shelley-spec-ledger.cabal

@@ -19,6 +19,7 @@ flag development
 library
  exposed-modules:
  Cardano.Ledger.Core
+ Cardano.Ledger.Compactible
  Cardano.Ledger.Crypto
  Cardano.Ledger.Era
  Cardano.Ledger.Shelley

shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Compactible.hs

@@ -0,0 +1,49 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+module Cardano.Ledger.Compactible
+ ( -- * Compactible
+ Compactible (..),
+ Compact (..),
+ )
+where
+
+import Cardano.Binary (FromCBOR (..), ToCBOR (..))
+import Data.Kind (Type)
+import Data.Typeable (Typeable)
+
+--------------------------------------------------------------------------------
+
+-- * Compactible
+
+--
+-- Certain types may have a "presentation" form and a more compact
+-- representation that allows for more efficient memory usage. In this case,
+-- one should make instances of the 'Compactible' class for them.
+--------------------------------------------------------------------------------
+
+class Compactible a where
+ data CompactForm a :: Type
+ toCompact :: a -> CompactForm a
+ fromCompact :: CompactForm a -> a
+
+newtype Compact a = Compact {unCompact :: a}
+
+instance
+ (Typeable a, Compactible a, ToCBOR (CompactForm a)) =>
+ ToCBOR (Compact a)
+ where
+ toCBOR = toCBOR . toCompact . unCompact
+
+instance
+ (Typeable a, Compactible a, FromCBOR (CompactForm a)) =>
+ FromCBOR (Compact a)
+ where
+ fromCBOR = Compact . fromCompact <$> fromCBOR
+
+-- TODO: consider if this is better the other way around
+instance (Eq a, Compactible a) => Eq (CompactForm a) where
+ a == b = fromCompact a == fromCompact b

shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Core.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
@@ -11,53 +13,65 @@
 -- It is intended for qualified import:
 -- > import qualified Cardano.Ledger.Core as Core
 module Cardano.Ledger.Core
- ( -- * Compactible
- Compactible (..),
- Compact (..),
- TxBody,
- Value,
+ ( TxBody,
+ Value (..),
+ VALUE,
  )
 where
 
 import Cardano.Binary (FromCBOR (..), ToCBOR (..))
+import Cardano.Ledger.Compactible
+import Cardano.Ledger.Val (Val)
+import Control.DeepSeq (NFData)
+import Data.Group (Abelian, Group)
 import Data.Kind (Type)
+import Data.PartialOrd (PartialOrd (..))
 import Data.Typeable (Typeable)
+import NoThunks.Class (NoThunks)
 
 -- | A value is something which quantifies a transaction output.
-type family Value era :: Type
+type family VALUE era :: Type
 
 -- | The body of a transaction.
 type family TxBody era :: Type
 
---------------------------------------------------------------------------------
+-- Wrap the type family as a newtype because :
+-- the genericShrink has something that
+-- detects that the immediate subterms of a type are the same as the parent type
+-- when there is a type family in that position, the instance resolution fails
+newtype Value era = Value {unVl :: VALUE era}
 
--- * Compactible
+deriving instance (Typeable (VALUE era)) => Typeable (Value era)
 
---
--- Certain types may have a "presentation" form and a more compact
--- representation that allows for more efficient memory usage. In this case,
--- one should make instances of the 'Compactible' class for them.
---------------------------------------------------------------------------------
-
-class Compactible a where
- data CompactForm a :: Type
- toCompact :: a -> CompactForm a
- fromCompact :: CompactForm a -> a
-
-newtype Compact a = Compact {unCompact :: a}
-
-instance
- (Typeable a, Compactible a, ToCBOR (CompactForm a)) =>
- ToCBOR (Compact a)
- where
- toCBOR = toCBOR . toCompact . unCompact
-
-instance
- (Typeable a, Compactible a, FromCBOR (CompactForm a)) =>
- FromCBOR (Compact a)
- where
- fromCBOR = Compact . fromCompact <$> fromCBOR
-
--- TODO: consider if this is better the other way around
-instance (Eq a, Compactible a) => Eq (CompactForm a) where
- a == b = fromCompact a == fromCompact b
+deriving instance (ToCBOR (VALUE era), Typeable era) => ToCBOR (Value era)
+
+deriving instance (FromCBOR (VALUE era), Typeable era) => FromCBOR (Value era)
+
+deriving instance (Eq (VALUE era)) => Eq (Value era)
+
+deriving instance (Show (VALUE era)) => Show (Value era)
+
+deriving instance (NoThunks (VALUE era)) => NoThunks (Value era)
+
+deriving instance (NFData (VALUE era)) => NFData (Value era)
+
+deriving instance (Val (VALUE era)) => Val (Value era)
+
+deriving instance (Abelian (VALUE era)) => Abelian (Value era)
+
+deriving instance (PartialOrd (VALUE era)) => PartialOrd (Value era)
+
+deriving instance (Group (VALUE era)) => Group (Value era)
+
+deriving instance (Monoid (VALUE era)) => Monoid (Value era)
+
+deriving instance (Semigroup (VALUE era)) => Semigroup (Value era)
+
+deriving instance (ToCBOR (CompactForm (VALUE era)), Typeable era) => ToCBOR (CompactForm (Value era))
+
+deriving instance (FromCBOR (CompactForm (VALUE era)), Typeable era) => FromCBOR (CompactForm (Value era))
+
+instance (Compactible (VALUE era)) => Compactible (Value era) where
+ newtype CompactForm (Value era) = ValueC (CompactForm (VALUE era))
+ toCompact (Value v) = ValueC (toCompact v)
+ fromCompact (ValueC v) = Value (fromCompact v)

shelley/chain-and-ledger/executable-spec/src/Cardano/Ledger/Shelley.hs

@@ -1,12 +1,16 @@
 {-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE EmptyDataDecls #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 module Cardano.Ledger.Shelley where
 
 import Cardano.Binary (Annotator, FromCBOR (..), ToCBOR (..))
+import Cardano.Ledger.Compactible
 import Cardano.Ledger.Core
 import qualified Cardano.Ledger.Crypto as CryptoClass
 import Cardano.Ledger.Era
@@ -26,7 +30,7 @@ data ShelleyEra c
 instance CryptoClass.Crypto c => Era (ShelleyEra c) where
  type Crypto (ShelleyEra c) = c
 
-type instance Value (ShelleyEra c) = Coin
+type instance VALUE (ShelleyEra c) = Coin
 
 type TxBodyConstraints era =
  ( NoThunks (TxBody era),
@@ -37,19 +41,24 @@ type TxBodyConstraints era =
  HashAnnotated (TxBody era) era
  )
 
-type ShelleyBased era =
+-- this is a type class rather than a constraint bundle to avoid having
+-- to add the `UndecidableInstances` PRAGMA in modules which make use of this constraint.
+class
  ( Era era,
  -- Value constraints
- Val (Value era),
- Compactible (Value era),
- Eq (Value era),
- FromCBOR (CompactForm (Value era)),
- FromCBOR (Value era),
- NFData (Value era),
- NoThunks (Value era),
- Show (Value era),
- ToCBOR (CompactForm (Value era)),
- ToCBOR (Value era),
- Typeable (Value era),
+ Val (VALUE era),
+ Compactible (VALUE era),
+ Eq (VALUE era),
+ FromCBOR (CompactForm (VALUE era)),
+ FromCBOR (VALUE era),
+ NFData (VALUE era),
+ NoThunks (VALUE era),
+ Show (VALUE era),
+ ToCBOR (CompactForm (VALUE era)),
+ ToCBOR (VALUE era),
+ Typeable (VALUE era),
  TxBodyConstraints era
- )
+ ) =>
+ ShelleyBased era
+
+deriving instance (CryptoClass.Crypto c, TxBodyConstraints (ShelleyEra c)) => ShelleyBased (ShelleyEra c)

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/ByronTranslation.hs

@@ -18,6 +18,8 @@ import qualified Cardano.Chain.Common as Byron
 import qualified Cardano.Chain.UTxO as Byron
 import qualified Cardano.Crypto.Hash as Crypto
 import qualified Cardano.Crypto.Hashing as Hashing
+import Cardano.Ledger.Compactible (Compactible (..))
+import qualified Cardano.Ledger.Core as Core
 import qualified Cardano.Ledger.Crypto as CC
 import Cardano.Ledger.Shelley (ShelleyEra)
 import Cardano.Ledger.Val ((<->))
@@ -60,7 +62,7 @@ translateCompactTxOutByronToShelley :: Byron.CompactTxOut -> TxOut (ShelleyEra c
 translateCompactTxOutByronToShelley (Byron.CompactTxOut compactAddr amount) =
  TxOutCompact
  (Byron.unsafeGetCompactAddress compactAddr)
- (CompactCoin (Byron.unsafeGetLovelace amount))
+ (toCompact $ Core.Value (fromCompact (CompactCoin $ Byron.unsafeGetLovelace amount)))
 
 translateCompactTxInByronToShelley ::
  (CC.Crypto c, CC.ADDRHASH c ~ Crypto.Blake2b_224) =>
@@ -120,7 +122,7 @@ translateToShelleyLedgerState genesisShelley epochNo cvs =
 
  reserves :: Coin
  reserves =
- word64ToCoin (sgMaxLovelaceSupply genesisShelley) <-> balance utxoShelley
+ word64ToCoin (sgMaxLovelaceSupply genesisShelley) <-> (Core.unVl $ balance utxoShelley)
 
  epochState :: EpochState (ShelleyEra c)
  epochState =

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/API/Wallet.hs

@@ -4,7 +4,6 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
 
 module Shelley.Spec.Ledger.API.Wallet
  ( getNonMyopicMemberRewards,

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/BlockChain.hs

@@ -16,7 +16,6 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
 
 module Shelley.Spec.Ledger.BlockChain
  ( HashHeader (..),

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Coin.hs

@@ -7,7 +7,7 @@
 
 module Shelley.Spec.Ledger.Coin
  ( Coin (..),
- Core.CompactForm (..),
+ CompactForm (..),
  DeltaCoin (..),
  word64ToCoin,
  coinToRational,
@@ -18,7 +18,7 @@ module Shelley.Spec.Ledger.Coin
 where
 
 import Cardano.Binary (FromCBOR (..), ToCBOR (..))
-import qualified Cardano.Ledger.Core as Core
+import Cardano.Ledger.Compactible
 import Control.DeepSeq (NFData)
 import Data.Aeson (FromJSON, ToJSON)
 import Data.Group (Abelian, Group (..))
@@ -42,7 +42,7 @@ newtype Coin = Coin {unCoin :: Integer}
  NFData
  )
  deriving (Show) via Quiet Coin
- deriving (ToCBOR, FromCBOR) via Core.Compact Coin
+ deriving (ToCBOR, FromCBOR) via Compact Coin
  deriving (Semigroup, Monoid, Group, Abelian) via Sum Integer
  deriving newtype (PartialOrd)
 
@@ -71,7 +71,7 @@ rationalToCoinViaFloor r = Coin . floor $ r
 -- if coin is less than 0 or greater than (maxBound :: Word64), then
 -- fromIntegral constructs the incorrect value. for now this is handled
 -- with an erroring bounds check here. where should this really live?
-instance Core.Compactible Coin where
+instance Compactible Coin where
  newtype CompactForm Coin = CompactCoin Word64
  toCompact (Coin c)
  | c < 0 = error $ "out of bounds : " ++ show c
@@ -80,8 +80,8 @@ instance Core.Compactible Coin where
  | otherwise = CompactCoin (fromIntegral c)
  fromCompact (CompactCoin c) = word64ToCoin c
 
-instance ToCBOR (Core.CompactForm Coin) where
+instance ToCBOR (CompactForm Coin) where
  toCBOR (CompactCoin c) = toCBOR c
 
-instance FromCBOR (Core.CompactForm Coin) where
+instance FromCBOR (CompactForm Coin) where
  fromCBOR = CompactCoin <$> fromCBOR

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/EpochBoundary.hs

@@ -32,6 +32,7 @@ module Shelley.Spec.Ledger.EpochBoundary
 where
 
 import Cardano.Binary (FromCBOR (..), ToCBOR (..), encodeListLen)
+import Cardano.Ledger.Compactible (Compactible (..))
 import qualified Cardano.Ledger.Core as Core
 import Cardano.Ledger.Era
 import Cardano.Ledger.Shelley (ShelleyBased)
@@ -99,7 +100,7 @@ aggregateUtxoCoinByCredential ptrs (UTxO u) initial =
  Map.foldr accum initial u
  where
  accum (TxOutCompact addr c) ans =
- let c' = Val.coin . Core.fromCompact @(Core.Value era) $ c
+ let c' = Val.coin . fromCompact @(Core.Value era) $ c
  in case deserialiseAddrStakeRef addr of
  Just (StakeRefPtr p) -> case Map.lookup p ptrs of
  Just cred -> Map.insertWith (<>) cred c' ans

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/Genesis.hs

@@ -11,7 +11,6 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
 
 module Shelley.Spec.Ledger.Genesis
  ( ShelleyGenesisStaking (..),

shelley/chain-and-ledger/executable-spec/src/Shelley/Spec/Ledger/LedgerState.hs

@@ -16,7 +16,6 @@
 {-# LANGUAGE TupleSections #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
 
 -- |
 -- Module : LedgerState
@@ -370,7 +369,7 @@ instance Era era => FromCBOR (DPState era) where
 
 data RewardUpdate era = RewardUpdate
  { deltaT :: !Coin,
- deltaR :: !Coin,
+ deltaR :: !DeltaCoin,
  rs :: !(Map (Credential 'Staking era) Coin),
  deltaF :: !DeltaCoin,
  nonMyopic :: !(NonMyopic era)
@@ -401,7 +400,7 @@ instance Era era => FromCBOR (RewardUpdate era) where
  pure $ RewardUpdate dt (invert dr) rw (invert df) nm
 
 emptyRewardUpdate :: RewardUpdate era
-emptyRewardUpdate = RewardUpdate (Coin 0) (Coin 0) Map.empty (DeltaCoin 0) emptyNonMyopic
+emptyRewardUpdate = RewardUpdate (Coin 0) (DeltaCoin 0) Map.empty (DeltaCoin 0) emptyNonMyopic
 
 data AccountState = AccountState
  { _treasury :: !Coin,
@@ -976,7 +975,7 @@ applyRUpd ru (EpochState as ss ls pr pp _nm) = EpochState as' ss ls' pr pp nm'
  as' =
  as
  { _treasury = _treasury as <> deltaT ru <> fold (range unregRU),
- _reserves = _reserves as <> deltaR ru
+ _reserves = addDelta (_reserves as) (deltaR ru)
  }
  ls' =
  ls
@@ -1056,7 +1055,7 @@ createRUpd slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) ma
  pure $
  RewardUpdate
  { deltaT = (Coin deltaT1),
- deltaR = (invert deltaR1 <> deltaR2),
+ deltaR = ((invert $ toDelta deltaR1) <> toDelta deltaR2),
  rs = rs_,
  deltaF = (invert (toDelta $ _feeSS ss)),
  nonMyopic = (updateNonMypopic nm _R newLikelihoods)