{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UndecidableSuperClasses #-}

module Ouroboros.Consensus.HardFork.Combinator.Abstract.CanHardFork
  ( CanHardFork (..)
  , HashSizeOfHead
  , rawHashNS
  ) where

import Data.ByteString.Short (ShortByteString)
import Data.Function (on)
import Data.Measure (Measure)
import Data.SOP.BasicFunctors (K (..))
import Data.SOP.Constraint
import Data.SOP.NonEmpty
import qualified Data.SOP.Strict as SOP
import Data.SOP.Tails (Tails)
import qualified Data.SOP.Tails as Tails
import Data.Typeable
import GHC.TypeNats (KnownNat)
import NoThunks.Class (NoThunks)
import Ouroboros.Consensus.Block (HashSize)
import Ouroboros.Consensus.HardFork.Combinator.Abstract.SingleEraBlock
import Ouroboros.Consensus.HardFork.Combinator.Protocol.ChainSel
import Ouroboros.Consensus.HardFork.Combinator.Translation
import Ouroboros.Consensus.Ledger.SupportsMempool
import Ouroboros.Consensus.TypeFamilyWrappers

{-------------------------------------------------------------------------------
  CanHardFork
-------------------------------------------------------------------------------}

-- | The hash size shared by all eras of a hard fork, represented by that of the
-- first era.
--
-- See 'EqualHashSizeOfHead' superclass constraint in 'CanHardFork' and the
-- @ConvertRawHash (HardForkBlock xs)@ instance.
type family HashSizeOfHead xs where
  HashSizeOfHead (x ': _) = HashSize x

-- | Witnesses that the hash size of @blk@ coincides with 'HashSizeOfHead' of
-- @xs@, i.e. with the hash size of the first era.
--
-- 'CanHardFork' requires @'All' ('EqualHashSizeOfHead' xs) xs@, which statically
-- guarantees that all eras of a hard fork use the same hash size. This lets the
-- @ConvertRawHash (HardForkBlock xs)@ instance enforce
-- @HashSize (HardForkBlock xs) = HashSizeOfHead xs@ without any runtime check.
class HashSize blk ~ HashSizeOfHead xs => EqualHashSizeOfHead xs blk

instance HashSize blk ~ HashSizeOfHead xs => EqualHashSizeOfHead xs blk

class
  ( All SingleEraBlock xs
  , All (EqualHashSizeOfHead xs) xs
  , KnownNat (HashSizeOfHead xs)
  , Typeable xs
  , IsNonEmpty xs
  , -- \* Phase1
    Measure (HardForkTxMeasurePhase1 xs)
  , HasByteSize (HardForkTxMeasurePhase1 xs)
  , NoThunks (HardForkTxMeasurePhase1 xs)
  , Show (HardForkTxMeasurePhase1 xs)
  , TxMeasurePhase1Metrics (HardForkTxMeasurePhase1 xs)
  , -- \* Phase2
    Measure (HardForkTxMeasurePhase2 xs)
  , NoThunks (HardForkTxMeasurePhase2 xs)
  , Show (HardForkTxMeasurePhase2 xs)
  , TxMeasurePhase2Metrics (HardForkTxMeasurePhase2 xs)
  ) =>
  CanHardFork xs
  where
  -- | A measure that can accurately represent the 'TxMeasure' of any era.
  --
  -- Usually, this can simply be the union of the sets of components of each
  -- individual era's 'TxMeasure'. (Which is too awkward of a type to express
  -- in Haskell.)
  type HardForkTxMeasurePhase1 xs

  type HardForkTxMeasurePhase2 xs

  hardForkEraTranslation :: EraTranslation xs
  hardForkChainSel :: Tails AcrossEraTiebreaker xs

  -- | This is ideally exact.
  --
  -- If that's not possible, the result must not be too small, since this is
  -- relied upon to determine which prefix of the mempool's txs will fit in a
  -- valid block.
  hardForkInjTxMeasurePhase1 :: SOP.NS WrapTxMeasurePhase1 xs -> HardForkTxMeasurePhase1 xs

  hardForkInjTxMeasurePhase2 :: SOP.NS WrapTxMeasurePhase2 xs -> HardForkTxMeasurePhase2 xs

  -- | Whether two transaction ids of @xs@ are equal, ignoring which era each
  -- sits in. Two txids in different eras can be equal; see the
  -- 'Ouroboros.Consensus.HardFork.Combinator.AcrossEras.OneEraGenTxId' 'Eq'
  -- instance.
  --
  -- Runs on every mempool lookup, so instances should avoid allocation.
  -- 'rawHashNS' is the reference implementation and allocates; the Cardano
  -- instance overrides it with an allocation-free walk. There is no class
  -- default: every instance names its body explicitly.
  hardForkEqGenTxId :: SOP.NS WrapGenTxId xs -> SOP.NS WrapGenTxId xs -> Bool

  -- | Order two transaction ids of @xs@. See 'hardForkEqGenTxId'.
  hardForkCompareGenTxId ::
    SOP.NS WrapGenTxId xs -> SOP.NS WrapGenTxId xs -> Ordering

-- | The raw hash of an era sum, era ignored.
--
-- The reference comparison for transaction ids. Non-optimizing 'CanHardFork'
-- instances implement 'hardForkEqGenTxId'\/'hardForkCompareGenTxId' by comparing
-- this hash. It serialises each id via 'toRawTxIdHash', which allocates.
rawHashNS :: All SingleEraBlock xs => SOP.NS WrapGenTxId xs -> ShortByteString
rawHashNS :: forall (xs :: [*]).
All SingleEraBlock xs =>
NS WrapGenTxId xs -> ShortByteString
rawHashNS = NS (K ShortByteString) xs -> ShortByteString
NS (K ShortByteString) xs -> CollapseTo NS ShortByteString
forall (xs :: [*]) a.
SListIN NS xs =>
NS (K a) xs -> CollapseTo NS a
forall k l (h :: (k -> *) -> l -> *) (xs :: l) a.
(HCollapse h, SListIN h xs) =>
h (K a) xs -> CollapseTo h a
SOP.hcollapse (NS (K ShortByteString) xs -> ShortByteString)
-> (NS WrapGenTxId xs -> NS (K ShortByteString) xs)
-> NS WrapGenTxId xs
-> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy SingleEraBlock
-> (forall a.
    SingleEraBlock a =>
    WrapGenTxId a -> K ShortByteString a)
-> NS WrapGenTxId xs
-> NS (K ShortByteString) xs
forall {k} {l} (h :: (k -> *) -> l -> *) (c :: k -> Constraint)
       (xs :: l) (proxy :: (k -> Constraint) -> *) (f :: k -> *)
       (f' :: k -> *).
(AllN (Prod h) c xs, HAp h) =>
proxy c
-> (forall (a :: k). c a => f a -> f' a) -> h f xs -> h f' xs
SOP.hcmap Proxy SingleEraBlock
proxySingle (ShortByteString -> K ShortByteString a
forall k a (b :: k). a -> K a b
K (ShortByteString -> K ShortByteString a)
-> (WrapGenTxId a -> ShortByteString)
-> WrapGenTxId a
-> K ShortByteString a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TxId (GenTx a) -> ShortByteString
forall tx. ConvertRawTxId tx => TxId tx -> ShortByteString
toRawTxIdHash (TxId (GenTx a) -> ShortByteString)
-> (WrapGenTxId a -> TxId (GenTx a))
-> WrapGenTxId a
-> ShortByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WrapGenTxId a -> TxId (GenTx a)
forall blk. WrapGenTxId blk -> GenTxId blk
unwrapGenTxId)

instance SingleEraBlock blk => CanHardFork '[blk] where
  type HardForkTxMeasurePhase1 '[blk] = TxMeasurePhase1 blk
  type HardForkTxMeasurePhase2 '[blk] = TxMeasurePhase2 blk

  hardForkEraTranslation :: EraTranslation '[blk]
hardForkEraTranslation = EraTranslation '[blk]
forall blk. EraTranslation '[blk]
trivialEraTranslation
  hardForkChainSel :: Tails AcrossEraTiebreaker '[blk]
hardForkChainSel = Tails AcrossEraTiebreaker '[blk]
forall {k} (f :: k -> k -> *) (x :: k). Tails f '[x]
Tails.mk1

  hardForkInjTxMeasurePhase1 :: NS WrapTxMeasurePhase1 '[blk] -> HardForkTxMeasurePhase1 '[blk]
hardForkInjTxMeasurePhase1 (SOP.Z (WrapTxMeasurePhase1 TxMeasurePhase1 x
x)) = TxMeasurePhase1 x
HardForkTxMeasurePhase1 '[blk]
x
  hardForkInjTxMeasurePhase2 :: NS WrapTxMeasurePhase2 '[blk] -> HardForkTxMeasurePhase2 '[blk]
hardForkInjTxMeasurePhase2 (SOP.Z (WrapTxMeasurePhase2 TxMeasurePhase2 x
x)) = TxMeasurePhase2 x
HardForkTxMeasurePhase2 '[blk]
x

  -- No production code uses a single-era hard fork, so an allocating raw-hash
  -- comparison is fine here.
  --
  -- NOTE: if some production code ever uses a single-era hard fork, it may
  -- want an allocation-free comparator here, as the Cardano instance has.
  hardForkEqGenTxId :: NS WrapGenTxId '[blk] -> NS WrapGenTxId '[blk] -> Bool
hardForkEqGenTxId = ShortByteString -> ShortByteString -> Bool
forall a. Eq a => a -> a -> Bool
(==) (ShortByteString -> ShortByteString -> Bool)
-> (NS WrapGenTxId '[blk] -> ShortByteString)
-> NS WrapGenTxId '[blk]
-> NS WrapGenTxId '[blk]
-> Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` NS WrapGenTxId '[blk] -> ShortByteString
forall (xs :: [*]).
All SingleEraBlock xs =>
NS WrapGenTxId xs -> ShortByteString
rawHashNS
  hardForkCompareGenTxId :: NS WrapGenTxId '[blk] -> NS WrapGenTxId '[blk] -> Ordering
hardForkCompareGenTxId = ShortByteString -> ShortByteString -> Ordering
forall a. Ord a => a -> a -> Ordering
compare (ShortByteString -> ShortByteString -> Ordering)
-> (NS WrapGenTxId '[blk] -> ShortByteString)
-> NS WrapGenTxId '[blk]
-> NS WrapGenTxId '[blk]
-> Ordering
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` NS WrapGenTxId '[blk] -> ShortByteString
forall (xs :: [*]).
All SingleEraBlock xs =>
NS WrapGenTxId xs -> ShortByteString
rawHashNS