{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE StandaloneDeriving    #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE TypeOperators         #-}
{-# LANGUAGE UndecidableInstances  #-}

-- | Interface to the ledger layer
module Ouroboros.Consensus.Ledger.Abstract (
    -- * Apply block
    ApplyBlock(..)
  , UpdateLedger
    -- ** Derived
  , tickThenApply
  , tickThenReapply
  , foldLedger
  , refoldLedger
    -- ** Short-hand
  , ledgerTipHash
  , ledgerTipPoint
  , ledgerTipSlot
    -- * Re-exports
  , module Ouroboros.Consensus.Ledger.Basics
  ) where

import           Control.Monad.Except
import           Data.Proxy
import           GHC.Stack (HasCallStack)

import           Ouroboros.Consensus.Block.Abstract
import           Ouroboros.Consensus.Ledger.Basics
import           Ouroboros.Consensus.Ticked
import           Ouroboros.Consensus.Util (repeatedly, repeatedlyM)

{-------------------------------------------------------------------------------
  Apply block to ledger state
-------------------------------------------------------------------------------}

class ( IsLedger l
      , HeaderHash l ~ HeaderHash blk
      , HasHeader blk
      , HasHeader (Header blk)
      ) => ApplyBlock l blk where

  -- | Apply a block to the ledger state.
  --
  -- This is passed the ledger state ticked with the slot of the given block,
  -- so 'applyChainTick' has already been called.
  applyLedgerBlock :: HasCallStack
                   => LedgerCfg l
                   -> blk -> Ticked l -> Except (LedgerErr l) l

  -- | Re-apply a block to the very same ledger state it was applied in before.
  --
  -- Since a block can only be applied to a single, specific, ledger state,
  -- if we apply a previously applied block again it will be applied in the
  -- very same ledger state, and therefore can't possibly fail.
  --
  -- It is worth noting that since we already know that the block is valid in
  -- the provided ledger state, the ledger layer should not perform /any/
  -- validation checks.
  reapplyLedgerBlock :: HasCallStack
                     => LedgerCfg l -> blk -> Ticked l -> l

-- | Interaction with the ledger layer
class ApplyBlock (LedgerState blk) blk => UpdateLedger blk

{-------------------------------------------------------------------------------
  Derived functionality
-------------------------------------------------------------------------------}

tickThenApply :: ApplyBlock l blk
              => LedgerCfg l -> blk -> l -> Except (LedgerErr l) l
tickThenApply :: LedgerCfg l -> blk -> l -> Except (LedgerErr l) l
tickThenApply LedgerCfg l
cfg blk
blk =
      LedgerCfg l -> blk -> Ticked l -> Except (LedgerErr l) l
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
LedgerCfg l -> blk -> Ticked l -> Except (LedgerErr l) l
applyLedgerBlock LedgerCfg l
cfg blk
blk
    (Ticked l -> Except (LedgerErr l) l)
-> (l -> Ticked l) -> l -> Except (LedgerErr l) l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerCfg l -> SlotNo -> l -> Ticked l
forall l. IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l
applyChainTick LedgerCfg l
cfg (blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
blk)

tickThenReapply :: ApplyBlock l blk
                => LedgerCfg l -> blk -> l -> l
tickThenReapply :: LedgerCfg l -> blk -> l -> l
tickThenReapply LedgerCfg l
cfg blk
blk =
      LedgerCfg l -> blk -> Ticked l -> l
forall l blk.
(ApplyBlock l blk, HasCallStack) =>
LedgerCfg l -> blk -> Ticked l -> l
reapplyLedgerBlock LedgerCfg l
cfg blk
blk
    (Ticked l -> l) -> (l -> Ticked l) -> l -> l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerCfg l -> SlotNo -> l -> Ticked l
forall l. IsLedger l => LedgerCfg l -> SlotNo -> l -> Ticked l
applyChainTick LedgerCfg l
cfg (blk -> SlotNo
forall b. HasHeader b => b -> SlotNo
blockSlot blk
blk)

foldLedger :: ApplyBlock l blk
           => LedgerCfg l -> [blk] -> l -> Except (LedgerErr l) l
foldLedger :: LedgerCfg l -> [blk] -> l -> Except (LedgerErr l) l
foldLedger = (blk -> l -> Except (LedgerErr l) l)
-> [blk] -> l -> Except (LedgerErr l) l
forall (m :: * -> *) a b.
Monad m =>
(a -> b -> m b) -> [a] -> b -> m b
repeatedlyM ((blk -> l -> Except (LedgerErr l) l)
 -> [blk] -> l -> Except (LedgerErr l) l)
-> (LedgerCfg l -> blk -> l -> Except (LedgerErr l) l)
-> LedgerCfg l
-> [blk]
-> l
-> Except (LedgerErr l) l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerCfg l -> blk -> l -> Except (LedgerErr l) l
forall l blk.
ApplyBlock l blk =>
LedgerCfg l -> blk -> l -> Except (LedgerErr l) l
tickThenApply

refoldLedger :: ApplyBlock l blk
             => LedgerCfg l -> [blk] -> l -> l
refoldLedger :: LedgerCfg l -> [blk] -> l -> l
refoldLedger = (blk -> l -> l) -> [blk] -> l -> l
forall a b. (a -> b -> b) -> [a] -> b -> b
repeatedly ((blk -> l -> l) -> [blk] -> l -> l)
-> (LedgerCfg l -> blk -> l -> l) -> LedgerCfg l -> [blk] -> l -> l
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerCfg l -> blk -> l -> l
forall l blk. ApplyBlock l blk => LedgerCfg l -> blk -> l -> l
tickThenReapply

{-------------------------------------------------------------------------------
  Short-hand
-------------------------------------------------------------------------------}

-- | Wrapper around 'ledgerTipPoint' that uses a proxy to fix @blk@
--
-- This is occassionally useful to guide type inference
ledgerTipPoint ::
     UpdateLedger blk
  => Proxy blk -> LedgerState blk -> Point blk
ledgerTipPoint :: Proxy blk -> LedgerState blk -> Point blk
ledgerTipPoint Proxy blk
_ = Point (LedgerState blk) -> Point blk
forall b b'.
Coercible (HeaderHash b) (HeaderHash b') =>
Point b -> Point b'
castPoint (Point (LedgerState blk) -> Point blk)
-> (LedgerState blk -> Point (LedgerState blk))
-> LedgerState blk
-> Point blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LedgerState blk -> Point (LedgerState blk)
forall l. GetTip l => l -> Point l
getTip

ledgerTipHash ::
     forall blk. UpdateLedger blk
  => LedgerState blk -> ChainHash blk
ledgerTipHash :: LedgerState blk -> ChainHash blk
ledgerTipHash = Point blk -> ChainHash blk
forall block. Point block -> ChainHash block
pointHash (Point blk -> ChainHash blk)
-> (LedgerState blk -> Point blk)
-> LedgerState blk
-> ChainHash blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Proxy blk -> LedgerState blk -> Point blk
forall blk.
UpdateLedger blk =>
Proxy blk -> LedgerState blk -> Point blk
ledgerTipPoint (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk))

ledgerTipSlot ::
     forall blk. UpdateLedger blk
  => LedgerState blk -> WithOrigin SlotNo
ledgerTipSlot :: LedgerState blk -> WithOrigin SlotNo
ledgerTipSlot = Point blk -> WithOrigin SlotNo
forall block. Point block -> WithOrigin SlotNo
pointSlot (Point blk -> WithOrigin SlotNo)
-> (LedgerState blk -> Point blk)
-> LedgerState blk
-> WithOrigin SlotNo
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Proxy blk -> LedgerState blk -> Point blk
forall blk.
UpdateLedger blk =>
Proxy blk -> LedgerState blk -> Point blk
ledgerTipPoint (Proxy blk
forall k (t :: k). Proxy t
Proxy @blk))