{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Ledger.ShelleyMA
  ( ShelleyMAEra,
    MaryOrAllegra (..),
    TxOut,
    TxBody,
    AuxiliaryData,
    Shelley.PParams,
    Tx,
  )
where

import Cardano.Ledger.AuxiliaryData
  ( AuxiliaryDataHash (..),
    ValidateAuxiliaryData (..),
  )
import Cardano.Ledger.Coin (Coin)
import Cardano.Ledger.Compactible (Compactible)
import qualified Cardano.Ledger.Core as Core
import qualified Cardano.Ledger.Crypto as CryptoClass
import Cardano.Ledger.Era (Era (..), SupportsSegWit (..), ValidateScript (..))
import Cardano.Ledger.Mary.Value (Value, policies, policyID)
import Cardano.Ledger.SafeHash (hashAnnotated)
import Cardano.Ledger.Shelley (nativeMultiSigTag)
import qualified Cardano.Ledger.Shelley.BlockChain as Shelley
  ( TxSeq (..),
    bbHash,
    txSeqTxns,
  )
import Cardano.Ledger.Shelley.Constraints
  ( UsesPParams (..),
    UsesTxBody,
    UsesTxOut (..),
    UsesValue,
  )
import Cardano.Ledger.Shelley.Metadata (validMetadatum)
import qualified Cardano.Ledger.Shelley.PParams as Shelley
import Cardano.Ledger.Shelley.Scripts (ScriptHash)
import Cardano.Ledger.Shelley.Tx (Tx, TxOut (..), WitnessSet)
import Cardano.Ledger.ShelleyMA.AuxiliaryData
  ( AuxiliaryData,
    pattern AuxiliaryData,
  )
import Cardano.Ledger.ShelleyMA.Timelocks
  ( Timelock (..),
    validateTimelock,
  )
import Cardano.Ledger.ShelleyMA.TxBody (TxBody)
import Cardano.Ledger.Val (Val)
import Control.DeepSeq (deepseq)
import Data.Kind (Type)
import Data.Proxy (Proxy (..))
import qualified Data.Set as Set
import Data.Typeable (Typeable)
import GHC.Records (HasField (..))

-- ========================================

-- | The Shelley Mary/Allegra eras
--   The uninhabited type that indexes both the Mary and Allegra Eras.
data ShelleyMAEra (ma :: MaryOrAllegra) c

-- 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 MaryOrAllegra = Mary | Allegra

-- | The MAClass provides a method and a type, which implement the differences
--   between the Mary and Allegra instances
class
  ( Compactible (MAValue x c),
    Show (MAValue x c),
    Val (MAValue x c),
    Typeable x,
    CryptoClass.Crypto c
  ) =>
  MAClass (x :: MaryOrAllegra) c
  where
  type MAValue (x :: MaryOrAllegra) c :: Type
  getScriptHash :: Proxy x -> MAValue x c -> Set.Set (ScriptHash c)

instance CryptoClass.Crypto c => MAClass 'Mary c where
  type MAValue 'Mary c = Value c
  getScriptHash :: Proxy 'Mary -> MAValue 'Mary c -> Set (ScriptHash c)
getScriptHash Proxy 'Mary
Proxy MAValue 'Mary c
x = (PolicyID c -> ScriptHash c)
-> Set (PolicyID c) -> Set (ScriptHash c)
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map PolicyID c -> ScriptHash c
forall crypto. PolicyID crypto -> ScriptHash crypto
policyID (Value c -> Set (PolicyID c)
forall crypto. Value crypto -> Set (PolicyID crypto)
policies Value c
MAValue 'Mary c
x)

instance CryptoClass.Crypto c => MAClass 'Allegra c where
  type MAValue 'Allegra c = Coin
  getScriptHash :: Proxy 'Allegra -> MAValue 'Allegra c -> Set (ScriptHash c)
getScriptHash Proxy 'Allegra
_ MAValue 'Allegra c
_ = Set (ScriptHash c)
forall a. Set a
Set.empty

-- | The actual Mary and Allegra instances, rolled into one, the MAClass superclass
--   provides the era-specific code for where they differ.
instance
  forall c (ma :: MaryOrAllegra).
  (MAClass ma c) =>
  Era (ShelleyMAEra ma c)
  where
  type Crypto (ShelleyMAEra ma c) = c

  getTxOutEitherAddr :: TxOut (ShelleyMAEra ma c)
-> Either
     (Addr (Crypto (ShelleyMAEra ma c)))
     (CompactAddr (Crypto (ShelleyMAEra ma c)))
getTxOutEitherAddr (TxOutCompact a _) = CompactAddr c -> Either (Addr c) (CompactAddr c)
forall a b. b -> Either a b
Right CompactAddr c
CompactAddr (Crypto (ShelleyMAEra ma c))
a

  getAllTxInputs :: TxBody (ShelleyMAEra ma c)
-> Set (TxIn (Crypto (ShelleyMAEra ma c)))
getAllTxInputs = forall k (x :: k) r a. HasField x r a => r -> a
forall r a. HasField "inputs" r a => r -> a
getField @"inputs"

instance CryptoClass.Crypto c => UsesValue (ShelleyMAEra 'Mary c)

instance CryptoClass.Crypto c => UsesValue (ShelleyMAEra 'Allegra c)

instance CryptoClass.Crypto c => UsesTxOut (ShelleyMAEra 'Mary c) where
  makeTxOut :: Proxy (ShelleyMAEra 'Mary c)
-> Addr (Crypto (ShelleyMAEra 'Mary c))
-> Value (ShelleyMAEra 'Mary c)
-> TxOut (ShelleyMAEra 'Mary c)
makeTxOut Proxy (ShelleyMAEra 'Mary c)
_ Addr (Crypto (ShelleyMAEra 'Mary c))
a Value (ShelleyMAEra 'Mary c)
v = Addr (Crypto (ShelleyMAEra 'Mary c))
-> Value (ShelleyMAEra 'Mary c) -> TxOut (ShelleyMAEra 'Mary c)
forall era.
(Era era, Show (Value era), Compactible (Value era)) =>
Addr (Crypto era) -> Value era -> TxOut era
TxOut Addr (Crypto (ShelleyMAEra 'Mary c))
a Value (ShelleyMAEra 'Mary c)
v

instance CryptoClass.Crypto c => UsesTxOut (ShelleyMAEra 'Allegra c) where
  makeTxOut :: Proxy (ShelleyMAEra 'Allegra c)
-> Addr (Crypto (ShelleyMAEra 'Allegra c))
-> Value (ShelleyMAEra 'Allegra c)
-> TxOut (ShelleyMAEra 'Allegra c)
makeTxOut Proxy (ShelleyMAEra 'Allegra c)
_ Addr (Crypto (ShelleyMAEra 'Allegra c))
a Value (ShelleyMAEra 'Allegra c)
v = Addr (Crypto (ShelleyMAEra 'Allegra c))
-> Value (ShelleyMAEra 'Allegra c)
-> TxOut (ShelleyMAEra 'Allegra c)
forall era.
(Era era, Show (Value era), Compactible (Value era)) =>
Addr (Crypto era) -> Value era -> TxOut era
TxOut Addr (Crypto (ShelleyMAEra 'Allegra c))
a Value (ShelleyMAEra 'Allegra c)
v

instance CryptoClass.Crypto c => UsesPParams (ShelleyMAEra 'Mary c) where
  mergePPUpdates :: proxy (ShelleyMAEra 'Mary c)
-> PParams (ShelleyMAEra 'Mary c)
-> PParamsDelta (ShelleyMAEra 'Mary c)
-> PParams (ShelleyMAEra 'Mary c)
mergePPUpdates proxy (ShelleyMAEra 'Mary c)
_ = PParams (ShelleyMAEra 'Mary c)
-> PParamsDelta (ShelleyMAEra 'Mary c)
-> PParams (ShelleyMAEra 'Mary c)
forall era. PParams era -> PParamsUpdate era -> PParams era
Shelley.updatePParams

instance CryptoClass.Crypto c => UsesPParams (ShelleyMAEra 'Allegra c) where
  mergePPUpdates :: proxy (ShelleyMAEra 'Allegra c)
-> PParams (ShelleyMAEra 'Allegra c)
-> PParamsDelta (ShelleyMAEra 'Allegra c)
-> PParams (ShelleyMAEra 'Allegra c)
mergePPUpdates proxy (ShelleyMAEra 'Allegra c)
_ = PParams (ShelleyMAEra 'Allegra c)
-> PParamsDelta (ShelleyMAEra 'Allegra c)
-> PParams (ShelleyMAEra 'Allegra c)
forall era. PParams era -> PParamsUpdate era -> PParams era
Shelley.updatePParams

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

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

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

type instance
  Core.TxOut (ShelleyMAEra (ma :: MaryOrAllegra) c) =
    TxOut (ShelleyMAEra ma 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)

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

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

type instance
  Core.PParamsDelta (ShelleyMAEra (ma :: MaryOrAllegra) c) =
    Shelley.PParamsUpdate (ShelleyMAEra (ma :: MaryOrAllegra) c)

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

-- Since Timelock scripts are a strictly backwards compatible extension of
-- Multisig scripts, we can use the same 'scriptPrefixTag' tag here as
-- we did for the ValidateScript instance in Multisig which is imported
-- from:  Cardano.Ledger.Shelley(nativeMultiSigTag)

instance
  ( CryptoClass.Crypto c,
    UsesTxBody (ShelleyMAEra ma c),
    Core.AnnotatedData (Core.AuxiliaryData (ShelleyMAEra ma c))
  ) =>
  ValidateScript (ShelleyMAEra ma c)
  where
  scriptPrefixTag :: Script (ShelleyMAEra ma c) -> ByteString
scriptPrefixTag Script (ShelleyMAEra ma c)
_script = ByteString
nativeMultiSigTag -- "\x00"
  validateScript :: Script (ShelleyMAEra ma c) -> Tx (ShelleyMAEra ma c) -> Bool
validateScript Script (ShelleyMAEra ma c)
script Tx (ShelleyMAEra ma c)
tx = Timelock (Crypto (ShelleyMAEra ma c))
-> Tx (ShelleyMAEra ma c) -> Bool
forall era.
(UsesTxBody era, HasField "vldt" (TxBody era) ValidityInterval,
 HasField
   "addrWits" (Tx era) (Set (WitVKey 'Witness (Crypto era)))) =>
Timelock (Crypto era) -> Tx era -> Bool
validateTimelock @(ShelleyMAEra ma c) Script (ShelleyMAEra ma c)
Timelock (Crypto (ShelleyMAEra ma c))
script Tx (ShelleyMAEra ma c)
tx

-- Uses the default instance of hashScript

instance
  ( CryptoClass.Crypto c,
    MAClass ma c
  ) =>
  SupportsSegWit (ShelleyMAEra ma c)
  where
  type TxSeq (ShelleyMAEra ma c) = Shelley.TxSeq (ShelleyMAEra ma c)
  fromTxSeq :: TxSeq (ShelleyMAEra ma c) -> StrictSeq (Tx (ShelleyMAEra ma c))
fromTxSeq = TxSeq (ShelleyMAEra ma c) -> StrictSeq (Tx (ShelleyMAEra ma c))
forall era. TxSeq era -> StrictSeq (Tx era)
Shelley.txSeqTxns
  toTxSeq :: StrictSeq (Tx (ShelleyMAEra ma c)) -> TxSeq (ShelleyMAEra ma c)
toTxSeq = StrictSeq (Tx (ShelleyMAEra ma c)) -> TxSeq (ShelleyMAEra ma c)
forall era.
(Era era, SafeToHash (Witnesses era)) =>
StrictSeq (Tx era) -> TxSeq era
Shelley.TxSeq
  hashTxSeq :: TxSeq (ShelleyMAEra ma c)
-> Hash (HASH (Crypto (ShelleyMAEra ma c))) EraIndependentBlockBody
hashTxSeq = TxSeq (ShelleyMAEra ma c)
-> Hash (HASH (Crypto (ShelleyMAEra ma c))) EraIndependentBlockBody
forall era.
Era era =>
TxSeq era -> Hash (Crypto era) EraIndependentBlockBody
Shelley.bbHash
  numSegComponents :: Word64
numSegComponents = Word64
3

instance
  ( CryptoClass.Crypto c,
    Core.AnnotatedData (Core.Script (ShelleyMAEra ma c))
  ) =>
  ValidateAuxiliaryData (ShelleyMAEra (ma :: MaryOrAllegra) c) c
  where
  validateAuxiliaryData :: ProtVer -> AuxiliaryData (ShelleyMAEra ma c) -> Bool
validateAuxiliaryData ProtVer
_ (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
  hashAuxiliaryData :: AuxiliaryData (ShelleyMAEra ma c) -> AuxiliaryDataHash c
hashAuxiliaryData AuxiliaryData (ShelleyMAEra ma c)
aux = SafeHash c EraIndependentAuxiliaryData -> AuxiliaryDataHash c
forall crypto.
SafeHash crypto EraIndependentAuxiliaryData
-> AuxiliaryDataHash crypto
AuxiliaryDataHash (AuxiliaryData (ShelleyMAEra ma c)
-> SafeHash c EraIndependentAuxiliaryData
forall c i x.
(HasAlgorithm c, HashAnnotated x i c) =>
x -> SafeHash c i
hashAnnotated AuxiliaryData (ShelleyMAEra ma c)
AuxiliaryData (ShelleyMAEra ma c)
aux)

instance
  forall ma c.
  MAClass ma c =>
  HasField "minted" (TxBody (ShelleyMAEra (ma :: MaryOrAllegra) c)) (Set.Set (ScriptHash c))
  where
  getField :: TxBody (ShelleyMAEra ma c) -> Set (ScriptHash c)
getField TxBody (ShelleyMAEra ma c)
x = Proxy ma -> MAValue ma c -> Set (ScriptHash c)
forall (x :: MaryOrAllegra) c.
MAClass x c =>
Proxy x -> MAValue x c -> Set (ScriptHash c)
getScriptHash (Proxy ma
forall k (t :: k). Proxy t
Proxy @ma) (TxBody (ShelleyMAEra ma c) -> MAValue ma c
forall k (x :: k) r a. HasField x r a => r -> a
getField @"mint" TxBody (ShelleyMAEra ma c)
x)