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

module Cardano.Ledger.ShelleyMA.Rules.Utxow where

import Cardano.Ledger.BaseTypes
import qualified Cardano.Ledger.Core as Core
import Cardano.Ledger.Era (Era)
import Cardano.Ledger.Shelley.LedgerState (UTxOState)
import qualified Cardano.Ledger.Shelley.Rules.Ledger as Shelley
import Cardano.Ledger.Shelley.Rules.Utxo (UtxoEnv)
import Cardano.Ledger.Shelley.Rules.Utxow
  ( ShelleyStyleWitnessNeeds,
    UtxowEvent (..),
    UtxowPredicateFailure (..),
    transitionRulesUTXOW,
  )
import Cardano.Ledger.Shelley.Tx (WitnessSet)
import Cardano.Ledger.ShelleyMA.Rules.Utxo (UTXO, UtxoPredicateFailure)
import Control.State.Transition.Extended

-- ==============================================================================
--   We want to reuse the same rules for Mary and Allegra. We accomplish this
--   by adding: HasField "minted" (Core.TxBody era) (Set (ScriptHash (Crypto era)))
--   to the (WellFormed era) constraint, and adjusting UTxO.(ScriptsNeeded) to
--   add this set to its output. In the Shelley and Allegra Era, this is the empty set.
--   With this generalization, Cardano.Ledger.Shelley.Rules.Utxow(shelleyStyleWitness)
--   can still be used in Allegra and Mary, because they use the same Shelley style rules.

--------------------------------------------------------------------------------
-- UTXOW STS
--------------------------------------------------------------------------------

data UTXOW era

instance
  forall era.
  ( -- Fix Core.Witnesses to the Allegra and Mary Era
    Core.Witnesses era ~ WitnessSet era,
    -- Allow UTXOW to call UTXO
    Embed (Core.EraRule "UTXO" era) (UTXOW era),
    Environment (Core.EraRule "UTXO" era) ~ UtxoEnv era,
    State (Core.EraRule "UTXO" era) ~ UTxOState era,
    Signal (Core.EraRule "UTXO" era) ~ Core.Tx era,
    -- Supply the HasField and Validate instances for Mary and Allegra (which match Shelley)
    ShelleyStyleWitnessNeeds era
  ) =>
  STS (UTXOW era)
  where
  type State (UTXOW era) = UTxOState era
  type Signal (UTXOW era) = Core.Tx era
  type Environment (UTXOW era) = UtxoEnv era
  type BaseM (UTXOW era) = ShelleyBase
  type PredicateFailure (UTXOW era) = UtxowPredicateFailure era
  type Event (UTXOW era) = UtxowEvent era

  transitionRules :: [TransitionRule (UTXOW era)]
transitionRules = [TransitionRule (UTXOW era)
forall era (utxow :: * -> *).
(Era era, BaseM (utxow era) ~ ShelleyBase,
 Embed (EraRule "UTXO" era) (utxow era),
 Environment (EraRule "UTXO" era) ~ UtxoEnv era,
 State (EraRule "UTXO" era) ~ UTxOState era,
 Signal (EraRule "UTXO" era) ~ Tx era,
 Environment (utxow era) ~ UtxoEnv era,
 State (utxow era) ~ UTxOState era, Signal (utxow era) ~ Tx era,
 PredicateFailure (utxow era) ~ UtxowPredicateFailure era,
 STS (utxow era), ShelleyStyleWitnessNeeds era) =>
TransitionRule (utxow era)
transitionRulesUTXOW]

  -- The ShelleyMA Era uses the same PredicateFailure type
  -- as Shelley, so the 'embed' function is identity
  initialRules :: [InitialRule (UTXOW era)]
initialRules = []

instance
  ( Era era,
    STS (UTXO era),
    PredicateFailure (Core.EraRule "UTXO" era) ~ UtxoPredicateFailure era,
    Event (Core.EraRule "UTXO" era) ~ Event (UTXO era)
  ) =>
  Embed (UTXO era) (UTXOW era)
  where
  wrapFailed :: PredicateFailure (UTXO era) -> PredicateFailure (UTXOW era)
wrapFailed = PredicateFailure (UTXO era) -> PredicateFailure (UTXOW era)
forall era.
PredicateFailure (EraRule "UTXO" era) -> UtxowPredicateFailure era
UtxoFailure
  wrapEvent :: Event (UTXO era) -> Event (UTXOW era)
wrapEvent = Event (UTXO era) -> Event (UTXOW era)
forall era. Event (EraRule "UTXO" era) -> UtxowEvent era
UtxoEvent

instance
  ( Era era,
    STS (UTXOW era),
    PredicateFailure (Core.EraRule "UTXOW" era) ~ UtxowPredicateFailure era,
    Event (Core.EraRule "UTXOW" era) ~ Event (UTXOW era)
  ) =>
  Embed (UTXOW era) (Shelley.LEDGER era)
  where
  wrapFailed :: PredicateFailure (UTXOW era) -> PredicateFailure (LEDGER era)
wrapFailed = PredicateFailure (UTXOW era) -> PredicateFailure (LEDGER era)
forall era.
PredicateFailure (EraRule "UTXOW" era)
-> LedgerPredicateFailure era
Shelley.UtxowFailure
  wrapEvent :: Event (UTXOW era) -> Event (LEDGER era)
wrapEvent = Event (UTXOW era) -> Event (LEDGER era)
forall era. Event (EraRule "UTXOW" era) -> LedgerEvent era
Shelley.UtxowEvent