{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE DerivingStrategies  #-}
{-# LANGUAGE TypeFamilies        #-}

{-# OPTIONS_GHC -fno-specialise #-}
{-# OPTIONS_GHC -Wno-simplifiable-class-constraints #-}
{-# OPTIONS_GHC -fno-omit-interface-pragmas #-}

module Plutus.Script.Utils.V2.Typed.Scripts.Validators
    ( UntypedValidator
    ---
    , ValidatorTypes (..)
    , ValidatorType
    , TypedValidator
    , mkTypedValidator
    , mkTypedValidatorParam
    , validatorHash
    , validatorAddress
    , validatorScript
    , vValidatorScript
    , forwardingMintingPolicy
    , vForwardingMintingPolicy
    , forwardingMintingPolicyHash
    , generalise
    )
where

import Data.Kind (Type)
import Plutus.Script.Utils.Scripts (Language (PlutusV2), Versioned (Versioned))
import Plutus.Script.Utils.Typed (DatumType, RedeemerType,
                                  TypedValidator (TypedValidator, tvForwardingMPS, tvForwardingMPSHash, tvValidator, tvValidatorHash),
                                  UntypedValidator, ValidatorTypes, forwardingMintingPolicy,
                                  forwardingMintingPolicyHash, generalise, vForwardingMintingPolicy, vValidatorScript,
                                  validatorAddress, validatorHash, validatorScript)
import Plutus.Script.Utils.V2.Scripts qualified as Scripts
import Plutus.Script.Utils.V2.Typed.Scripts.MonetaryPolicies qualified as MPS
import Plutus.V2.Ledger.Api qualified as PV2
import PlutusCore.Default (DefaultUni)
import PlutusTx (CompiledCode, Lift, applyCode, liftCode)

-- | The type of validators for the given connection type.
type ValidatorType (a :: Type) = DatumType a -> RedeemerType a -> PV2.ScriptContext -> Bool

-- | Make a 'TypedValidator' from the 'CompiledCode' of a validator script and its wrapper.
mkTypedValidator ::
  -- | Validator script (compiled)
  CompiledCode (ValidatorType a) ->
  -- | A wrapper for the compiled validator
  CompiledCode (ValidatorType a -> UntypedValidator) ->
  TypedValidator a
mkTypedValidator :: CompiledCode (ValidatorType a)
-> CompiledCode (ValidatorType a -> UntypedValidator)
-> TypedValidator a
mkTypedValidator CompiledCode (ValidatorType a)
vc CompiledCode (ValidatorType a -> UntypedValidator)
wrapper =
  TypedValidator :: forall a.
Versioned Validator
-> ValidatorHash
-> Versioned MintingPolicy
-> MintingPolicyHash
-> TypedValidator a
TypedValidator
    { tvValidator :: Versioned Validator
tvValidator = Validator -> Language -> Versioned Validator
forall script. script -> Language -> Versioned script
Versioned Validator
val Language
PlutusV2
    , tvValidatorHash :: ValidatorHash
tvValidatorHash = ValidatorHash
hsh
    , tvForwardingMPS :: Versioned MintingPolicy
tvForwardingMPS = MintingPolicy -> Language -> Versioned MintingPolicy
forall script. script -> Language -> Versioned script
Versioned MintingPolicy
mps Language
PlutusV2
    , tvForwardingMPSHash :: MintingPolicyHash
tvForwardingMPSHash = MintingPolicy -> MintingPolicyHash
Scripts.mintingPolicyHash MintingPolicy
mps
    }
  where
    val :: Validator
val = CompiledCode UntypedValidator -> Validator
PV2.mkValidatorScript (CompiledCode UntypedValidator -> Validator)
-> CompiledCode UntypedValidator -> Validator
forall a b. (a -> b) -> a -> b
$ CompiledCode (ValidatorType a -> UntypedValidator)
wrapper CompiledCode (ValidatorType a -> UntypedValidator)
-> CompiledCode (ValidatorType a) -> CompiledCode UntypedValidator
forall (uni :: * -> *) fun a b.
(Closed uni, Everywhere uni Flat, Flat fun,
 Everywhere uni PrettyConst, GShow uni, Pretty fun) =>
CompiledCodeIn uni fun (a -> b)
-> CompiledCodeIn uni fun a -> CompiledCodeIn uni fun b
`applyCode` CompiledCode (ValidatorType a)
vc
    hsh :: ValidatorHash
hsh = Validator -> ValidatorHash
Scripts.validatorHash Validator
val
    mps :: MintingPolicy
mps = ValidatorHash -> MintingPolicy
MPS.mkForwardingMintingPolicy ValidatorHash
hsh

-- | Make a 'TypedValidator' from the 'CompiledCode' of a parameterized validator script and its wrapper.
mkTypedValidatorParam ::
  forall a param.
  Lift DefaultUni param =>
  -- | Validator script (compiled)
  CompiledCode (param -> ValidatorType a) ->
  -- | A wrapper for the compiled validator
  CompiledCode (ValidatorType a -> UntypedValidator) ->
  -- | The extra paramater for the validator script
  param ->
  TypedValidator a
mkTypedValidatorParam :: CompiledCode (param -> ValidatorType a)
-> CompiledCode (ValidatorType a -> UntypedValidator)
-> param
-> TypedValidator a
mkTypedValidatorParam CompiledCode (param -> ValidatorType a)
vc CompiledCode (ValidatorType a -> UntypedValidator)
wrapper param
param =
  CompiledCode (ValidatorType a)
-> CompiledCode (ValidatorType a -> UntypedValidator)
-> TypedValidator a
forall a.
CompiledCode (ValidatorType a)
-> CompiledCode (ValidatorType a -> UntypedValidator)
-> TypedValidator a
mkTypedValidator (CompiledCode (param -> ValidatorType a)
vc CompiledCode (param -> ValidatorType a)
-> CompiledCodeIn DefaultUni DefaultFun param
-> CompiledCode (ValidatorType a)
forall (uni :: * -> *) fun a b.
(Closed uni, Everywhere uni Flat, Flat fun,
 Everywhere uni PrettyConst, GShow uni, Pretty fun) =>
CompiledCodeIn uni fun (a -> b)
-> CompiledCodeIn uni fun a -> CompiledCodeIn uni fun b
`applyCode` param -> CompiledCodeIn DefaultUni DefaultFun param
forall (uni :: * -> *) a fun.
(Lift uni a, Throwable uni fun, Typecheckable uni fun) =>
a -> CompiledCodeIn uni fun a
liftCode param
param) CompiledCode (ValidatorType a -> UntypedValidator)
wrapper