{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Ledger.ShelleyMA where

import Cardano.Binary (toCBOR)
import Cardano.Crypto.Hash (castHash, hashWithSerialiser)
import Cardano.Ledger.AuxiliaryData
  ( AuxiliaryDataHash (..),
    ValidateAuxiliaryData (..),
  )
import qualified Cardano.Ledger.Core as Core
import qualified Cardano.Ledger.Crypto as CryptoClass
import Cardano.Ledger.Era (Crypto, Era)
import Cardano.Ledger.Mary.Value (Value)
import Cardano.Ledger.Shelley.Constraints (TxBodyConstraints)
import Cardano.Ledger.ShelleyMA.AuxiliaryData (AuxiliaryData, pattern AuxiliaryData)
import Cardano.Ledger.ShelleyMA.Timelocks
  ( Timelock (..),
    ValidityInterval,
    hashTimelockScript,
    validateTimelock,
  )
import Cardano.Ledger.ShelleyMA.TxBody (TxBody)
import Control.DeepSeq (deepseq)
import Data.Kind (Type)
import Data.Typeable (Typeable)
import GHC.Records (HasField)
import Shelley.Spec.Ledger.Coin (Coin)
import Shelley.Spec.Ledger.Metadata (validMetadatum)
import Shelley.Spec.Ledger.Tx
  ( ValidateScript (..),
  )

-- | The Shelley Mary/Allegra eras
--
-- Both eras are implemented within the same codebase, matching the formal
-- specification. They differ only in the @value@ type. Due to some annoying
-- issues with 'Coin' and 'Value' being of different kinds, we don't parametrise
-- over the value but instead over a closed kind 'MaryOrAllegra'. But this
-- should be transparent to the user.
data ShelleyMAEra (ma :: MaryOrAllegra) c

data MaryOrAllegra = Mary | Allegra

instance
  forall c (ma :: MaryOrAllegra).
  (Typeable ma, CryptoClass.Crypto c) =>
  Era (ShelleyMAEra ma c)
  where
  type Crypto (ShelleyMAEra ma c) = c

type family MAValue (x :: MaryOrAllegra) c :: Type where
  MAValue 'Allegra _ = Coin
  MAValue 'Mary c = Value c

--------------------------------------------------------------------------------
-- Core instances
--------------------------------------------------------------------------------

type instance Core.Value (ShelleyMAEra m c) = MAValue m c

type instance
  Core.TxBody (ShelleyMAEra (ma :: MaryOrAllegra) c) =
    TxBody (ShelleyMAEra ma c)

type instance
  Core.Script (ShelleyMAEra (_ma :: MaryOrAllegra) c) =
    Timelock c

type instance
  Core.AuxiliaryData (ShelleyMAEra (ma :: MaryOrAllegra) c) =
    AuxiliaryData (ShelleyMAEra (ma :: MaryOrAllegra) c)

--------------------------------------------------------------------------------
-- Ledger data instances
--------------------------------------------------------------------------------

instance
  ( CryptoClass.Crypto c,
    Typeable ma,
    TxBodyConstraints (ShelleyMAEra ma c),
    Core.AnnotatedData (Core.AuxiliaryData (ShelleyMAEra ma c)),
    (HasField "vldt" (Core.TxBody (ShelleyMAEra ma c)) ValidityInterval)
  ) =>
  ValidateScript (ShelleyMAEra ma c)
  where
  validateScript :: Script (ShelleyMAEra ma c) -> Tx (ShelleyMAEra ma c) -> Bool
validateScript Script (ShelleyMAEra ma c)
s Tx (ShelleyMAEra ma c)
tx = Timelock (Crypto (ShelleyMAEra ma c))
-> Tx (ShelleyMAEra ma c) -> Bool
forall era.
(TxBodyConstraints era,
 HasField "vldt" (TxBody era) ValidityInterval,
 ToCBOR (AuxiliaryData era)) =>
Timelock (Crypto era) -> Tx era -> Bool
validateTimelock Script (ShelleyMAEra ma c)
Timelock (Crypto (ShelleyMAEra ma c))
s Tx (ShelleyMAEra ma c)
tx
  hashScript :: Script (ShelleyMAEra ma c)
-> ScriptHash (Crypto (ShelleyMAEra ma c))
hashScript Script (ShelleyMAEra ma c)
s = Timelock c -> ScriptHash c
forall crypto.
Crypto crypto =>
Timelock crypto -> ScriptHash crypto
hashTimelockScript Script (ShelleyMAEra ma c)
Timelock c
s

instance
  ( CryptoClass.Crypto c,
    Typeable ma,
    Core.AnnotatedData (Core.Script (ShelleyMAEra ma c))
  ) =>
  ValidateAuxiliaryData (ShelleyMAEra (ma :: MaryOrAllegra) c)
  where
  hashAuxiliaryData :: AuxiliaryData (ShelleyMAEra ma c)
-> AuxiliaryDataHash (Crypto (ShelleyMAEra ma c))
hashAuxiliaryData = Hash (HASH c) EraIndependentMetadata -> AuxiliaryDataHash c
forall crypto.
Hash crypto EraIndependentMetadata -> AuxiliaryDataHash crypto
AuxiliaryDataHash (Hash (HASH c) EraIndependentMetadata -> AuxiliaryDataHash c)
-> (AuxiliaryData (ShelleyMAEra ma c)
    -> Hash (HASH c) EraIndependentMetadata)
-> AuxiliaryData (ShelleyMAEra ma c)
-> AuxiliaryDataHash c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash (HASH c) (AuxiliaryData (ShelleyMAEra ma c))
-> Hash (HASH c) EraIndependentMetadata
forall h a b. Hash h a -> Hash h b
castHash (Hash (HASH c) (AuxiliaryData (ShelleyMAEra ma c))
 -> Hash (HASH c) EraIndependentMetadata)
-> (AuxiliaryData (ShelleyMAEra ma c)
    -> Hash (HASH c) (AuxiliaryData (ShelleyMAEra ma c)))
-> AuxiliaryData (ShelleyMAEra ma c)
-> Hash (HASH c) EraIndependentMetadata
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AuxiliaryData (ShelleyMAEra ma c) -> Encoding)
-> AuxiliaryData (ShelleyMAEra ma c)
-> Hash (HASH c) (AuxiliaryData (ShelleyMAEra ma c))
forall h a. HashAlgorithm h => (a -> Encoding) -> a -> Hash h a
hashWithSerialiser AuxiliaryData (ShelleyMAEra ma c) -> Encoding
forall a. ToCBOR a => a -> Encoding
toCBOR
  validateAuxiliaryData :: AuxiliaryData (ShelleyMAEra ma c) -> Bool
validateAuxiliaryData (AuxiliaryData md as) = StrictSeq (Timelock c) -> Bool -> Bool
forall a b. NFData a => a -> b -> b
deepseq StrictSeq (Script (ShelleyMAEra ma c))
StrictSeq (Timelock c)
as (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Metadatum -> Bool) -> Map Word64 Metadatum -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Metadatum -> Bool
validMetadatum Map Word64 Metadatum
md