From 96b44977911d7d3184aa81a08e5c28087cde8c1b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Joosep=20J=C3=A4=C3=A4ger?= Date: Thu, 24 Aug 2023 17:02:37 +0300 Subject: [PATCH] Added RATIFY thresholds --- .../impl/src/Cardano/Ledger/Conway/Core.hs | 55 +++++++++- .../src/Cardano/Ledger/Conway/Governance.hs | 78 +++++++++++++- .../impl/src/Cardano/Ledger/Conway/PParams.hs | 34 +++++- .../src/Cardano/Ledger/Conway/Rules/Ratify.hs | 53 +++++----- .../Test/Cardano/Ledger/Conway/RatifySpec.hs | 20 ++-- .../cardano-ledger-core.cabal | 1 + .../src/Cardano/Ledger/Ap.hs | 100 ++++++++++++++++++ 7 files changed, 301 insertions(+), 40 deletions(-) create mode 100644 libs/cardano-ledger-core/src/Cardano/Ledger/Ap.hs diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs index a3c009fe626..588622dd037 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Core.hs @@ -1,6 +1,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} @@ -16,6 +17,11 @@ module Cardano.Ledger.Conway.Core ( module X, ConwayEraTxBody (..), ConwayEraPParams (..), + PParamGroup (..), + ParamGrouper, + pGroup, + pUngrouped, + modifiedGroups, ppPoolVotingThresholdsL, ppDRepVotingThresholdsL, ppMinCommitteeSizeL, @@ -34,11 +40,16 @@ module Cardano.Ledger.Conway.Core ( ppuDRepActivityL, PoolVotingThresholds (..), DRepVotingThresholds (..), + dvtPPNetworkGroupL, + dvtPPGovGroupL, + dvtPPTechnicalGroupL, + dvtPPEconomicGroupL, ) where +import Cardano.Ledger.Ap (Ap, runAp_) import Cardano.Ledger.Babbage.Core as X -import Cardano.Ledger.BaseTypes (EpochNo, StrictMaybe, UnitInterval) +import Cardano.Ledger.BaseTypes (EpochNo, StrictMaybe (..), UnitInterval) import Cardano.Ledger.Binary (DecCBOR, EncCBOR, decodeRecordNamed, encodeListLen) import Cardano.Ledger.Binary.Decoding (DecCBOR (decCBOR)) import Cardano.Ledger.Binary.Encoding (EncCBOR (encCBOR)) @@ -50,8 +61,10 @@ import Data.Aeson (ToJSON) import Data.Default.Class (Default) import Data.Functor.Identity (Identity) import Data.Sequence.Strict (StrictSeq (..)) +import Data.Set (Set) +import qualified Data.Set as Set import GHC.Generics (Generic) -import Lens.Micro (Lens') +import Lens.Micro (Lens', lens) import NoThunks.Class (NoThunks) import Numeric.Natural (Natural) @@ -68,7 +81,33 @@ class BabbageEraTxBody era => ConwayEraTxBody era where treasuryDonationTxBodyL :: Lens' (TxBody era) Coin +data PParamGroup + = EconomicGroup + | NetworkGroup + | TechnicalGroup + | GovernanceGroup + deriving (Eq, Ord) + +newtype ParamGrouper a = ParamGrouper {unParamGrouper :: Set PParamGroup} + deriving (Functor) + +pGroup :: PParamGroup -> StrictMaybe a -> Ap f (ParamGrouper a) +pGroup pg (SJust _) = pure . ParamGrouper $ Set.singleton pg +pGroup _ SNothing = pure $ ParamGrouper mempty + +pUngrouped :: Ap f (ParamGrouper a) +pUngrouped = pure $ ParamGrouper mempty + +modifiedGroups :: + forall era. + ConwayEraPParams era => + PParamsUpdate era -> + Set PParamGroup +modifiedGroups = runAp_ unParamGrouper . (pparamsGroups @era) + class BabbageEraPParams era => ConwayEraPParams era where + pparamsGroups :: + Functor f => PParamsUpdate era -> Ap f (PParamsHKD ParamGrouper era) ppuWellFormed :: PParamsUpdate era -> Bool hkdPoolVotingThresholdsL :: HKDFunctor f => Lens' (PParamsHKD f era) (HKD f PoolVotingThresholds) @@ -167,6 +206,18 @@ data DRepVotingThresholds = DRepVotingThresholds } deriving (Eq, Ord, Show, Generic, Default, ToJSON, NFData, NoThunks) +dvtPPNetworkGroupL :: Lens' DRepVotingThresholds UnitInterval +dvtPPNetworkGroupL = lens dvtPPNetworkGroup (\x y -> x {dvtPPNetworkGroup = y}) + +dvtPPEconomicGroupL :: Lens' DRepVotingThresholds UnitInterval +dvtPPEconomicGroupL = lens dvtPPEconomicGroup (\x y -> x {dvtPPEconomicGroup = y}) + +dvtPPTechnicalGroupL :: Lens' DRepVotingThresholds UnitInterval +dvtPPTechnicalGroupL = lens dvtPPTechnicalGroup (\x y -> x {dvtPPTechnicalGroup = y}) + +dvtPPGovGroupL :: Lens' DRepVotingThresholds UnitInterval +dvtPPGovGroupL = lens dvtPPGovGroup (\x y -> x {dvtPPGovGroup = y}) + instance EncCBOR DRepVotingThresholds where encCBOR DRepVotingThresholds {..} = encodeListLen 10 diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs index 090dafe7db6..0cdebe46afa 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Governance.hs @@ -3,6 +3,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} @@ -27,6 +28,7 @@ module Cardano.Ledger.Conway.Governance ( GovActionIx (..), GovActionId (..), GovActionPurpose (..), + GovRole (..), PrevGovActionId (..), govActionIdToText, Voter (..), @@ -40,9 +42,11 @@ module Cardano.Ledger.Conway.Governance ( indexedGovProps, Constitution (..), ConwayEraGov (..), + threshold, -- Lenses cgGovActionsStateL, cgRatifyStateL, + ensCommitteeL, ensConstitutionL, rsEnactStateL, curPParamsConwayGovStateL, @@ -52,7 +56,7 @@ module Cardano.Ledger.Conway.Governance ( ) where import Cardano.Ledger.Address (RewardAcnt) -import Cardano.Ledger.BaseTypes (EpochNo (..), ProtVer (..), StrictMaybe) +import Cardano.Ledger.BaseTypes (EpochNo (..), ProtVer (..), StrictMaybe (..), UnitInterval) import Cardano.Ledger.Binary ( DecCBOR (..), EncCBOR (..), @@ -68,6 +72,7 @@ import Cardano.Ledger.Binary.Coders ( ( x {ensCommittee = y}) + ensConstitutionL :: Lens' (EnactState era) (Constitution era) ensConstitutionL = lens ensConstitution (\x y -> x {ensConstitution = y}) @@ -413,3 +425,65 @@ class EraGov era => ConwayEraGov era where instance Crypto c => ConwayEraGov (ConwayEra c) where constitutionGovStateL = cgRatifyStateL . rsEnactStateL . ensConstitutionL + +data GovRole + = SPO + | DRep + | CC + +pparamsUpdateThreshold :: + forall era. + ConwayEraPParams era => + PParams era -> + PParamsUpdate era -> + UnitInterval +pparamsUpdateThreshold pp ppu = + let thresholdLens = \case + NetworkGroup -> dvtPPNetworkGroupL + GovernanceGroup -> dvtPPGovGroupL + TechnicalGroup -> dvtPPTechnicalGroupL + EconomicGroup -> dvtPPEconomicGroupL + lookupGroupThreshold grp = + pp ^. ppDRepVotingThresholdsL . thresholdLens grp + in maximum $ + Set.map lookupGroupThreshold $ + modifiedGroups @era ppu + +threshold :: + ConwayEraPParams era => + RatifyState era -> + GovAction era -> + GovRole -> + StrictMaybe UnitInterval +threshold rSt action role = + let pp = rSt ^. rsEnactStateL . ensCurPParamsL + DRepVotingThresholds {..} = pp ^. ppDRepVotingThresholdsL + PoolVotingThresholds {..} = pp ^. ppPoolVotingThresholdsL + committee = rSt ^. rsEnactStateL . ensCommitteeL + ccThreshold = committeeQuorum <$> committee + in case (action, role) of + (NoConfidence {}, CC) -> SJust minBound + (NoConfidence {}, DRep) -> SJust dvtCommitteeNoConfidence + (NoConfidence {}, SPO) -> SJust pvtCommitteeNoConfidence + (NewCommittee {}, CC) -> SJust minBound + (NewCommittee {}, DRep) -> SJust $ + case committee of + SJust _ -> dvtCommitteeNormal + SNothing -> dvtCommitteeNoConfidence + (NewCommittee {}, SPO) -> SJust $ + case committee of + SJust _ -> pvtCommitteeNormal + SNothing -> pvtCommitteeNoConfidence + (NewConstitution {}, CC) -> ccThreshold + (NewConstitution {}, DRep) -> SJust dvtUpdateToConstitution + (NewConstitution {}, SPO) -> SJust minBound + (HardForkInitiation {}, CC) -> ccThreshold + (HardForkInitiation {}, DRep) -> SJust dvtHardForkInitiation + (HardForkInitiation {}, SPO) -> SJust pvtHardForkInitiation + (ParameterChange {}, CC) -> ccThreshold + (ParameterChange _ ppu, DRep) -> SJust $ pparamsUpdateThreshold pp ppu + (ParameterChange {}, SPO) -> SJust minBound + (TreasuryWithdrawals {}, CC) -> ccThreshold + (TreasuryWithdrawals {}, DRep) -> SJust dvtTreasuryWithdrawal + (TreasuryWithdrawals {}, SPO) -> SJust minBound + (InfoAction {}, _) -> SNothing diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs index 58360a4320b..cd43d035e00 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/PParams.hs @@ -36,7 +36,6 @@ where import Cardano.Ledger.Alonzo.PParams (OrdExUnits (..)) import Cardano.Ledger.Alonzo.Scripts (CostModels, ExUnits (..), Prices (Prices), emptyCostModels) import Cardano.Ledger.Babbage (BabbageEra) -import Cardano.Ledger.Babbage.Core hiding (Value) import Cardano.Ledger.Babbage.PParams import Cardano.Ledger.BaseTypes (EpochNo (EpochNo), NonNegativeInterval, ProtVer (ProtVer), UnitInterval) import Cardano.Ledger.Binary @@ -294,6 +293,39 @@ instance Crypto c => BabbageEraPParams (ConwayEra c) where hkdCoinsPerUTxOByteL = lens cppCoinsPerUTxOByte (\pp x -> pp {cppCoinsPerUTxOByte = x}) instance Crypto c => ConwayEraPParams (ConwayEra c) where + pparamsGroups (PParamsUpdate ConwayPParams {..}) = + ConwayPParams + <$> pGroup EconomicGroup cppMinFeeA + <*> pGroup EconomicGroup cppMinFeeB + <*> pGroup NetworkGroup cppMaxBBSize + <*> pGroup NetworkGroup cppMaxTxSize + <*> pGroup NetworkGroup cppMaxBHSize + <*> pGroup EconomicGroup cppKeyDeposit + <*> pGroup EconomicGroup cppPoolDeposit + <*> pGroup TechnicalGroup cppEMax + <*> pGroup TechnicalGroup cppNOpt + <*> pGroup TechnicalGroup cppA0 + <*> pGroup EconomicGroup cppRho + <*> pGroup EconomicGroup cppTau + <*> pUngrouped + <*> pGroup EconomicGroup cppMinPoolCost + <*> pGroup EconomicGroup cppCoinsPerUTxOByte + <*> pGroup TechnicalGroup cppCostModels + <*> pGroup EconomicGroup cppPrices + <*> pGroup NetworkGroup cppMaxTxExUnits + <*> pGroup NetworkGroup cppMaxBlockExUnits + <*> pGroup NetworkGroup cppMaxValSize + <*> pGroup TechnicalGroup cppCollateralPercentage + <*> pGroup NetworkGroup cppMaxCollateralInputs + <*> pGroup GovernanceGroup cppPoolVotingThresholds + <*> pGroup GovernanceGroup cppDRepVotingThresholds + <*> pGroup GovernanceGroup cppMinCommitteeSize + <*> pGroup GovernanceGroup cppCommitteeTermLimit + <*> pGroup GovernanceGroup cppGovActionExpiration + <*> pGroup GovernanceGroup cppGovActionDeposit + <*> pGroup GovernanceGroup cppDRepDeposit + <*> pGroup GovernanceGroup cppDRepActivity + ppuWellFormed ppu = and [ -- Numbers diff --git a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs index 984916a7913..5bfa3e14757 100644 --- a/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs +++ b/eras/conway/impl/src/Cardano/Ledger/Conway/Rules/Ratify.hs @@ -6,7 +6,9 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -21,16 +23,19 @@ module Cardano.Ledger.Conway.Rules.Ratify ( dRepAcceptedRatio, ) where -import Cardano.Ledger.BaseTypes (ShelleyBase) +import Cardano.Ledger.BaseTypes (BoundedRational (..), ShelleyBase, StrictMaybe (..)) import Cardano.Ledger.CertState (DRepState (..)) import Cardano.Ledger.Coin (Coin (..), CompactForm (..)) +import Cardano.Ledger.Conway.Core (ConwayEraPParams) import Cardano.Ledger.Conway.Era (ConwayENACT, ConwayRATIFY) import Cardano.Ledger.Conway.Governance ( EraGov, GovAction (..), GovActionState (..), + GovRole (..), RatifyState (..), Vote (..), + threshold, ) import Cardano.Ledger.Conway.Rules.Enact (EnactPredFailure, EnactState (..)) import Cardano.Ledger.Core @@ -62,12 +67,13 @@ data RatifyEnv era = RatifyEnv , reDRepState :: !(Map (Credential 'DRepRole (EraCrypto era)) (DRepState (EraCrypto era))) , reCurrentEpoch :: !EpochNo } - deriving (Show) + +deriving instance Show (RatifyEnv era) newtype RatifySignal era = RatifySignal (StrictSeq (GovActionState era)) instance - ( Era era + ( ConwayEraPParams era , Embed (EraRule "ENACT" era) (ConwayRATIFY era) , State (EraRule "ENACT" era) ~ EnactState era , Environment (EraRule "ENACT" era) ~ () @@ -89,16 +95,16 @@ instance -- ccThreshold :: Int -- ccThreshold = 0 --- Temporary threshold of 1 lovelace -spoThreshold :: Rational -spoThreshold = 51 % 100 - -dRepThreshold :: Rational -dRepThreshold = 51 % 100 - -spoAccepted :: RatifyEnv era -> GovActionState era -> Bool -spoAccepted RatifyEnv {reStakePoolDistr = PoolDistr poolDistr} gas = - totalAcceptedStakePoolsRatio > getStakePoolThreshold gasAction +spoAccepted :: + ConwayEraPParams era => + RatifyState era -> + RatifyEnv era -> + GovActionState era -> + Bool +spoAccepted rs RatifyEnv {reStakePoolDistr = PoolDistr poolDistr} gas = + case threshold rs gasAction SPO of + SJust r -> totalAcceptedStakePoolsRatio > unboundRational r + SNothing -> False where GovActionState {gasStakePoolVotes, gasAction} = gas -- Final ratio for `totalAcceptedStakePoolsRatio` we want is: t = y / (s - a) @@ -130,14 +136,14 @@ spoAccepted RatifyEnv {reStakePoolDistr = PoolDistr poolDistr} gas = VoteNo -> Nothing VoteYes -> Just (distr, mempty) Abstain -> Just (mempty, distr) - getStakePoolThreshold = \case - -- Disable HardForks for now, in order to prevent SanchoNet from dying - HardForkInitiation {} -> 101 % 100 - _ -> spoThreshold -dRepAccepted :: forall era. RatifyEnv era -> GovActionState era -> Rational -> Bool -dRepAccepted ratifyEnv GovActionState {gasDRepVotes, gasAction} threshold = - dRepAcceptedRatio ratifyEnv gasDRepVotes gasAction >= threshold +dRepAccepted :: forall era. ConwayEraPParams era => RatifyEnv era -> RatifyState era -> GovActionState era -> Bool +dRepAccepted re rs GovActionState {gasDRepVotes, gasAction} = + case threshold rs gasAction DRep of + SJust r -> + dRepAcceptedRatio re gasDRepVotes gasAction + >= unboundRational r + SNothing -> False -- Compute the dRep ratio yes/(yes + no), where -- yes: is the total stake of @@ -190,7 +196,7 @@ ratifyTransition :: , State (EraRule "ENACT" era) ~ EnactState era , Environment (EraRule "ENACT" era) ~ () , Signal (EraRule "ENACT" era) ~ GovAction era - , Era era + , ConwayEraPParams era ) => TransitionRule (ConwayRATIFY era) ratifyTransition = do @@ -200,11 +206,10 @@ ratifyTransition = do , RatifySignal rsig ) <- judgmentContext - case rsig of ast :<| sigs -> do - let GovActionState {gasAction, gasExpiresAfter} = ast - if spoAccepted env ast && dRepAccepted env ast dRepThreshold + let gas@GovActionState {gasAction, gasExpiresAfter} = ast + if spoAccepted st env gas && dRepAccepted env st gas then do -- Update ENACT state with the governance action that was ratified es <- trans @(EraRule "ENACT" era) $ TRC ((), rsEnactState, gasAction) diff --git a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/RatifySpec.hs b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/RatifySpec.hs index 028b776e4b8..86b5de5f3fb 100644 --- a/eras/conway/impl/test/Test/Cardano/Ledger/Conway/RatifySpec.hs +++ b/eras/conway/impl/test/Test/Cardano/Ledger/Conway/RatifySpec.hs @@ -14,9 +14,9 @@ import Cardano.Ledger.BaseTypes (EpochNo (..), StrictMaybe (..)) import Cardano.Ledger.Coin (Coin (..), CompactForm (..)) import Cardano.Ledger.Compactible (Compactible (..)) import Cardano.Ledger.Conway +import Cardano.Ledger.Conway.Core (ConwayEraPParams) import Cardano.Ledger.Conway.Governance ( GovAction (..), - GovActionState (..), Vote (..), ) import Cardano.Ledger.Conway.Rules (RatifyEnv (..), dRepAccepted, dRepAcceptedRatio) @@ -141,21 +141,19 @@ drepsPropAllYes = drepsPropNoStake :: forall era. - ( EraPParams era - , Arbitrary (PParamsHKD StrictMaybe era) + ( Arbitrary (PParamsHKD StrictMaybe era) , Arbitrary (PParamsHKD Identity era) + , ConwayEraPParams era ) => Spec drepsPropNoStake = prop "If there is no stake, accept only if the threshold is zero" $ - forAll - ((,) <$> arbitrary @(RatifyEnv era) <*> arbitrary @(GovActionState era)) - ( \(env, gas) -> do - dRepAccepted @era env {reDRepDistr = Map.empty} gas 0 - `shouldBe` True - dRepAccepted @era env {reDRepDistr = Map.empty} gas (1 % 2) - `shouldBe` False - ) + ( \(env, st, gas) -> do + dRepAccepted @era env {reDRepDistr = Map.empty} st gas + `shouldBe` True + dRepAccepted @era env {reDRepDistr = Map.empty} st gas + `shouldBe` False + ) activeDRepAcceptedRatio :: forall era. DRepTestData era -> Rational activeDRepAcceptedRatio (DRepTestData {..}) = diff --git a/libs/cardano-ledger-core/cardano-ledger-core.cabal b/libs/cardano-ledger-core/cardano-ledger-core.cabal index 19d097ccf0e..220ec1eb3fd 100644 --- a/libs/cardano-ledger-core/cardano-ledger-core.cabal +++ b/libs/cardano-ledger-core/cardano-ledger-core.cabal @@ -27,6 +27,7 @@ flag asserts library exposed-modules: Cardano.Ledger.Address + Cardano.Ledger.Ap Cardano.Ledger.CompactAddress Cardano.Ledger.AuxiliaryData Cardano.Ledger.BaseTypes diff --git a/libs/cardano-ledger-core/src/Cardano/Ledger/Ap.hs b/libs/cardano-ledger-core/src/Cardano/Ledger/Ap.hs new file mode 100644 index 00000000000..129ce745aab --- /dev/null +++ b/libs/cardano-ledger-core/src/Cardano/Ledger/Ap.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE GADTs #-} +{-# LANGUAGE RankNTypes #-} + +-- | This is taken from Edward Kmett's `free` library +-- See: https://hackage.haskell.org/package/free-5.2 + +module Cardano.Ledger.Ap ( + Ap (..), + hoistAp, + runAp, + runAp_, +) where + + +-------------------------------------------------------------------------------- +-- | +-- A faster free applicative. +-- Based on . +-------------------------------------------------------------------------------- +import Control.Applicative + +-- | The free applicative is composed of a sequence of effects, +-- and a pure function to apply that sequence to. +-- The fast free applicative separates these from each other, +-- so that the sequence may be built up independently, +-- and so that 'fmap' can run in constant time by having immediate access to the pure function. +data ASeq f a where + ANil :: ASeq f () + ACons :: f a -> ASeq f u -> ASeq f (a,u) + +-- | Interprets the sequence of effects using the semantics for +-- `pure` and `<*>` given by the Applicative instance for 'f'. +reduceASeq :: Applicative f => ASeq f u -> f u +reduceASeq ANil = pure () +reduceASeq (ACons x xs) = (,) <$> x <*> reduceASeq xs + +-- | Given a natural transformation from @f@ to @g@ this gives a natural transformation from @ASeq f@ to @ASeq g@. +hoistASeq :: (forall x. f x -> g x) -> ASeq f a -> ASeq g a +hoistASeq _ ANil = ANil +hoistASeq u (ACons x xs) = ACons (u x) (u `hoistASeq` xs) + +-- | It may not be obvious, but this essentially acts like ++, +-- traversing the first sequence and creating a new one by appending the second sequence. +-- The difference is that this also has to modify the return functions and that the return type depends on the input types. +-- +-- See the source of 'hoistAp' as an example usage. +rebaseASeq :: ASeq f u -> (forall x. (x -> y) -> ASeq f x -> z) -> + (v -> u -> y) -> ASeq f v -> z +rebaseASeq ANil k f = k (`f` ()) +rebaseASeq (ACons x xs) k f = + rebaseASeq xs (\g s -> k (\(a,u) -> g u a) (ACons x s)) + (\v u a -> f v (a,u)) + + +-- | The faster free 'Applicative'. +newtype Ap f a = Ap + { unAp :: forall u y z. + (forall x. (x -> y) -> ASeq f x -> z) -> + (u -> a -> y) -> ASeq f u -> z } + +-- | Given a natural transformation from @f@ to @g@, this gives a canonical monoidal natural transformation from @'Ap' f@ to @g@. +-- +-- prop> runAp t == retractApp . hoistApp t +runAp :: Applicative g => (forall x. f x -> g x) -> Ap f a -> g a +runAp u = retractAp . hoistAp u + +-- | Perform a monoidal analysis over free applicative value. +-- +-- Example: +-- +-- @ +-- count :: Ap f a -> Int +-- count = getSum . runAp_ (\\_ -> Sum 1) +-- @ +runAp_ :: Monoid m => (forall a. f a -> m) -> Ap f b -> m +runAp_ f = getConst . runAp (Const . f) + +instance Functor (Ap f) where + fmap g x = Ap (\k f -> unAp x k (\s -> f s . g)) + +instance Applicative (Ap f) where + pure a = Ap (\k f -> k (`f` a)) + x <*> y = Ap (\k f -> unAp y (unAp x k) (\s a g -> f s (g a))) + +-- | Given a natural transformation from @f@ to @g@ this gives a monoidal natural transformation from @Ap f@ to @Ap g@. +hoistAp :: (forall x. f x -> g x) -> Ap f a -> Ap g a +hoistAp g x = Ap (\k f s -> + unAp x + (\f' s' -> + rebaseASeq (hoistASeq g s') k + (\v u -> f v (f' u)) s) + (const id) + ANil) + +-- | Interprets the free applicative functor over f using the semantics for +-- `pure` and `<*>` given by the Applicative instance for f. +-- +-- prop> retractApp == runAp id +retractAp :: Applicative f => Ap f a -> f a +retractAp x = unAp x (\f s -> f <$> reduceASeq s) (\() -> id) ANil