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

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 :: 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 :: 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 :: [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
    -> LedgerState    blk -- ^ Before
    -> LedgerState    blk -- ^ After
    -> [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
    -> LedgerState    blk -- ^ Before
    -> LedgerState    blk -- ^ After
    -> [LedgerEvent   blk]
  inspectLedger TopLevelConfig blk
_ LedgerState blk
_ LedgerState blk
_ = []
    where
      ()
_ = Proxy (LedgerWarning blk ~ Void) -> ()
forall (c :: Constraint) (proxy :: Constraint -> *).
c =>
proxy c -> ()
keepRedundantConstraint (Proxy (LedgerWarning blk ~ Void)
forall k (t :: k). Proxy t
Proxy @(LedgerWarning blk ~ Void))
      ()
_ = Proxy (LedgerUpdate blk ~ Void) -> ()
forall (c :: Constraint) (proxy :: Constraint -> *).
c =>
proxy c -> ()
keepRedundantConstraint (Proxy (LedgerUpdate blk ~ Void)
forall k (t :: k). Proxy t
Proxy @(LedgerUpdate  blk ~ Void))