{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE EmptyDataDeriving  #-}
{-# LANGUAGE NamedFieldPuns     #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TypeFamilies       #-}
module Plutus.Script.Utils.Typed (
  UntypedValidator
  , UntypedMintingPolicy
  , UntypedStakeValidator
  ---
  , ValidatorTypes (..)
  , TypedValidator (..)
  , validatorHash
  , validatorCardanoAddress
  , validatorCardanoAddressAny
  , validatorAddress
  , validatorScript
  , vValidatorScript
  , forwardingMintingPolicy
  , vForwardingMintingPolicy
  , forwardingMintingPolicyHash
  , generalise
  ---
  , Any
  , Language (PlutusV1, PlutusV2)
  , Versioned (Versioned, unversioned, version)
  , IsScriptContext(mkUntypedValidator, mkUntypedStakeValidator, mkUntypedMintingPolicy)
  , ScriptContextV1
  , ScriptContextV2
) where

import Cardano.Api qualified as C
import Cardano.Ledger.Alonzo.Language (Language (PlutusV1, PlutusV2))
import Data.Aeson (ToJSON)
import Data.Kind (Type)
import Data.Void (Void)
import GHC.Generics (Generic)
import Plutus.Script.Utils.Scripts (Versioned (Versioned, unversioned, version))
import Plutus.Script.Utils.V1.Address qualified as PSU.PV1
import Plutus.Script.Utils.V2.Address qualified as PSU.PV2
import Plutus.V1.Ledger.Address qualified as PV1
import Plutus.V1.Ledger.Api qualified as PV1
import Plutus.V2.Ledger.Api qualified as PV2
import PlutusTx.Prelude (BuiltinData, BuiltinString, check, trace)

type UntypedValidator = BuiltinData -> BuiltinData -> BuiltinData -> ()
type UntypedMintingPolicy = BuiltinData -> BuiltinData -> ()
type UntypedStakeValidator = BuiltinData -> BuiltinData -> ()

data Any
  deriving stock (Any -> Any -> Bool
(Any -> Any -> Bool) -> (Any -> Any -> Bool) -> Eq Any
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Any -> Any -> Bool
$c/= :: Any -> Any -> Bool
== :: Any -> Any -> Bool
$c== :: Any -> Any -> Bool
Eq, Int -> Any -> ShowS
[Any] -> ShowS
Any -> String
(Int -> Any -> ShowS)
-> (Any -> String) -> ([Any] -> ShowS) -> Show Any
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Any] -> ShowS
$cshowList :: [Any] -> ShowS
show :: Any -> String
$cshow :: Any -> String
showsPrec :: Int -> Any -> ShowS
$cshowsPrec :: Int -> Any -> ShowS
Show, (forall x. Any -> Rep Any x)
-> (forall x. Rep Any x -> Any) -> Generic Any
forall x. Rep Any x -> Any
forall x. Any -> Rep Any x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Any x -> Any
$cfrom :: forall x. Any -> Rep Any x
Generic)
  deriving anyclass ([Any] -> Encoding
[Any] -> Value
Any -> Encoding
Any -> Value
(Any -> Value)
-> (Any -> Encoding)
-> ([Any] -> Value)
-> ([Any] -> Encoding)
-> ToJSON Any
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [Any] -> Encoding
$ctoEncodingList :: [Any] -> Encoding
toJSONList :: [Any] -> Value
$ctoJSONList :: [Any] -> Value
toEncoding :: Any -> Encoding
$ctoEncoding :: Any -> Encoding
toJSON :: Any -> Value
$ctoJSON :: Any -> Value
ToJSON)

-- | A class that associates a type standing for a connection type with two types, the type of the
-- redeemer and the data script for that connection type.
class ValidatorTypes (a :: Type) where
  -- | The type of the redeemers of this connection type.
  type RedeemerType a :: Type

  -- | The type of the data of this connection type.
  type DatumType a :: Type

  -- Defaults
  type RedeemerType a = ()
  type DatumType a = ()

instance ValidatorTypes Void where
  type RedeemerType Void = Void
  type DatumType Void = Void

instance ValidatorTypes Any where
  type RedeemerType Any = BuiltinData
  type DatumType Any = BuiltinData

-- | A typed validator script with its 'ValidatorScript' and 'Address'.
data TypedValidator (a :: Type) = TypedValidator
  { TypedValidator a -> Versioned Validator
tvValidator         :: Versioned PV1.Validator
  , TypedValidator a -> ValidatorHash
tvValidatorHash     :: PV1.ValidatorHash
  , TypedValidator a -> Versioned MintingPolicy
tvForwardingMPS     :: Versioned PV1.MintingPolicy
    -- | The hash of the minting policy that checks whether the validator
    --   is run in this transaction
  , TypedValidator a -> MintingPolicyHash
tvForwardingMPSHash :: PV1.MintingPolicyHash
  }
  deriving stock (Int -> TypedValidator a -> ShowS
[TypedValidator a] -> ShowS
TypedValidator a -> String
(Int -> TypedValidator a -> ShowS)
-> (TypedValidator a -> String)
-> ([TypedValidator a] -> ShowS)
-> Show (TypedValidator a)
forall a. Int -> TypedValidator a -> ShowS
forall a. [TypedValidator a] -> ShowS
forall a. TypedValidator a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TypedValidator a] -> ShowS
$cshowList :: forall a. [TypedValidator a] -> ShowS
show :: TypedValidator a -> String
$cshow :: forall a. TypedValidator a -> String
showsPrec :: Int -> TypedValidator a -> ShowS
$cshowsPrec :: forall a. Int -> TypedValidator a -> ShowS
Show, TypedValidator a -> TypedValidator a -> Bool
(TypedValidator a -> TypedValidator a -> Bool)
-> (TypedValidator a -> TypedValidator a -> Bool)
-> Eq (TypedValidator a)
forall a. TypedValidator a -> TypedValidator a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TypedValidator a -> TypedValidator a -> Bool
$c/= :: forall a. TypedValidator a -> TypedValidator a -> Bool
== :: TypedValidator a -> TypedValidator a -> Bool
$c== :: forall a. TypedValidator a -> TypedValidator a -> Bool
Eq, (forall x. TypedValidator a -> Rep (TypedValidator a) x)
-> (forall x. Rep (TypedValidator a) x -> TypedValidator a)
-> Generic (TypedValidator a)
forall x. Rep (TypedValidator a) x -> TypedValidator a
forall x. TypedValidator a -> Rep (TypedValidator a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (TypedValidator a) x -> TypedValidator a
forall a x. TypedValidator a -> Rep (TypedValidator a) x
$cto :: forall a x. Rep (TypedValidator a) x -> TypedValidator a
$cfrom :: forall a x. TypedValidator a -> Rep (TypedValidator a) x
Generic)

-- | The hash of the validator.
validatorHash :: TypedValidator a -> PV1.ValidatorHash
validatorHash :: TypedValidator a -> ValidatorHash
validatorHash = TypedValidator a -> ValidatorHash
forall a. TypedValidator a -> ValidatorHash
tvValidatorHash

-- | The address of the validator.
validatorAddress :: TypedValidator a -> PV1.Address
validatorAddress :: TypedValidator a -> Address
validatorAddress = ValidatorHash -> Address
PV1.scriptHashAddress (ValidatorHash -> Address)
-> (TypedValidator a -> ValidatorHash)
-> TypedValidator a
-> Address
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypedValidator a -> ValidatorHash
forall a. TypedValidator a -> ValidatorHash
tvValidatorHash

-- | The address of the validator.
validatorCardanoAddress :: C.NetworkId -> TypedValidator a -> C.AddressInEra C.BabbageEra
validatorCardanoAddress :: NetworkId -> TypedValidator a -> AddressInEra BabbageEra
validatorCardanoAddress NetworkId
networkId TypedValidator a
tv =
  let validator :: Versioned Validator
validator = TypedValidator a -> Versioned Validator
forall a. TypedValidator a -> Versioned Validator
tvValidator TypedValidator a
tv
  in case Versioned Validator -> Language
forall script. Versioned script -> Language
version Versioned Validator
validator of
          Language
PlutusV1 -> NetworkId -> Validator -> AddressInEra BabbageEra
PSU.PV1.mkValidatorCardanoAddress NetworkId
networkId (Validator -> AddressInEra BabbageEra)
-> Validator -> AddressInEra BabbageEra
forall a b. (a -> b) -> a -> b
$ Versioned Validator -> Validator
forall script. Versioned script -> script
unversioned Versioned Validator
validator
          Language
PlutusV2 -> NetworkId -> Validator -> AddressInEra BabbageEra
PSU.PV2.mkValidatorCardanoAddress NetworkId
networkId (Validator -> AddressInEra BabbageEra)
-> Validator -> AddressInEra BabbageEra
forall a b. (a -> b) -> a -> b
$ Versioned Validator -> Validator
forall script. Versioned script -> script
unversioned Versioned Validator
validator

validatorCardanoAddressAny :: C.NetworkId -> TypedValidator a -> C.AddressAny
validatorCardanoAddressAny :: NetworkId -> TypedValidator a -> AddressAny
validatorCardanoAddressAny NetworkId
nid TypedValidator a
tv =
  case NetworkId -> TypedValidator a -> AddressInEra BabbageEra
forall a. NetworkId -> TypedValidator a -> AddressInEra BabbageEra
validatorCardanoAddress NetworkId
nid TypedValidator a
tv of
    C.AddressInEra C.ShelleyAddressInEra{} Address addrtype
addr  -> Address ShelleyAddr -> AddressAny
C.AddressShelley Address addrtype
Address ShelleyAddr
addr
    C.AddressInEra C.ByronAddressInAnyEra{} Address addrtype
addr -> Address ByronAddr -> AddressAny
C.AddressByron Address addrtype
Address ByronAddr
addr

-- | The unversioned validator script itself.
validatorScript :: TypedValidator a -> PV1.Validator
validatorScript :: TypedValidator a -> Validator
validatorScript = Versioned Validator -> Validator
forall script. Versioned script -> script
unversioned (Versioned Validator -> Validator)
-> (TypedValidator a -> Versioned Validator)
-> TypedValidator a
-> Validator
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypedValidator a -> Versioned Validator
forall a. TypedValidator a -> Versioned Validator
vValidatorScript

-- | The validator script itself.
vValidatorScript :: TypedValidator a -> Versioned PV1.Validator
vValidatorScript :: TypedValidator a -> Versioned Validator
vValidatorScript = TypedValidator a -> Versioned Validator
forall a. TypedValidator a -> Versioned Validator
tvValidator

-- | Generalise the typed validator to one that works with the 'Data' type.
generalise :: forall a. TypedValidator a -> TypedValidator Any
generalise :: TypedValidator a -> TypedValidator Any
generalise TypedValidator {Versioned Validator
tvValidator :: Versioned Validator
tvValidator :: forall a. TypedValidator a -> Versioned Validator
tvValidator, ValidatorHash
tvValidatorHash :: ValidatorHash
tvValidatorHash :: forall a. TypedValidator a -> ValidatorHash
tvValidatorHash, Versioned MintingPolicy
tvForwardingMPS :: Versioned MintingPolicy
tvForwardingMPS :: forall a. TypedValidator a -> Versioned MintingPolicy
tvForwardingMPS, MintingPolicyHash
tvForwardingMPSHash :: MintingPolicyHash
tvForwardingMPSHash :: forall a. TypedValidator a -> MintingPolicyHash
tvForwardingMPSHash} =
  -- we can do this safely because the on-chain validators are untyped, so they always
  -- take 'BuiltinData' arguments. The validator script stays the same, so the conversion
  -- from 'BuiltinData' to 'a' still takes place, even if it's not reflected in the type
  -- signature anymore.
  TypedValidator :: forall a.
Versioned Validator
-> ValidatorHash
-> Versioned MintingPolicy
-> MintingPolicyHash
-> TypedValidator a
TypedValidator {Versioned Validator
tvValidator :: Versioned Validator
tvValidator :: Versioned Validator
tvValidator, ValidatorHash
tvValidatorHash :: ValidatorHash
tvValidatorHash :: ValidatorHash
tvValidatorHash, Versioned MintingPolicy
tvForwardingMPS :: Versioned MintingPolicy
tvForwardingMPS :: Versioned MintingPolicy
tvForwardingMPS, MintingPolicyHash
tvForwardingMPSHash :: MintingPolicyHash
tvForwardingMPSHash :: MintingPolicyHash
tvForwardingMPSHash}

-- | The unversioned minting policy that forwards all checks to the instance's
--   validator
forwardingMintingPolicy :: TypedValidator a -> PV1.MintingPolicy
forwardingMintingPolicy :: TypedValidator a -> MintingPolicy
forwardingMintingPolicy = Versioned MintingPolicy -> MintingPolicy
forall script. Versioned script -> script
unversioned (Versioned MintingPolicy -> MintingPolicy)
-> (TypedValidator a -> Versioned MintingPolicy)
-> TypedValidator a
-> MintingPolicy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypedValidator a -> Versioned MintingPolicy
forall a. TypedValidator a -> Versioned MintingPolicy
tvForwardingMPS

-- | The minting policy that forwards all checks to the instance's
--   validator
vForwardingMintingPolicy :: TypedValidator a -> Versioned PV1.MintingPolicy
vForwardingMintingPolicy :: TypedValidator a -> Versioned MintingPolicy
vForwardingMintingPolicy = TypedValidator a -> Versioned MintingPolicy
forall a. TypedValidator a -> Versioned MintingPolicy
tvForwardingMPS


-- | Hash of the minting policy that forwards all checks to the instance's
--   validator
forwardingMintingPolicyHash :: TypedValidator a -> PV1.MintingPolicyHash
forwardingMintingPolicyHash :: TypedValidator a -> MintingPolicyHash
forwardingMintingPolicyHash = TypedValidator a -> MintingPolicyHash
forall a. TypedValidator a -> MintingPolicyHash
tvForwardingMPSHash

{-# INLINABLE tracedUnsafeFrom #-}
tracedUnsafeFrom :: forall a. PV1.UnsafeFromData a => BuiltinString -> BuiltinData -> a
tracedUnsafeFrom :: BuiltinString -> BuiltinData -> a
tracedUnsafeFrom BuiltinString
label BuiltinData
d = BuiltinString -> a -> a
forall a. BuiltinString -> a -> a
trace BuiltinString
label (a -> a) -> a -> a
forall a b. (a -> b) -> a -> b
$ BuiltinData -> a
forall a. UnsafeFromData a => BuiltinData -> a
PV1.unsafeFromBuiltinData BuiltinData
d


class PV1.UnsafeFromData sc => IsScriptContext sc where
    {-# INLINABLE mkUntypedValidator #-}
    -- | Converts a custom datum and redeemer from a validator function to an
    -- untyped validator function. See Note [Scripts returning Bool].
    --
    -- Here's an example of how this function can be used:
    --
    -- @
    --   import PlutusTx qualified
    --   import Plutus.V2.Ledger.Scripts qualified as Plutus
    --   import Plutus.Script.Utils.V2.Scripts (mkUntypedValidator)
    --
    --   newtype MyCustomDatum = MyCustomDatum Integer
    --   PlutusTx.unstableMakeIsData ''MyCustomDatum
    --   newtype MyCustomRedeemer = MyCustomRedeemer Integer
    --   PlutusTx.unstableMakeIsData ''MyCustomRedeemer
    --
    --   mkValidator :: MyCustomDatum -> MyCustomRedeemer -> Plutus.ScriptContext -> Bool
    --   mkValidator _ _ _ = True
    --
    --   validator :: Plutus.Validator
    --   validator = Plutus.mkValidatorScript
    --       $$(PlutusTx.compile [|| wrap ||])
    --    where
    --       wrap = mkUntypedValidator mkValidator
    -- @
    --
    -- Here's an example using a parameterized validator:
    --
    -- @
    --   import PlutusTx qualified
    --   import Plutus.V2.Ledger.Scripts qualified as Plutus
    --   import Plutus.Script.Utils.V2.Scripts (mkUntypedValidator)
    --
    --   newtype MyCustomDatum = MyCustomDatum Integer
    --   PlutusTx.unstableMakeIsData ''MyCustomDatum
    --   newtype MyCustomRedeemer = MyCustomRedeemer Integer
    --   PlutusTx.unstableMakeIsData ''MyCustomRedeemer
    --
    --   mkValidator :: Int -> MyCustomDatum -> MyCustomRedeemer -> Plutus.ScriptContext -> Bool
    --   mkValidator _ _ _ _ = True
    --
    --   validator :: Int -> Plutus.Validator
    --   validator i = Plutus.mkValidatorScript
    --       $$(PlutusTx.compile [|| wrap . mkValidator ||]) `PlutusTx.applyCode` PlutusTx.liftCode i
    --    where
    --       wrap = mkUntypedValidator
    -- @
    --
    -- For debugging purpose, it may be of interest to know that in the default implementation,
    -- the parameters are decoded in the order they appear
    -- (data, redeemer and then script context).
    -- A log trace is generated after each successfully decoded parameter.
    -- Thus, if a parameter can't be decoded, the culprit is the first parameter in the list that doesn't appear as
    -- successfully decoded in the log trace.
    mkUntypedValidator
        :: (PV1.UnsafeFromData d, PV1.UnsafeFromData r)
        => (d -> r -> sc -> Bool)
        -> UntypedValidator
    -- We can use unsafeFromBuiltinData here as we would fail immediately anyway if parsing failed
    mkUntypedValidator d -> r -> sc -> Bool
f BuiltinData
d BuiltinData
r BuiltinData
p =
        Bool -> ()
check (Bool -> ()) -> Bool -> ()
forall a b. (a -> b) -> a -> b
$ d -> r -> sc -> Bool
f (BuiltinString -> BuiltinData -> d
forall a. UnsafeFromData a => BuiltinString -> BuiltinData -> a
tracedUnsafeFrom BuiltinString
"Data decoded successfully" BuiltinData
d)
                  (BuiltinString -> BuiltinData -> r
forall a. UnsafeFromData a => BuiltinString -> BuiltinData -> a
tracedUnsafeFrom BuiltinString
"Redeemer decoded successfully" BuiltinData
r)
                  (BuiltinString -> BuiltinData -> sc
forall a. UnsafeFromData a => BuiltinString -> BuiltinData -> a
tracedUnsafeFrom BuiltinString
"Script context decoded successfully" BuiltinData
p)

    {-# INLINABLE mkUntypedStakeValidator #-}
    -- | Converts a custom redeemer from a stake validator function to an
    -- untyped stake validator function. See Note [Scripts returning Bool].
    --
    -- Here's an example of how this function can be used:
    --
    -- @
    --   import PlutusTx qualified
    --   import Plutus.V1.Ledger.Scripts qualified as Plutus
    --   import Plutus.Script.Utils.V1.Scripts (mkUntypedStakeValidator)
    --
    --   newtype MyCustomRedeemer = MyCustomRedeemer Integer
    --   PlutusTx.unstableMakeIsData ''MyCustomRedeemer
    --
    --   mkStakeValidator :: MyCustomRedeemer -> ScriptContext -> Bool
    --   mkStakeValidator _ _ = True
    --
    --   validator :: Plutus.Validator
    --   validator = Plutus.mkStakeValidatorScript
    --       $$(PlutusTx.compile [|| wrap ||])
    --    where
    --       wrap = mkUntypedStakeValidator mkStakeValidator
    -- @
    --
    -- For debugging purpose, it may be of interest to know that in the default implementation,
    -- the parameters are decoded in the order they appear
    -- (redeemer and then script context).
    -- A log trace is generated after each successfully decoded parameter.
    -- Thus, if a parameter can't be decoded, the culprit is the first parameter in the list that doesn't appear as
    -- successfully decoded in the log trace.
    mkUntypedStakeValidator
        :: PV1.UnsafeFromData r
        => (r -> sc -> Bool)
        -> UntypedStakeValidator
    mkUntypedStakeValidator r -> sc -> Bool
f BuiltinData
r BuiltinData
p =
        Bool -> ()
check (Bool -> ()) -> Bool -> ()
forall a b. (a -> b) -> a -> b
$ r -> sc -> Bool
f (BuiltinString -> BuiltinData -> r
forall a. UnsafeFromData a => BuiltinString -> BuiltinData -> a
tracedUnsafeFrom BuiltinString
"Redeemer decoded successfully" BuiltinData
r)
                  (BuiltinString -> BuiltinData -> sc
forall a. UnsafeFromData a => BuiltinString -> BuiltinData -> a
tracedUnsafeFrom BuiltinString
"Script context decoded successfully" BuiltinData
p)

    {-# INLINABLE mkUntypedMintingPolicy #-}
    -- | Converts a custom redeemer from a minting policy function to an
    -- untyped minting policy function. See Note [Scripts returning Bool].
    --
    -- Here's an example of how this function can be used:
    --
    -- @
    --   import PlutusTx qualified
    --   import Plutus.V1.Ledger.Scripts qualified as Plutus
    --   import Plutus.Script.Utils.V1.Scripts (mkUntypedMintingPolicy)
    --
    --   newtype MyCustomRedeemer = MyCustomRedeemer Integer
    --   PlutusTx.unstableMakeIsData ''MyCustomRedeemer
    --
    --   mkMintingPolicy :: MyCustomRedeemer -> ScriptContext -> Bool
    --   mkMintingPolicy _ _ = True
    --
    --   validator :: Plutus.Validator
    --   validator = Plutus.mkMintingPolicyScript
    --       $$(PlutusTx.compile [|| wrap ||])
    --    where
    --       wrap = mkUntypedMintingPolicy mkMintingPolicy
    -- @
    --
    -- For debugging purpose, it may be of interest to know that in the default implementation,
    -- the parameters are decoded in the order they appear
    -- (redeemer and then script context).
    -- A log trace is generated after each successfully decoded parameter.
    -- Thus, if a parameter can't be decoded, the culprit is the first parameter in the list that doesn't appear as
    -- successfully decoded in the log trace.
    mkUntypedMintingPolicy
        :: PV1.UnsafeFromData r
        => (r -> sc -> Bool)
        -> UntypedMintingPolicy
    -- We can use unsafeFromBuiltinData here as we would fail immediately anyway if parsing failed
    mkUntypedMintingPolicy r -> sc -> Bool
f BuiltinData
r BuiltinData
p =
        Bool -> ()
check (Bool -> ()) -> Bool -> ()
forall a b. (a -> b) -> a -> b
$ r -> sc -> Bool
f (BuiltinString -> BuiltinData -> r
forall a. UnsafeFromData a => BuiltinString -> BuiltinData -> a
tracedUnsafeFrom BuiltinString
"Redeemer decoded successfully" BuiltinData
r)
                  (BuiltinString -> BuiltinData -> sc
forall a. UnsafeFromData a => BuiltinString -> BuiltinData -> a
tracedUnsafeFrom BuiltinString
"Script context decoded successfully" BuiltinData
p)

type ScriptContextV1 = PV1.ScriptContext
type ScriptContextV2 = PV2.ScriptContext

instance IsScriptContext PV1.ScriptContext where

instance IsScriptContext PV2.ScriptContext where