Merge pull request #1865 from input-output-hk/ts-new-genTx

Migrates the improved Transaction Generator using Fixed points into master.

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

@@ -18,11 +18,14 @@
 -- > import qualified Cardano.Ledger.Val as Val
 module Cardano.Ledger.Val
   ( Val (..),
-    (~~),
+    (<+>),
+    (<->),
+    (<×>),
+    invert,
+    sumVal,
     scaledMinDeposit,
 
     -- * Re-exports
-    Data.Group.invert,
     (Data.PartialOrd.<=),
     (Data.PartialOrd.>=),
     (Data.PartialOrd.==),
@@ -38,7 +41,7 @@ import Cardano.Binary
     ToCBOR (..),
   )
 import Cardano.Prelude (NFData (), NoUnexpectedThunks (..))
-import Data.Group (Abelian, Group (invert))
+import Data.Group (Abelian)
 import Data.PartialOrd hiding ((==))
 import qualified Data.PartialOrd
 import Data.Typeable (Typeable)
@@ -74,10 +77,30 @@ class
   size :: t -> Integer -- compute size of Val instance
   -- TODO add PACK/UNPACK stuff to this class
 
--- | Group subtraction. When we move to groups-0.5 we can export this from
--- there.
-(~~) :: Group g => g -> g -> g
-a ~~ b = a <> invert b
+-- =============================================================
+-- Infix synonyms with types fixed at (Val t). Makes calls easier
+-- to read, and gives better error messages, when a mistake is made
+
+infixl 6 <+>
+
+infixl 6 <->
+
+infixl 7 <×>
+
+(<+>) :: Val t => t -> t -> t
+x <+> y = x <> y
+
+(<->) :: Val t => t -> t -> t
+x <-> y = x <+> (invert y)
+
+(<×>) :: Val t => Int -> t -> t
+x <×> y = scale x y
+
+invert :: Val t => t -> t
+invert x = scale (-1 :: Int) x
+
+sumVal :: (Foldable t, Val v) => t v -> v
+sumVal xs = foldl (<+>) mempty xs
 
 instance Val Coin where
   scale n (Coin x) = Coin $ (fromIntegral n) * x

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

@@ -20,7 +20,7 @@ import qualified Cardano.Crypto.Hash as Crypto
 import qualified Cardano.Crypto.Hashing as Hashing
 import Cardano.Ledger.Crypto (ADDRHASH)
 import Cardano.Ledger.Era
-import qualified Cardano.Ledger.Val as Val
+import Cardano.Ledger.Val ((<->))
 import qualified Data.ByteString.Short as SBS
 import qualified Data.Map.Strict as Map
 import Data.Maybe (fromMaybe)
@@ -119,7 +119,7 @@ translateToShelleyLedgerState genesisShelley epochNo cvs =
 
     reserves :: Coin
     reserves =
-      word64ToCoin (sgMaxLovelaceSupply genesisShelley) Val.~~ balance utxoShelley
+      word64ToCoin (sgMaxLovelaceSupply genesisShelley) <-> balance utxoShelley
 
     epochState :: EpochState era
     epochState =

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

@@ -28,7 +28,7 @@ where
 
 import Cardano.Binary (FromCBOR (..), ToCBOR (..), encodeListLen)
 import Cardano.Ledger.Era
-import qualified Cardano.Ledger.Val as Val
+import Cardano.Ledger.Val ((<+>), (<×>))
 import Cardano.Prelude (NFData, NoUnexpectedThunks (..))
 import Control.Iterate.SetAlgebra (dom, eval, setSingleton, (▷), (◁))
 import Data.Map.Strict (Map)
@@ -108,8 +108,7 @@ obligation ::
   Map (KeyHash 'StakePool era) (PoolParams era) ->
   Coin
 obligation pp rewards stakePools =
-  Val.scale (length rewards) (_keyDeposit pp)
-    <> Val.scale (length stakePools) (_poolDeposit pp)
+  (length rewards <×> _keyDeposit pp) <+> (length stakePools <×> _poolDeposit pp)
 
 -- | Calculate maximal pool reward
 maxPool :: PParams era -> Coin -> Rational -> Rational -> Coin

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

@@ -11,6 +11,7 @@
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -137,6 +138,7 @@ class HasKeyRole (a :: KeyRole -> Type -> Type) where
 --   be used as witnesses to some types of transaction. As such, we provide an
 --   explicit coercion for it.
 asWitness ::
+  forall era a r.
   (HasKeyRole a) =>
   a r era ->
   a 'Witness era

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

@@ -95,7 +95,7 @@ import Cardano.Binary
     encodeListLen,
   )
 import Cardano.Ledger.Era (Era)
-import qualified Cardano.Ledger.Val as Val
+import Cardano.Ledger.Val (invert, (<+>), (<->), (<×>))
 import Cardano.Prelude (NFData, NoUnexpectedThunks (..))
 import Control.Iterate.SetAlgebra (Bimap, biMapEmpty, dom, eval, forwards, range, (∈), (∪+), (▷), (◁))
 import Control.Monad.Trans.Reader (asks)
@@ -365,9 +365,9 @@ instance Era era => ToCBOR (RewardUpdate era) where
   toCBOR (RewardUpdate dt dr rw df nm) =
     encodeListLen 5
       <> toCBOR dt
-      <> toCBOR (Val.invert dr) -- TODO change Coin serialization to use integers?
+      <> toCBOR (invert dr) -- TODO change Coin serialization to use integers?
       <> toCBOR rw
-      <> toCBOR (Val.invert df) -- TODO change Coin serialization to use integers?
+      <> toCBOR (invert df) -- TODO change Coin serialization to use integers?
       <> toCBOR nm
 
 instance Era era => FromCBOR (RewardUpdate era) where
@@ -378,7 +378,7 @@ instance Era era => FromCBOR (RewardUpdate era) where
       rw <- fromCBOR
       df <- fromCBOR -- TODO change Coin serialization to use integers?
       nm <- fromCBOR
-      pure $ RewardUpdate dt (Val.invert dr) rw (Val.invert df) nm
+      pure $ RewardUpdate dt (invert dr) rw (invert df) nm
 
 emptyRewardUpdate :: RewardUpdate era
 emptyRewardUpdate = RewardUpdate (Coin 0) (Coin 0) Map.empty (Coin 0) emptyNonMyopic
@@ -667,7 +667,7 @@ keyRefunds ::
   PParams era ->
   TxBody era ->
   Coin
-keyRefunds pp tx = Val.scale (length deregistrations) (_keyDeposit pp)
+keyRefunds pp tx = (length deregistrations) <×> (_keyDeposit pp)
   where
     deregistrations = filter isDeRegKey (toList $ _certs tx)
 
@@ -806,7 +806,7 @@ depositPoolChange ::
   PParams era ->
   TxBody era ->
   Coin
-depositPoolChange ls pp tx = (currentPool <> txDeposits) Val.~~ txRefunds
+depositPoolChange ls pp tx = (currentPool <+> txDeposits) <-> txRefunds
   where
     -- Note that while (currentPool + txDeposits) >= txRefunds,
     -- it could be that txDeposits < txRefunds. We keep the parenthesis above
@@ -942,14 +942,14 @@ createRUpd slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) ma
           totalStake
           asc
           slotsPerEpoch
-      deltaR2 = _R Val.~~ (Map.foldr (<>) mempty rs_)
+      deltaR2 = _R <-> (Map.foldr (<+>) mempty rs_)
       blocksMade = fromIntegral $ Map.foldr (+) 0 b' :: Integer
   pure $
     RewardUpdate
       { deltaT = (Coin deltaT1),
-        deltaR = (Val.invert deltaR1 <> deltaR2),
+        deltaR = (invert deltaR1 <> deltaR2),
         rs = rs_,
-        deltaF = (Val.invert (_feeSS ss)),
+        deltaF = (invert (_feeSS ss)),
         nonMyopic = (updateNonMypopic nm _R newLikelihoods)
       }
 
@@ -958,7 +958,7 @@ createRUpd slotsPerEpoch b@(BlocksMade b') es@(EpochState acnt ss ls pr _ nm) ma
 -- This is used in the rewards calculation, and for API endpoints for pool ranking.
 circulation :: EpochState era -> Coin -> Coin
 circulation (EpochState acnt _ _ _ _ _) supply =
-  supply Val.~~ (_reserves acnt)
+  supply <-> (_reserves acnt)
 
 -- | Update new epoch state
 updateNES ::

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

@@ -32,7 +32,7 @@ import Cardano.Binary
     encodeListLen,
   )
 import Cardano.Ledger.Era (Era)
-import qualified Cardano.Ledger.Val as Val
+import Cardano.Ledger.Val ((<->))
 import Cardano.Prelude (NFData, NoUnexpectedThunks (..))
 import Cardano.Slotting.Slot (EpochSize)
 import Control.Iterate.SetAlgebra (eval, (◁))
@@ -328,7 +328,7 @@ leaderRew f pool (StakeShare s) (StakeShare sigma)
   | otherwise =
     c
       <> rationalToCoinViaFloor
-        (coinToRational (f Val.~~ c) * (m' + (1 - m') * s / sigma))
+        (coinToRational (f <-> c) * (m' + (1 - m') * s / sigma))
   where
     (c, m, _) = poolSpec pool
     m' = unitIntervalToRational m

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

@@ -15,7 +15,7 @@ module Shelley.Spec.Ledger.STS.Mir
   )
 where
 
-import qualified Cardano.Ledger.Val as Val
+import Cardano.Ledger.Val ((<->))
 import Cardano.Prelude (NoUnexpectedThunks (..))
 import Control.Iterate.SetAlgebra (dom, eval, (∪+), (◁))
 import Control.State.Transition
@@ -122,8 +122,8 @@ mirTransition = do
       pure $
         EpochState
           acnt
-            { _reserves = reserves Val.~~ totR,
-              _treasury = treasury Val.~~ totT
+            { _reserves = reserves <-> totR,
+              _treasury = treasury <-> totT
             }
           ss
           ls

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

@@ -12,7 +12,7 @@ module Shelley.Spec.Ledger.STS.PoolReap
   )
 where
 
-import qualified Cardano.Ledger.Val as Val
+import Cardano.Ledger.Val ((<+>), (<->))
 import Cardano.Prelude (NoUnexpectedThunks (..))
 import Control.Iterate.SetAlgebra (dom, eval, setSingleton, (∈), (∪+), (⋪), (⋫), (▷), (◁))
 import Control.State.Transition
@@ -93,7 +93,7 @@ poolReapTransition = do
       pr = Map.fromList $ fmap (\kh -> (kh, _poolDeposit pp)) (Set.toList retired)
       rewardAcnts = Map.map _poolRAcnt $ eval (retired ◁ (_pParams ps))
       rewardAcnts' =
-        Map.fromListWith (<>)
+        Map.fromListWith (<+>)
           . Map.elems
           $ Map.intersectionWith (,) rewardAcnts pr
       (refunds, mRefunds) =
@@ -105,8 +105,8 @@ poolReapTransition = do
 
   pure $
     PoolreapState
-      us {_deposited = _deposited us Val.~~ (unclaimed <> refunded)}
-      a {_treasury = _treasury a <> unclaimed}
+      us {_deposited = _deposited us <-> (unclaimed <+> refunded)}
+      a {_treasury = _treasury a <+> unclaimed}
       ds
         { _rewards = eval (_rewards ds ∪+ refunds),
           _delegations = eval (_delegations ds ⋫ retired)

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

@@ -26,7 +26,7 @@ import Cardano.Binary
     encodeListLen,
   )
 import Cardano.Ledger.Era (Era)
-import qualified Cardano.Ledger.Val as Val
+import Cardano.Ledger.Val (scaledMinDeposit, (<->))
 import Cardano.Prelude (NoUnexpectedThunks (..), asks)
 import Control.Iterate.SetAlgebra (dom, eval, (∪), (⊆), (⋪))
 import Control.State.Transition
@@ -308,7 +308,7 @@ utxoInductive = do
 
   let outputs = Map.elems $ unUTxO (txouts txb)
       minUTxOValue = _minUTxOValue pp
-      outputsTooSmall = [out | out@(TxOut _ c) <- outputs, c < (Val.scaledMinDeposit c minUTxOValue)]
+      outputsTooSmall = [out | out@(TxOut _ c) <- outputs, c < (scaledMinDeposit c minUTxOValue)]
   null outputsTooSmall ?! OutputTooSmallUTxO outputsTooSmall
 
   -- Bootstrap (i.e. Byron) addresses have variable sized attributes in them.
@@ -323,7 +323,7 @@ utxoInductive = do
 
   let refunded = keyRefunds pp txb
   let txCerts = toList $ _certs txb
-  let depositChange = totalDeposits pp stakepools txCerts Val.~~ refunded
+  let depositChange = totalDeposits pp stakepools txCerts <-> refunded
 
   pure
     UTxOState

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

@@ -43,7 +43,7 @@ where
 
 import Cardano.Binary (FromCBOR (..), ToCBOR (..))
 import Cardano.Ledger.Era
-import qualified Cardano.Ledger.Val as Val
+import Cardano.Ledger.Val ((<+>), (<×>))
 import Cardano.Prelude (Generic, NFData, NoUnexpectedThunks (..))
 import Control.Iterate.SetAlgebra
   ( BaseRep (MapR),
@@ -230,7 +230,7 @@ makeWitnessesFromScriptKeys txbodyHash hashKeyMap scriptHashes =
 balance :: UTxO era -> Coin
 balance (UTxO utxo) = Map.foldl' addCoins mempty utxo
   where
-    addCoins !b (TxOutCompact _ (word64ToCoin -> a)) = a <> b
+    addCoins !b (TxOutCompact _ (word64ToCoin -> a)) = a <+> b
 
 -- | Determine the total deposit amount needed.
 -- The block may (legitimately) contain multiple registration certificates
@@ -246,7 +246,7 @@ totalDeposits ::
   [DCert era] ->
   Coin
 totalDeposits pp stpools cs =
-  Val.scale numKeys (_keyDeposit pp) <> Val.scale numNewPools (_poolDeposit pp)
+  (numKeys <×> _keyDeposit pp) <+> (numNewPools <×> _poolDeposit pp)
   where
     numKeys = length $ filter isRegKey cs
     pools = Set.fromList . Maybe.catMaybes $ fmap getKeyHashFromRegPool cs