{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Ledger.Block (
  Block (Block),
  bheader,
  bbody,
  neededTxInsForBlock,
)
where

import Cardano.Ledger.Binary (
  DecCBOR (decCBOR),
  EncCBOR (..),
  EncCBORGroup (..),
  decodeRecordNamed,
  encodeListLen,
  toPlainEncoding,
 )
import qualified Cardano.Ledger.Binary.Plain as Plain
import Cardano.Ledger.Core
import Cardano.Ledger.TxIn (TxIn (..))
import Data.Foldable (toList)
import Data.Set (Set)
import qualified Data.Set as Set
import GHC.Generics (Generic)
import Lens.Micro ((^.))
import NoThunks.Class (NoThunks (..))

data Block h era
  = Block !h !(TxSeq era)
  deriving (forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall h era x. Rep (Block h era) x -> Block h era
forall h era x. Block h era -> Rep (Block h era) x
$cto :: forall h era x. Rep (Block h era) x -> Block h era
$cfrom :: forall h era x. Block h era -> Rep (Block h era) x
Generic)

deriving stock instance
  (Era era, Show (TxSeq era), Show h) =>
  Show (Block h era)

deriving stock instance
  (Era era, Eq (TxSeq era), Eq h) =>
  Eq (Block h era)

deriving anyclass instance
  ( Era era
  , NoThunks (TxSeq era)
  , NoThunks h
  ) =>
  NoThunks (Block h era)

instance
  forall era h.
  ( Era era
  , EncCBORGroup (TxSeq era)
  , EncCBOR h
  ) =>
  EncCBOR (Block h era)
  where
  encCBOR :: Block h era -> Encoding
encCBOR (Block h
h TxSeq era
txns) =
    Word -> Encoding
encodeListLen (Word
1 forall a. Num a => a -> a -> a
+ forall a. EncCBORGroup a => a -> Word
listLen TxSeq era
txns) forall a. Semigroup a => a -> a -> a
<> forall a. EncCBOR a => a -> Encoding
encCBOR h
h forall a. Semigroup a => a -> a -> a
<> forall a. EncCBORGroup a => a -> Encoding
encCBORGroup TxSeq era
txns

instance
  forall era h.
  ( Era era
  , EncCBORGroup (TxSeq era)
  , EncCBOR h
  ) =>
  Plain.ToCBOR (Block h era)
  where
  toCBOR :: Block h era -> Encoding
toCBOR = Version -> Encoding -> Encoding
toPlainEncoding (forall era. Era era => Version
eraProtVerLow @era) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. EncCBOR a => a -> Encoding
encCBOR

instance
  ( EraSegWits era
  , DecCBOR h
  ) =>
  DecCBOR (Block h era)
  where
  decCBOR :: forall s. Decoder s (Block h era)
decCBOR =
    forall a s. Text -> (a -> Int) -> Decoder s a -> Decoder s a
decodeRecordNamed Text
"Block" (forall a b. a -> b -> a
const Int
blockSize) forall a b. (a -> b) -> a -> b
$ forall h era. h -> TxSeq era -> Block h era
Block forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a s. DecCBOR a => Decoder s a
decCBOR forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a s. DecCBOR a => Decoder s a
decCBOR
    where
      blockSize :: Int
blockSize = Int
1 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall era. EraSegWits era => Word64
numSegComponents @era)

bheader ::
  Block h era ->
  h
bheader :: forall h era. Block h era -> h
bheader (Block h
bh TxSeq era
_) = h
bh

bbody :: Block h era -> TxSeq era
bbody :: forall h era. Block h era -> TxSeq era
bbody (Block h
_ TxSeq era
txs) = TxSeq era
txs

-- | The validity of any individual block depends only on a subset
-- of the UTxO stored in the ledger state. This function returns
-- the transaction inputs corresponding to the required UTxO for a
-- given Block.
--
-- This function will be used by the consensus layer to enable storing
-- the UTxO on disk. In particular, given a block, the consensus layer
-- will use 'neededTxInsForBlock' to retrieve the needed UTxO from disk
-- and present only those to the ledger.
neededTxInsForBlock ::
  forall h era.
  EraSegWits era =>
  Block h era ->
  Set TxIn
neededTxInsForBlock :: forall h era. EraSegWits era => Block h era -> Set TxIn
neededTxInsForBlock (Block h
_ TxSeq era
txsSeq) = forall a. (a -> Bool) -> Set a -> Set a
Set.filter TxIn -> Bool
isNotNewInput Set TxIn
allTxIns
  where
    txBodies :: [TxBody era]
txBodies = forall a b. (a -> b) -> [a] -> [b]
map (forall s a. s -> Getting a s a -> a
^. forall era. EraTx era => Lens' (Tx era) (TxBody era)
bodyTxL) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> [a]
toList forall a b. (a -> b) -> a -> b
$ forall era. EraSegWits era => TxSeq era -> StrictSeq (Tx era)
fromTxSeq TxSeq era
txsSeq
    allTxIns :: Set TxIn
allTxIns = forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall s a. s -> Getting a s a -> a
^. forall era. EraTxBody era => SimpleGetter (TxBody era) (Set TxIn)
allInputsTxBodyF) [TxBody era]
txBodies
    newTxIds :: Set TxId
newTxIds = forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall era. EraTxBody era => TxBody era -> TxId
txIdTxBody [TxBody era]
txBodies
    isNotNewInput :: TxIn -> Bool
isNotNewInput (TxIn TxId
txID TxIx
_) = TxId
txID forall a. Ord a => a -> Set a -> Bool
`Set.notMember` Set TxId
newTxIds