Skip to content

Commit

Permalink
Use MKs in ouroboros-consensus-cardano
Browse files Browse the repository at this point in the history 
Co-authored-by: Nick Frisby <nick.frisby@iohk.io>
Co-authored-by: Damian Nadales <damian.nadales@iohk.io>
Co-authored-by: Joris Dral <joris@well-typed.com>

skip-checks: true
  • Loading branch information
@jasagredo @jorisdral
jasagredo authored and jorisdral committed Mar 21, 2023
1 parent 5331fb6 commit 9c7f3fc
Show file tree
Hide file tree
Showing 10 changed files with 762 additions and 181 deletions.
2 changes: 0 additions & 2 deletions ouroboros-consensus-byronspec/src/Ouroboros/Consensus/ByronSpec/Ledger/Ledger.hs
View file
@@ -1,11 +1,9 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeFamilies #-}

{-# OPTIONS -Wno-orphans #-}
Expand Down
4 changes: 4 additions & 0 deletions ouroboros-consensus-cardano/README.md
View file
Expand Up @@ -3,3 +3,7 @@
This package contains:

* `src` : Support for Hard Fork between Cardano eras.

* `tools/ledger-db-backends-checker`: simple tool (for the UTxO-HD feature) to
compare the contents of an in-memory backing store and an LMDB backing store
(i.e., it checks if they have the same slot number and values).
37 changes: 36 additions & 1 deletion ouroboros-consensus-cardano/ouroboros-consensus-cardano.cabal
View file
Expand Up @@ -32,7 +32,7 @@ library
Ouroboros.Consensus.Cardano.Condense
Ouroboros.Consensus.Cardano.CanHardFork
Ouroboros.Consensus.Cardano.Node
Ouroboros.Consensus.Cardano.ShelleyBased
Ouroboros.Consensus.Cardano.Tables

build-depends: base >=4.14 && <4.17
, bytestring >=0.10 && <0.12
Expand All @@ -45,12 +45,17 @@ library
, cardano-binary
, cardano-crypto-class
, cardano-data
, cardano-ledger-allegra
, cardano-ledger-alonzo
, cardano-ledger-babbage
, cardano-ledger-byron
, cardano-ledger-conway
, cardano-ledger-core
, cardano-ledger-shelley
, cardano-prelude
, cardano-protocol-tpraos
, cardano-slotting
, diff-containers

, ouroboros-consensus ^>=0.3
, ouroboros-consensus-protocol ^>=0.3
Expand All @@ -68,5 +73,35 @@ library
-Wredundant-constraints
-Wmissing-export-lists
-Wunused-packages
-Wno-unticked-promoted-constructors
if flag(asserts)
ghc-options: -fno-ignore-asserts

executable ledger-db-backends-checker
hs-source-dirs: tools/ledger-db-backends-checker
main-is: Main.hs
build-depends: base
, bytestring
, cardano-binary
, cardano-crypto-wrapper
, cardano-ledger-core
, cborg
, containers
, mtl
, optparse-applicative

, ouroboros-consensus
, ouroboros-consensus-cardano
, ouroboros-consensus-protocol
, ouroboros-consensus-shelley
, cardano-lmdb-simple
, cardano-lmdb
, cardano-slotting
, io-classes

default-language: Haskell2010
ghc-options: -Wall
-threaded
-rtsopts
"-with-rtsopts=-T -I0 -N2 -A16m"
-Wno-unticked-promoted-constructors
66 changes: 43 additions & 23 deletions ouroboros-consensus-cardano/src/Ouroboros/Consensus/Cardano/Block.hs
View file
Expand Up @@ -2,13 +2,17 @@
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE StandaloneKindSignatures #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
module Ouroboros.Consensus.Cardano.Block (
-- * Eras
CardanoEras
, CardanoShelleyEras
, module Ouroboros.Consensus.Shelley.Eras
, ShelleyBasedEras
-- * Block
, CardanoBlock
-- Note: by exporting the pattern synonyms as part of the matching data
Expand Down Expand Up @@ -66,6 +70,8 @@ module Ouroboros.Consensus.Cardano.Block (
, EraMismatch (..)
) where

import Data.Kind

import Data.SOP.Strict

import Ouroboros.Consensus.Block (BlockProtocol)
Expand All @@ -80,6 +86,8 @@ import Ouroboros.Consensus.TypeFamilyWrappers
import Ouroboros.Consensus.HardFork.Combinator
import Ouroboros.Consensus.HardFork.Combinator.AcrossEras
import qualified Ouroboros.Consensus.HardFork.Combinator.State as State
import Ouroboros.Consensus.HardFork.Combinator.Util.Functors
(Flip (..))

import Ouroboros.Consensus.Byron.Ledger.Block (ByronBlock)

Expand All @@ -97,8 +105,10 @@ import Ouroboros.Consensus.Shelley.Ledger (ShelleyBlock)
-- We parameterise over the crypto used in the post-Byron eras: @c@.
--
-- TODO: parameterise ByronBlock over crypto too
type CardanoEras :: Type -> [Type]
type CardanoEras c = ByronBlock ': CardanoShelleyEras c

type CardanoShelleyEras :: Type -> [Type]
type CardanoShelleyEras c =
'[ ShelleyBlock (TPraos c) (ShelleyEra c)
, ShelleyBlock (TPraos c) (AllegraEra c)
Expand All @@ -108,6 +118,16 @@ type CardanoShelleyEras c =
, ShelleyBlock (Praos c) (ConwayEra c)
]

type ShelleyBasedEras :: Type -> [Type]
type ShelleyBasedEras c =
'[ ShelleyEra c
, AllegraEra c
, MaryEra c
, AlonzoEra c
, BabbageEra c
, ConwayEra c
]

{-------------------------------------------------------------------------------
INTERNAL A tag function for each era
-------------------------------------------------------------------------------}
Expand Down Expand Up @@ -203,7 +223,7 @@ pattern TeleConway byron shelley allegra mary alonzo babbage x = TS byron (TS s
-- | /The/ Cardano block.
--
-- Thanks to the pattern synonyms, you can treat this as a sum type with
-- constructors 'BlockByron' and 'BlockShelley'.
-- constructors 'BlockByron', 'BlockShelley', etc.
--
-- > f :: CardanoBlock c -> _
-- > f (BlockByron b) = _
Expand Down Expand Up @@ -1040,63 +1060,63 @@ pattern CardanoLedgerConfig cfgByron cfgShelley cfgAllegra cfgMary cfgAlonzo cfg
-- 'LedgerState'. We don't give access to those internal details through the
-- pattern synonyms. This is also the reason the pattern synonyms are not
-- bidirectional.
type CardanoLedgerState c = LedgerState (CardanoBlock c)
type CardanoLedgerState c mk = LedgerState (CardanoBlock c) mk

pattern LedgerStateByron
:: LedgerState ByronBlock
-> CardanoLedgerState c
:: LedgerState ByronBlock mk
-> CardanoLedgerState c mk
pattern LedgerStateByron st <-
HardForkLedgerState
(State.HardForkState
(TeleByron (State.Current { currentState = st })))
(TeleByron (State.Current { currentState = Flip st })))

pattern LedgerStateShelley
:: LedgerState (ShelleyBlock (TPraos c) (ShelleyEra c))
-> CardanoLedgerState c
:: LedgerState (ShelleyBlock (TPraos c) (ShelleyEra c)) mk
-> CardanoLedgerState c mk
pattern LedgerStateShelley st <-
HardForkLedgerState
(State.HardForkState
(TeleShelley _ (State.Current { currentState = st })))
(TeleShelley _ (State.Current { currentState = Flip st })))

pattern LedgerStateAllegra
:: LedgerState (ShelleyBlock (TPraos c) (AllegraEra c))
-> CardanoLedgerState c
:: LedgerState (ShelleyBlock (TPraos c) (AllegraEra c)) mk
-> CardanoLedgerState c mk
pattern LedgerStateAllegra st <-
HardForkLedgerState
(State.HardForkState
(TeleAllegra _ _ (State.Current { currentState = st })))
(TeleAllegra _ _ (State.Current { currentState = Flip st })))

pattern LedgerStateMary
:: LedgerState (ShelleyBlock (TPraos c) (MaryEra c))
-> CardanoLedgerState c
:: LedgerState (ShelleyBlock (TPraos c) (MaryEra c)) mk
-> CardanoLedgerState c mk
pattern LedgerStateMary st <-
HardForkLedgerState
(State.HardForkState
(TeleMary _ _ _ (State.Current { currentState = st })))
(TeleMary _ _ _ (State.Current { currentState = Flip st })))

pattern LedgerStateAlonzo
:: LedgerState (ShelleyBlock (TPraos c) (AlonzoEra c))
-> CardanoLedgerState c
:: LedgerState (ShelleyBlock (TPraos c) (AlonzoEra c)) mk
-> CardanoLedgerState c mk
pattern LedgerStateAlonzo st <-
HardForkLedgerState
(State.HardForkState
(TeleAlonzo _ _ _ _ (State.Current { currentState = st })))
(TeleAlonzo _ _ _ _ (State.Current { currentState = Flip st })))

pattern LedgerStateBabbage
:: LedgerState (ShelleyBlock (Praos c) (BabbageEra c))
-> CardanoLedgerState c
:: LedgerState (ShelleyBlock (Praos c) (BabbageEra c)) mk
-> CardanoLedgerState c mk
pattern LedgerStateBabbage st <-
HardForkLedgerState
(State.HardForkState
(TeleBabbage _ _ _ _ _ (State.Current { currentState = st })))
(TeleBabbage _ _ _ _ _ (State.Current { currentState = Flip st })))

pattern LedgerStateConway
:: LedgerState (ShelleyBlock (Praos c) (ConwayEra c))
-> CardanoLedgerState c
:: LedgerState (ShelleyBlock (Praos c) (ConwayEra c)) mk
-> CardanoLedgerState c mk
pattern LedgerStateConway st <-
HardForkLedgerState
(State.HardForkState
(TeleConway _ _ _ _ _ _ (State.Current { currentState = st })))
(TeleConway _ _ _ _ _ _ (State.Current { currentState = Flip st })))

{-# COMPLETE LedgerStateByron
, LedgerStateShelley
Expand Down

0 comments on commit 9c7f3fc

Please sign in to comment.