Skip to content

Commit ae21b70

Browse files
SoupstrawSoupstraw
committed
Generics
1 parent 0aa92f7 commit ae21b70

File tree

2 files changed

+49
-162
lines changed

2 files changed

+49
-162
lines changed

‎eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs‎

Lines changed: 38 additions & 72 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
{-# LANGUAGE AllowAmbiguousTypes #-}
22
{-# LANGUAGE DataKinds #-}
3+
{-# LANGUAGE DefaultSignatures #-}
34
{-# LANGUAGE DeriveGeneric #-}
45
{-# LANGUAGE DerivingVia #-}
56
{-# LANGUAGE FlexibleContexts #-}
@@ -16,6 +17,7 @@
1617
{-# LANGUAGE StandaloneDeriving #-}
1718
{-# LANGUAGE TypeApplications #-}
1819
{-# LANGUAGE TypeFamilies #-}
20+
{-# LANGUAGE TypeOperators #-}
1921
{-# LANGUAGE UndecidableInstances #-}
2022
{-# LANGUAGE UndecidableSuperClasses #-}
2123
{-# OPTIONS_GHC -Wno-orphans #-}
@@ -77,7 +79,6 @@ module Cardano.Ledger.Conway.PParams (
7779
DRepGroup (..),
7880
PPGroups (..),
7981
StakePoolGroup (..),
80-
conwayModifiedPPGroups,
8182
pvtHardForkInitiationL,
8283
pvtMotionNoConfidenceL,
8384
emptyConwayPParams,
@@ -148,15 +149,24 @@ import Data.Set (Set)
148149
import qualified Data.Set as Set
149150
import Data.Typeable
150151
import Data.Word (Word16, Word32)
151-
import GHC.Generics (Generic, K1 (..))
152+
import GHC.Generics (Generic (..), K1 (..), M1 (..), (:*:) (..))
152153
import GHC.Stack (HasCallStack)
153-
import Lens.Micro
154+
import Lens.Micro (Lens', lens, set, (^.))
155+
import qualified Lens.Micro as L
154156
import NoThunks.Class (NoThunks (..))
155157
import Numeric.Natural (Natural)
156158
import qualified PlutusLedgerApi.Common as P (Data (..))
157159

158160
class BabbageEraPParams era => ConwayEraPParams era where
159161
modifiedPPGroups :: PParamsUpdate era -> Set PPGroups
162+
default modifiedPPGroups ::
163+
forall a.
164+
( Generic (PParamsHKD StrictMaybe era)
165+
, CollectModifiedPPGroups (Rep (PParamsHKD StrictMaybe era) a)
166+
) =>
167+
PParamsUpdate era ->
168+
Set PPGroups
169+
modifiedPPGroups (PParamsUpdate ppu) = collectModifiedPPGroups $ from @_ @a ppu
160170
ppuWellFormed :: ProtVer -> PParamsUpdate era -> Bool
161171

162172
hkdPoolVotingThresholdsL :: HKDFunctor f => Lens' (PParamsHKD f era) (HKD f PoolVotingThresholds)
@@ -799,7 +809,7 @@ instance EraPParams ConwayEra where
799809
hkdMinPoolCostL = lens (unTHKD . cppMinPoolCost) $ \pp x -> pp {cppMinPoolCost = THKD x}
800810
ppProtocolVersionL = ppLensHKD . lens cppProtocolVersion (\pp x -> pp {cppProtocolVersion = x})
801811

802-
ppDG = to (const minBound)
812+
ppDG = L.to (const minBound)
803813
ppuProtocolVersionL = notSupportedInThisEraL
804814
hkdDL = notSupportedInThisEraL
805815
hkdExtraEntropyL = notSupportedInThisEraL
@@ -872,7 +882,6 @@ instance BabbageEraPParams ConwayEra where
872882
lens (unTHKD . cppCoinsPerUTxOByte) $ \pp x -> pp {cppCoinsPerUTxOByte = THKD x}
873883

874884
instance ConwayEraPParams ConwayEra where
875-
modifiedPPGroups (PParamsUpdate ppu) = conwayModifiedPPGroups ppu
876885
ppuWellFormed pv ppu =
877886
and
878887
[ -- Numbers
@@ -1121,73 +1130,30 @@ downgradeConwayPParams ConwayPParams {..} =
11211130
, bppMaxCollateralInputs = asNaturalHKD @f @Word16 (unTHKD cppMaxCollateralInputs)
11221131
}
11231132

1124-
conwayModifiedPPGroups :: ConwayPParams StrictMaybe era -> Set PPGroups
1125-
conwayModifiedPPGroups
1126-
( ConwayPParams
1127-
p01
1128-
p02
1129-
p03
1130-
p04
1131-
p05
1132-
p06
1133-
p07
1134-
p08
1135-
p09
1136-
p10
1137-
p11
1138-
p12
1139-
_protocolVersion
1140-
p14
1141-
p15
1142-
p16
1143-
p17
1144-
p18
1145-
p19
1146-
p20
1147-
p21
1148-
p22
1149-
p23
1150-
p24
1151-
p25
1152-
p26
1153-
p27
1154-
p28
1155-
p29
1156-
p30
1157-
p31
1158-
) =
1159-
mconcat
1160-
[ ppGroup p01
1161-
, ppGroup p02
1162-
, ppGroup p03
1163-
, ppGroup p04
1164-
, ppGroup p05
1165-
, ppGroup p06
1166-
, ppGroup p07
1167-
, ppGroup p08
1168-
, ppGroup p09
1169-
, ppGroup p10
1170-
, ppGroup p11
1171-
, ppGroup p12
1172-
, ppGroup p14
1173-
, ppGroup p15
1174-
, ppGroup p16
1175-
, ppGroup p17
1176-
, ppGroup p18
1177-
, ppGroup p19
1178-
, ppGroup p20
1179-
, ppGroup p21
1180-
, ppGroup p22
1181-
, ppGroup p23
1182-
, ppGroup p24
1183-
, ppGroup p25
1184-
, ppGroup p26
1185-
, ppGroup p27
1186-
, ppGroup p28
1187-
, ppGroup p29
1188-
, ppGroup p30
1189-
, ppGroup p31
1190-
]
1133+
class CollectModifiedPPGroups x where
1134+
collectModifiedPPGroups :: x -> Set PPGroups
1135+
1136+
instance
1137+
( CollectModifiedPPGroups (x u)
1138+
, CollectModifiedPPGroups (y u)
1139+
) =>
1140+
CollectModifiedPPGroups ((x :*: y) u)
1141+
where
1142+
collectModifiedPPGroups (x :*: y) = collectModifiedPPGroups x <> collectModifiedPPGroups y
1143+
1144+
instance
1145+
( ToDRepGroup g
1146+
, ToStakePoolGroup h
1147+
) =>
1148+
CollectModifiedPPGroups (K1 i (THKD ('PPGroups g h) StrictMaybe a) p)
1149+
where
1150+
collectModifiedPPGroups (K1 x) = ppGroup x
1151+
1152+
instance CollectModifiedPPGroups (K1 i (NoUpdate a) p) where
1153+
collectModifiedPPGroups _ = mempty
1154+
1155+
instance CollectModifiedPPGroups (a u) => CollectModifiedPPGroups (M1 i c a u) where
1156+
collectModifiedPPGroups (M1 x) = collectModifiedPPGroups x
11911157

11921158
asNaturalHKD :: forall f i. (HKDFunctor f, Integral i) => HKD f i -> HKD f Natural
11931159
asNaturalHKD = hkdMap (Proxy @f) (fromIntegral @i @Natural)

‎eras/dijkstra/src/Cardano/Ledger/Dijkstra/PParams.hs‎

Lines changed: 11 additions & 90 deletions
Original file line numberDiff line numberDiff line change
@@ -1,20 +1,20 @@
1+
{-# LANGUAGE AllowAmbiguousTypes #-}
12
{-# LANGUAGE DataKinds #-}
23
{-# LANGUAGE DeriveGeneric #-}
34
{-# LANGUAGE FlexibleInstances #-}
45
{-# LANGUAGE InstanceSigs #-}
56
{-# LANGUAGE RankNTypes #-}
67
{-# LANGUAGE ScopedTypeVariables #-}
8+
{-# LANGUAGE StandaloneDeriving #-}
79
{-# LANGUAGE TypeApplications #-}
810
{-# LANGUAGE TypeFamilies #-}
911
{-# LANGUAGE UndecidableSuperClasses #-}
1012
{-# OPTIONS_GHC -Wno-orphans #-}
11-
{-# LANGUAGE AllowAmbiguousTypes #-}
12-
{-# LANGUAGE StandaloneDeriving #-}
1313

14-
module Cardano.Ledger.Dijkstra.PParams
15-
( DijkstraPParams (..)
16-
, DijkstraEraPParams (..)
17-
) where
14+
module Cardano.Ledger.Dijkstra.PParams (
15+
DijkstraPParams (..),
16+
DijkstraEraPParams (..),
17+
) where
1818

1919
import Cardano.Ledger.Alonzo.PParams
2020
import Cardano.Ledger.Babbage.PParams
@@ -30,19 +30,18 @@ import Cardano.Ledger.Conway.PParams
3030
import Cardano.Ledger.Core hiding (ppUpdate)
3131
import Cardano.Ledger.Dijkstra.Era (DijkstraEra)
3232
import Cardano.Ledger.HKD (HKDFunctor (..), HKDNoUpdate, NoUpdate (..))
33-
import Cardano.Ledger.Plutus (CostModels, ExUnits (..), Prices (..), updateCostModels, emptyCostModels)
33+
import Cardano.Ledger.Plutus (CostModels, ExUnits (..), Prices (..), emptyCostModels)
3434
import Cardano.Ledger.Shelley.PParams
3535
import Cardano.Ledger.Val (Val (..))
36+
import Control.DeepSeq (NFData)
3637
import Data.Data (Proxy (..))
38+
import Data.Default (Default (..))
39+
import Data.Functor.Identity (Identity)
3740
import Data.Word (Word16, Word32)
3841
import GHC.Generics (Generic)
3942
import Lens.Micro (Lens', lens, to, (^.))
40-
import Numeric.Natural (Natural)
41-
import Data.Functor.Identity (Identity)
42-
import Data.Set (Set)
43-
import Data.Default (Default(..))
4443
import NoThunks.Class (NoThunks)
45-
import Control.DeepSeq (NFData)
44+
import Numeric.Natural (Natural)
4645

4746
-- | Dijkstra Protocol parameters. The following parameters have been added since Dijkstra:
4847
-- * @maxRefScriptSizePerBlock@
@@ -127,7 +126,6 @@ data DijkstraPParams f era = DijkstraPParams
127126
}
128127
deriving (Generic)
129128

130-
131129
deriving instance Eq (DijkstraPParams Identity era)
132130

133131
deriving instance Ord (DijkstraPParams Identity era)
@@ -148,82 +146,6 @@ instance NoThunks (DijkstraPParams StrictMaybe era)
148146

149147
instance NFData (DijkstraPParams StrictMaybe era)
150148

151-
dijkstraModifiedPPGroups :: DijkstraPParams StrictMaybe era -> Set PPGroups
152-
dijkstraModifiedPPGroups
153-
( DijkstraPParams
154-
p01
155-
p02
156-
p03
157-
p04
158-
p05
159-
p06
160-
p07
161-
p08
162-
p09
163-
p10
164-
p11
165-
p12
166-
_protocolVersion
167-
p14
168-
p15
169-
p16
170-
p17
171-
p18
172-
p19
173-
p20
174-
p21
175-
p22
176-
p23
177-
p24
178-
p25
179-
p26
180-
p27
181-
p28
182-
p29
183-
p30
184-
p31
185-
p32
186-
p33
187-
p34
188-
p35
189-
) =
190-
mconcat
191-
[ ppGroup p01
192-
, ppGroup p02
193-
, ppGroup p03
194-
, ppGroup p04
195-
, ppGroup p05
196-
, ppGroup p06
197-
, ppGroup p07
198-
, ppGroup p08
199-
, ppGroup p09
200-
, ppGroup p10
201-
, ppGroup p11
202-
, ppGroup p12
203-
, ppGroup p14
204-
, ppGroup p15
205-
, ppGroup p16
206-
, ppGroup p17
207-
, ppGroup p18
208-
, ppGroup p19
209-
, ppGroup p20
210-
, ppGroup p21
211-
, ppGroup p22
212-
, ppGroup p23
213-
, ppGroup p24
214-
, ppGroup p25
215-
, ppGroup p26
216-
, ppGroup p27
217-
, ppGroup p28
218-
, ppGroup p29
219-
, ppGroup p30
220-
, ppGroup p31
221-
, ppGroup p32
222-
, ppGroup p33
223-
, ppGroup p34
224-
, ppGroup p35
225-
]
226-
227149
instance EraPParams DijkstraEra where
228150
type PParamsHKD f DijkstraEra = DijkstraPParams f DijkstraEra
229151
type UpgradePParams f DijkstraEra = ()
@@ -323,7 +245,6 @@ instance BabbageEraPParams DijkstraEra where
323245
lens (unTHKD . dppCoinsPerUTxOByte) $ \pp x -> pp {dppCoinsPerUTxOByte = THKD x}
324246

325247
instance ConwayEraPParams DijkstraEra where
326-
modifiedPPGroups (PParamsUpdate ppu) = dijkstraModifiedPPGroups ppu
327248
ppuWellFormed _pv ppu =
328249
and
329250
[ -- Numbers

0 commit comments

Comments
 (0)