{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Ouroboros.Consensus.Ledger.Inspect
  ( InspectLedger (..)
  , LedgerEvent (..)
  , castLedgerEvent
  , partitionLedgerEvents
  ) where

import Data.Either
import Data.Kind (Type)
import Data.Void
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.Abstract
import Ouroboros.Consensus.Util.Condense
import Ouroboros.Consensus.Util.RedundantConstraints

data LedgerEvent blk
  = LedgerWarning (LedgerWarning blk)
  | LedgerUpdate (LedgerUpdate blk)

deriving instance InspectLedger blk => Show (LedgerEvent blk)
deriving instance InspectLedger blk => Eq (LedgerEvent blk)

castLedgerEvent ::
  ( LedgerWarning blk ~ LedgerWarning blk'
  , LedgerUpdate blk ~ LedgerUpdate blk'
  ) =>
  LedgerEvent blk -> LedgerEvent blk'
castLedgerEvent :: forall blk blk'.
(LedgerWarning blk ~ LedgerWarning blk',
 LedgerUpdate blk ~ LedgerUpdate blk') =>
LedgerEvent blk -> LedgerEvent blk'
castLedgerEvent (LedgerWarning LedgerWarning blk
warning) = LedgerWarning blk' -> LedgerEvent blk'
forall blk. LedgerWarning blk -> LedgerEvent blk
LedgerWarning LedgerWarning blk
LedgerWarning blk'
warning
castLedgerEvent (LedgerUpdate LedgerUpdate blk
update) = LedgerUpdate blk' -> LedgerEvent blk'
forall blk. LedgerUpdate blk -> LedgerEvent blk
LedgerUpdate LedgerUpdate blk
LedgerUpdate blk'
update

ledgerEventToEither ::
  LedgerEvent blk ->
  Either (LedgerWarning blk) (LedgerUpdate blk)
ledgerEventToEither :: forall blk.
LedgerEvent blk -> Either (LedgerWarning blk) (LedgerUpdate blk)
ledgerEventToEither (LedgerWarning LedgerWarning blk
warning) = LedgerWarning blk -> Either (LedgerWarning blk) (LedgerUpdate blk)
forall a b. a -> Either a b
Left LedgerWarning blk
warning
ledgerEventToEither (LedgerUpdate LedgerUpdate blk
update) = LedgerUpdate blk -> Either (LedgerWarning blk) (LedgerUpdate blk)
forall a b. b -> Either a b
Right LedgerUpdate blk
update

partitionLedgerEvents ::
  [LedgerEvent blk] ->
  ([LedgerWarning blk], [LedgerUpdate blk])
partitionLedgerEvents :: forall blk.
[LedgerEvent blk] -> ([LedgerWarning blk], [LedgerUpdate blk])
partitionLedgerEvents = [Either (LedgerWarning blk) (LedgerUpdate blk)]
-> ([LedgerWarning blk], [LedgerUpdate blk])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either (LedgerWarning blk) (LedgerUpdate blk)]
 -> ([LedgerWarning blk], [LedgerUpdate blk]))
-> ([LedgerEvent blk]
    -> [Either (LedgerWarning blk) (LedgerUpdate blk)])
-> [LedgerEvent blk]
-> ([LedgerWarning blk], [LedgerUpdate blk])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (LedgerEvent blk -> Either (LedgerWarning blk) (LedgerUpdate blk))
-> [LedgerEvent blk]
-> [Either (LedgerWarning blk) (LedgerUpdate blk)]
forall a b. (a -> b) -> [a] -> [b]
map LedgerEvent blk -> Either (LedgerWarning blk) (LedgerUpdate blk)
forall blk.
LedgerEvent blk -> Either (LedgerWarning blk) (LedgerUpdate blk)
ledgerEventToEither

class
  ( Show (LedgerWarning blk)
  , Show (LedgerUpdate blk)
  , Eq (LedgerWarning blk)
  , Eq (LedgerUpdate blk)
  , Condense (LedgerUpdate blk)
  ) =>
  InspectLedger blk
  where
  type LedgerWarning blk :: Type
  type LedgerUpdate blk :: Type

  -- | Inspect the ledger
  --
  -- The point of the inspection is to see if the state of the ledger might
  -- indicate a potential misconfiguration of the node.
  --
  -- TODO: We might at some point need to generalize this to 'ExtLedgerState'
  -- instead. That doesn't fit quite so neatly with the HFC at present, so
  -- leaving it at this for now.
  inspectLedger ::
    TopLevelConfig blk ->
    -- | Before
    LedgerState blk mk1 ->
    -- | After
    LedgerState blk mk2 ->
    [LedgerEvent blk]

  -- Defaults
  -- The defaults just use no events at all

  type LedgerWarning blk = Void
  type LedgerUpdate blk = Void

  default inspectLedger ::
    ( LedgerWarning blk ~ Void
    , LedgerUpdate blk ~ Void
    ) =>
    TopLevelConfig blk ->
    -- | Before
    LedgerState blk mk1 ->
    -- | After
    LedgerState blk mk2 ->
    [LedgerEvent blk]
  inspectLedger TopLevelConfig blk
_ LedgerState blk mk1
_ LedgerState blk mk2
_ = []
   where
    ()
_ = Proxy (LedgerWarning blk ~ Void) -> ()
forall (c :: Constraint) (proxy :: Constraint -> *).
c =>
proxy c -> ()
keepRedundantConstraint (forall {k} (t :: k). Proxy t
forall (t :: Constraint). Proxy t
Proxy @(LedgerWarning blk ~ Void))
    ()
_ = Proxy (LedgerUpdate blk ~ Void) -> ()
forall (c :: Constraint) (proxy :: Constraint -> *).
c =>
proxy c -> ()
keepRedundantConstraint (forall {k} (t :: k). Proxy t
forall (t :: Constraint). Proxy t
Proxy @(LedgerUpdate blk ~ Void))