{-# LANGUAGE DerivingStrategies   #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE TypeApplications     #-}
{-# LANGUAGE UndecidableInstances #-}

{-# OPTIONS_GHC -Wno-missing-import-lists #-}

module Plutus.Script.Utils.V1.Typed.Scripts
  ( module Plutus.Script.Utils.V1.Typed.Scripts.MonetaryPolicies,
    module Plutus.Script.Utils.V1.Typed.Scripts.StakeValidators,
    module Plutus.Script.Utils.V1.Typed.Scripts.Validators,
    Validator,
    MintingPolicy,
    StakeValidator,
    TypedScriptTxOut (tyTxOutData, tyTxOutTxOut),
    TypedScriptTxOutRef (tyTxOutRefOut, tyTxOutRefRef),
    makeTypedScriptTxOut,
    typeScriptTxOut,
    typeScriptTxOutRef,
  )
where

import Control.Monad.Except (MonadError (throwError))
import Plutus.Script.Utils.Scripts (datumHash)
import Plutus.Script.Utils.V1.Typed.Scripts.MonetaryPolicies hiding (forwardToValidator)
import Plutus.Script.Utils.V1.Typed.Scripts.StakeValidators hiding (forwardToValidator)
import Plutus.Script.Utils.V1.Typed.Scripts.Validators
import Plutus.V1.Ledger.Api (Credential (PubKeyCredential, ScriptCredential), Datum (Datum), FromData, MintingPolicy,
                             StakeValidator, ToData (..), TxOut (TxOut, txOutAddress, txOutDatumHash, txOutValue),
                             TxOutRef, Validator, Value, addressCredential)

{- Note [Scripts returning Bool]
It used to be that the signal for validation failure was a script being `error`. This is nice for
the validator, since you can determine whether the script evaluation is error-or-not without having
to look at what the result actually *is* if there is one.

However, from the script author's point of view, it would be nicer to return a Bool, since
otherwise you end up doing a lot of `if realCondition then () else error ()` which is rubbish.

So we changed the result type to be Bool. But now we have to answer the question of how the
validator knows what the result value is. All *sorts* of terms can be True or False in disguise.
The easiest way to tell is by reducing it to the previous problem: apply a function which does a
pattern match and returns error in the case of False and () otherwise. Then, as before, we just
check for error in the overall evaluation.
-}

-- | A 'TxOut' tagged by a phantom type: and the connection type of the output.
data TypedScriptTxOut a = (FromData (DatumType a), ToData (DatumType a)) =>
  TypedScriptTxOut
  { TypedScriptTxOut a -> TxOut
tyTxOutTxOut :: TxOut,
    TypedScriptTxOut a -> DatumType a
tyTxOutData  :: DatumType a
  }

instance Eq (DatumType a) => Eq (TypedScriptTxOut a) where
  TypedScriptTxOut a
l == :: TypedScriptTxOut a -> TypedScriptTxOut a -> Bool
== TypedScriptTxOut a
r =
    TypedScriptTxOut a -> TxOut
forall a. TypedScriptTxOut a -> TxOut
tyTxOutTxOut TypedScriptTxOut a
l TxOut -> TxOut -> Bool
forall a. Eq a => a -> a -> Bool
== TypedScriptTxOut a -> TxOut
forall a. TypedScriptTxOut a -> TxOut
tyTxOutTxOut TypedScriptTxOut a
r
      Bool -> Bool -> Bool
&& TypedScriptTxOut a -> DatumType a
forall a. TypedScriptTxOut a -> DatumType a
tyTxOutData TypedScriptTxOut a
l DatumType a -> DatumType a -> Bool
forall a. Eq a => a -> a -> Bool
== TypedScriptTxOut a -> DatumType a
forall a. TypedScriptTxOut a -> DatumType a
tyTxOutData TypedScriptTxOut a
r

-- | Create a 'TypedScriptTxOut' from a correctly-typed data script, an address, and a value.
makeTypedScriptTxOut ::
  forall out.
  (ToData (DatumType out), FromData (DatumType out)) =>
  TypedValidator out ->
  DatumType out ->
  Value ->
  TypedScriptTxOut out
makeTypedScriptTxOut :: TypedValidator out
-> DatumType out -> Value -> TypedScriptTxOut out
makeTypedScriptTxOut TypedValidator out
ct DatumType out
d Value
value =
  TxOut -> DatumType out -> TypedScriptTxOut out
forall a.
(FromData (DatumType a), ToData (DatumType a)) =>
TxOut -> DatumType a -> TypedScriptTxOut a
TypedScriptTxOut @out
    TxOut :: Address -> Value -> Maybe DatumHash -> TxOut
TxOut
      { txOutAddress :: Address
txOutAddress = TypedValidator out -> Address
forall a. TypedValidator a -> Address
validatorAddress TypedValidator out
ct,
        txOutValue :: Value
txOutValue = Value
value,
        txOutDatumHash :: Maybe DatumHash
txOutDatumHash = DatumHash -> Maybe DatumHash
forall a. a -> Maybe a
Just (Datum -> DatumHash
datumHash (Datum -> DatumHash) -> Datum -> DatumHash
forall a b. (a -> b) -> a -> b
$ BuiltinData -> Datum
Datum (BuiltinData -> Datum) -> BuiltinData -> Datum
forall a b. (a -> b) -> a -> b
$ DatumType out -> BuiltinData
forall a. ToData a => a -> BuiltinData
toBuiltinData DatumType out
d)
      }
    DatumType out
d

-- | A 'TxOutRef' tagged by a phantom type: and the connection type of the output.
data TypedScriptTxOutRef a = TypedScriptTxOutRef
  { TypedScriptTxOutRef a -> TxOutRef
tyTxOutRefRef :: TxOutRef,
    TypedScriptTxOutRef a -> TypedScriptTxOut a
tyTxOutRefOut :: TypedScriptTxOut a
  }

instance Eq (DatumType a) => Eq (TypedScriptTxOutRef a) where
  TypedScriptTxOutRef a
l == :: TypedScriptTxOutRef a -> TypedScriptTxOutRef a -> Bool
== TypedScriptTxOutRef a
r =
    TypedScriptTxOutRef a -> TxOutRef
forall a. TypedScriptTxOutRef a -> TxOutRef
tyTxOutRefRef TypedScriptTxOutRef a
l TxOutRef -> TxOutRef -> Bool
forall a. Eq a => a -> a -> Bool
== TypedScriptTxOutRef a -> TxOutRef
forall a. TypedScriptTxOutRef a -> TxOutRef
tyTxOutRefRef TypedScriptTxOutRef a
r
      Bool -> Bool -> Bool
&& TypedScriptTxOutRef a -> TypedScriptTxOut a
forall a. TypedScriptTxOutRef a -> TypedScriptTxOut a
tyTxOutRefOut TypedScriptTxOutRef a
l TypedScriptTxOut a -> TypedScriptTxOut a -> Bool
forall a. Eq a => a -> a -> Bool
== TypedScriptTxOutRef a -> TypedScriptTxOut a
forall a. TypedScriptTxOutRef a -> TypedScriptTxOut a
tyTxOutRefOut TypedScriptTxOutRef a
r

-- | Create a 'TypedScriptTxOut' from an existing 'TxOut' by checking the types of its parts.
typeScriptTxOut ::
  forall out m.
  ( FromData (DatumType out),
    ToData (DatumType out),
    MonadError ConnectionError m
  ) =>
  TypedValidator out ->
  TxOutRef ->
  TxOut ->
  Datum ->
  m (TypedScriptTxOut out)
typeScriptTxOut :: TypedValidator out
-> TxOutRef -> TxOut -> Datum -> m (TypedScriptTxOut out)
typeScriptTxOut TypedValidator out
tv TxOutRef
txOutRef TxOut
txOut Datum
datum = do
  case Address -> Credential
addressCredential (TxOut -> Address
txOutAddress TxOut
txOut) of
    PubKeyCredential PubKeyHash
_ ->
      ConnectionError -> m (TypedScriptTxOut out)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ConnectionError -> m (TypedScriptTxOut out))
-> ConnectionError -> m (TypedScriptTxOut out)
forall a b. (a -> b) -> a -> b
$ WrongOutTypeError -> ConnectionError
WrongOutType WrongOutTypeError
ExpectedScriptGotPubkey
    ScriptCredential ValidatorHash
_vh ->
      case TxOut -> Maybe DatumHash
txOutDatumHash TxOut
txOut of
        Just DatumHash
dh | Datum -> DatumHash
datumHash Datum
datum DatumHash -> DatumHash -> Bool
forall a. Eq a => a -> a -> Bool
== DatumHash
dh -> do
          TypedValidator out -> Address -> m ()
forall a (m :: * -> *).
MonadError ConnectionError m =>
TypedValidator a -> Address -> m ()
checkValidatorAddress TypedValidator out
tv (TxOut -> Address
txOutAddress TxOut
txOut)
          DatumType out
dsVal <- TypedValidator out -> Datum -> m (DatumType out)
forall a (m :: * -> *).
(FromData (DatumType a), MonadError ConnectionError m) =>
TypedValidator a -> Datum -> m (DatumType a)
checkDatum TypedValidator out
tv Datum
datum
          TypedScriptTxOut out -> m (TypedScriptTxOut out)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypedScriptTxOut out -> m (TypedScriptTxOut out))
-> TypedScriptTxOut out -> m (TypedScriptTxOut out)
forall a b. (a -> b) -> a -> b
$ TxOut -> DatumType out -> TypedScriptTxOut out
forall a.
(FromData (DatumType a), ToData (DatumType a)) =>
TxOut -> DatumType a -> TypedScriptTxOut a
TypedScriptTxOut @out TxOut
txOut DatumType out
dsVal
        Maybe DatumHash
_ -> ConnectionError -> m (TypedScriptTxOut out)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ConnectionError -> m (TypedScriptTxOut out))
-> ConnectionError -> m (TypedScriptTxOut out)
forall a b. (a -> b) -> a -> b
$ TxOutRef -> DatumHash -> ConnectionError
NoDatum TxOutRef
txOutRef (Datum -> DatumHash
datumHash Datum
datum)

-- | Create a 'TypedScriptTxOut' from an existing 'TxOut' by checking the types of its parts.
typeScriptTxOutRef ::
  forall out m.
  ( FromData (DatumType out),
    ToData (DatumType out),
    MonadError ConnectionError m
  ) =>
  TypedValidator out ->
  TxOutRef ->
  TxOut ->
  Datum ->
  m (TypedScriptTxOutRef out)
typeScriptTxOutRef :: TypedValidator out
-> TxOutRef -> TxOut -> Datum -> m (TypedScriptTxOutRef out)
typeScriptTxOutRef TypedValidator out
tv TxOutRef
txOutRef TxOut
txOut Datum
datum = do
  TypedScriptTxOut out
tyOut <- TypedValidator out
-> TxOutRef -> TxOut -> Datum -> m (TypedScriptTxOut out)
forall out (m :: * -> *).
(FromData (DatumType out), ToData (DatumType out),
 MonadError ConnectionError m) =>
TypedValidator out
-> TxOutRef -> TxOut -> Datum -> m (TypedScriptTxOut out)
typeScriptTxOut TypedValidator out
tv TxOutRef
txOutRef TxOut
txOut Datum
datum
  TypedScriptTxOutRef out -> m (TypedScriptTxOutRef out)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypedScriptTxOutRef out -> m (TypedScriptTxOutRef out))
-> TypedScriptTxOutRef out -> m (TypedScriptTxOutRef out)
forall a b. (a -> b) -> a -> b
$ TxOutRef -> TypedScriptTxOut out -> TypedScriptTxOutRef out
forall a. TxOutRef -> TypedScriptTxOut a -> TypedScriptTxOutRef a
TypedScriptTxOutRef TxOutRef
txOutRef TypedScriptTxOut out
tyOut