{-# LANGUAGE Rank2Types #-}

module Plutarch.Extra.StateThread (
  withStateThread,
  pwithStateThread,
  withStateThreadMulti,
  pwithStateThreadMulti,
) where

import Plutarch.Api.V1 (PCurrencySymbol, PValue)
import Plutarch.Api.V1.AssocMap (plookup)
import Plutarch.Api.V2 (
  AmountGuarantees,
  KeyGuarantees,
  PMintingPolicy,
  PScriptPurpose (PMinting),
  PTxInInfo,
  PTxOutRef,
 )
import Plutarch.Builtin (ppairDataBuiltin)
import Plutarch.Extra.Field (pletAll)
import Plutarch.Extra.List (ptryFromSingleton)
import Plutarch.Extra.Maybe (pfromJust)

{- | Adds a state thread to a minting policy.
 Parameterized at the Haskell level.

 @since 3.19.0
-}
withStateThread ::
  forall (s :: S).
  -- | Minting policy to wrap
  Term s PMintingPolicy ->
  -- | Initial spend
  Term s PTxOutRef ->
  Term s PMintingPolicy
withStateThread :: forall (s :: S).
Term s PMintingPolicy -> Term s PTxOutRef -> Term s PMintingPolicy
withStateThread = forall (s :: S).
(forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees).
 Term s PCurrencySymbol
 -> Term s (PValue keys amounts) -> Term s PBool)
-> Term s PMintingPolicy
-> Term s PTxOutRef
-> Term s PMintingPolicy
withStateThreadGeneric forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees)
       (s :: S).
Term s PCurrencySymbol
-> Term s (PValue keys amounts) -> Term s PBool
uniqueStateTokenMint

{- | Adds a state thread to a minting policy.
 Parameterized at the Plutarch level

 @since 3.19.0
-}
pwithStateThread ::
  forall (s :: S).
  Term s (PMintingPolicy :--> PTxOutRef :--> PMintingPolicy)
pwithStateThread :: forall (s :: S).
Term s (PMintingPolicy :--> (PTxOutRef :--> PMintingPolicy))
pwithStateThread = forall a (b :: PType) (s :: S) (c :: PType).
(PLamN a b s, HasCallStack) =>
(Term s c -> a) -> Term s (c :--> b)
plam forall (s :: S).
Term s PMintingPolicy -> Term s PTxOutRef -> Term s PMintingPolicy
withStateThread

{- | Adds a state thread to a minting policy
 allowing more than one state thread token to be minted
 Parameterized at the Haskell level.

 @since 3.21.0
-}
withStateThreadMulti ::
  forall (s :: S).
  -- | Minting policy to wrap
  Term s PMintingPolicy ->
  -- | Initial spend
  Term s PTxOutRef ->
  Term s PMintingPolicy
withStateThreadMulti :: forall (s :: S).
Term s PMintingPolicy -> Term s PTxOutRef -> Term s PMintingPolicy
withStateThreadMulti = forall (s :: S).
(forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees).
 Term s PCurrencySymbol
 -> Term s (PValue keys amounts) -> Term s PBool)
-> Term s PMintingPolicy
-> Term s PTxOutRef
-> Term s PMintingPolicy
withStateThreadGeneric forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees)
       (s :: S).
Term s PCurrencySymbol
-> Term s (PValue keys amounts) -> Term s PBool
uniqueStateTokensMint

{- | Adds a state thread to a minting policy
 allowing more than one state thread token to be minted
 Parameterized at the Plutarch level.

 @since 3.21.0
-}
pwithStateThreadMulti ::
  forall (s :: S).
  Term s (PMintingPolicy :--> PTxOutRef :--> PMintingPolicy)
pwithStateThreadMulti :: forall (s :: S).
Term s (PMintingPolicy :--> (PTxOutRef :--> PMintingPolicy))
pwithStateThreadMulti = forall a (b :: PType) (s :: S) (c :: PType).
(PLamN a b s, HasCallStack) =>
(Term s c -> a) -> Term s (c :--> b)
plam forall (s :: S).
Term s PMintingPolicy -> Term s PTxOutRef -> Term s PMintingPolicy
withStateThreadMulti

-- Helpers

{- | Adds a state thread to a minting policy.
 Parameterized at the Haskell level,
 with parametrized check on minted assets.

 @since 3.21.0
-}
withStateThreadGeneric ::
  forall (s :: S).
  ( forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees).
    Term s PCurrencySymbol ->
    Term s (PValue keys amounts) ->
    Term s PBool
  ) ->
  -- | Minting policy to wrap
  Term s PMintingPolicy ->
  -- | Initial spend
  Term s PTxOutRef ->
  Term s PMintingPolicy
withStateThreadGeneric :: forall (s :: S).
(forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees).
 Term s PCurrencySymbol
 -> Term s (PValue keys amounts) -> Term s PBool)
-> Term s PMintingPolicy
-> Term s PTxOutRef
-> Term s PMintingPolicy
withStateThreadGeneric forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees).
Term s PCurrencySymbol
-> Term s (PValue keys amounts) -> Term s PBool
checkMint Term s PMintingPolicy
mp Term s PTxOutRef
ref = forall a (b :: PType) (s :: S) (c :: PType).
(PLamN a b s, HasCallStack) =>
(Term s c -> a) -> Term s (c :--> b)
plam forall a b. (a -> b) -> a -> b
$ \Term s PData
red Term s PScriptContext
ctx -> forall (a :: PType) (s :: S) (b :: PType) (ps :: [PLabeledType])
       (bs :: [ToBind]).
(PDataFields a, ps ~ PFields a, bs ~ Bindings ps (BindAll ps),
 BindFields ps bs) =>
Term s a -> (HRecOf a (BindAll ps) s -> Term s b) -> Term s b
pletAll Term s PScriptContext
ctx forall a b. (a -> b) -> a -> b
$ \HRecOf
  PScriptContext
  (BindAll '[ "txInfo" ':= PTxInfo, "purpose" ':= PScriptPurpose])
  s
ctx' ->
  forall (fs :: [Symbol]) (a :: PType) (s :: S) (b :: PType)
       (ps :: [PLabeledType]) (bs :: [ToBind]).
(PDataFields a, ps ~ PFields a, bs ~ Bindings ps fs,
 BindFields ps bs) =>
Term s a -> (HRecOf a fs s -> Term s b) -> Term s b
pletFields @'["inputs", "mint"] (forall {k} (x :: k) r a. HasField x r a => r -> a
getField @"txInfo" HRecOf
  PScriptContext
  (BindAll '[ "txInfo" ':= PTxInfo, "purpose" ':= PScriptPurpose])
  s
ctx') forall a b. (a -> b) -> a -> b
$ \HRec
  (BoundTerms
     (PFields (PAsData PTxInfo))
     (Bindings (PFields (PAsData PTxInfo)) '["inputs", "mint"])
     s)
txInfo ->
    forall (a :: PType) (s :: S) (b :: PType).
PlutusType a =>
Term s a -> (a s -> Term s b) -> Term s b
pmatch (forall {k} (x :: k) r a. HasField x r a => r -> a
getField @"purpose" HRecOf
  PScriptContext
  (BindAll '[ "txInfo" ':= PTxInfo, "purpose" ':= PScriptPurpose])
  s
ctx') forall a b. (a -> b) -> a -> b
$ \case
      PMinting Term s (PDataRecord '[ "_0" ':= PCurrencySymbol])
thisPolicy ->
        forall (s :: S) (a :: PType).
Term s PBool -> Term s a -> Term s a -> Term s a
pif
          (forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees).
Term s PCurrencySymbol
-> Term s (PValue keys amounts) -> Term s PBool
checkMint (forall (name :: Symbol) (b :: PType) (p :: PType) (s :: S)
       (a :: PType) (as :: [PLabeledType]) (n :: Nat).
(PDataFields p, as ~ PFields p, n ~ PLabelIndex name as,
 KnownNat n, a ~ PUnLabel (IndexList n as), PFromDataable a b) =>
Term s (p :--> b)
pfield @"_0" forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# Term s (PDataRecord '[ "_0" ':= PCurrencySymbol])
thisPolicy) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {k} (x :: k) r a. HasField x r a => r -> a
getField @"mint" forall a b. (a -> b) -> a -> b
$ HRec
  (BoundTerms
     (PFields (PAsData PTxInfo))
     (Bindings (PFields (PAsData PTxInfo)) '["inputs", "mint"])
     s)
txInfo)
          ( forall (s :: S) (a :: PType).
Term s PBool -> Term s a -> Term s a -> Term s a
pif
              (forall (list :: PType -> PType) (a :: PType) (s :: S).
PIsListLike list a =>
Term s ((a :--> PBool) :--> (list a :--> PBool))
pany forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# (forall (s :: S). Term s (PTxOutRef :--> (PTxInInfo :--> PBool))
hasUniqueInput forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# Term s PTxOutRef
ref) forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# forall {k} (x :: k) r a. HasField x r a => r -> a
getField @"inputs" HRec
  (BoundTerms
     (PFields (PAsData PTxInfo))
     (Bindings (PFields (PAsData PTxInfo)) '["inputs", "mint"])
     s)
txInfo)
              (Term s PMintingPolicy
mp forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# Term s PData
red forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# Term s PScriptContext
ctx)
              (forall (s :: S) (a :: PType). Term s PString -> Term s a
ptraceError Term s PString
"stateThread: Unique input not found")
          )
          (forall (s :: S) (a :: PType). Term s PString -> Term s a
ptraceError Term s PString
"stateThread: Not minting a unique state token")
      PScriptPurpose s
_ -> forall (s :: S) (a :: PType). Term s PString -> Term s a
ptraceError Term s PString
"stateThread: Not a minting script purpose"

uniqueStateTokenMint ::
  forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
  Term s PCurrencySymbol ->
  Term s (PValue keys amounts) ->
  Term s PBool
uniqueStateTokenMint :: forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees)
       (s :: S).
Term s PCurrencySymbol
-> Term s (PValue keys amounts) -> Term s PBool
uniqueStateTokenMint Term s PCurrencySymbol
thisPolicy Term s (PValue keys amounts)
mint =
  let singleEmptyToken :: Term s (PBuiltinPair (PAsData PTokenName) (PAsData PInteger))
singleEmptyToken = forall (s :: S) (a :: PType) (b :: PType).
Term
  s
  (PAsData a
   :--> (PAsData b :--> PBuiltinPair (PAsData a) (PAsData b)))
ppairDataBuiltin forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# forall (a :: PType) (s :: S).
PIsData a =>
Term s a -> Term s (PAsData a)
pdata (forall (p :: PType) (s :: S). PLift p => PLifted p -> Term s p
pconstant PLifted PTokenName
"") forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# forall (a :: PType) (s :: S).
PIsData a =>
Term s a -> Term s (PAsData a)
pdata Term s PInteger
1
   in forall (a :: PType) (list :: PType -> PType) (s :: S).
PIsListLike list a =>
Term s (list a :--> a)
ptryFromSingleton
        # pto (pfromJust #$ plookup # thisPolicy # pto mint)
        #== singleEmptyToken

uniqueStateTokensMint ::
  forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees) (s :: S).
  Term s PCurrencySymbol ->
  Term s (PValue keys amounts) ->
  Term s PBool
uniqueStateTokensMint :: forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees)
       (s :: S).
Term s PCurrencySymbol
-> Term s (PValue keys amounts) -> Term s PBool
uniqueStateTokensMint Term s PCurrencySymbol
thisPolicy Term s (PValue keys amounts)
mint =
  Term s PInteger
0 forall (t :: PType) (s :: S).
PPartialOrd t =>
Term s t -> Term s t -> Term s PBool
#< forall (a :: PType) (s :: S).
PIsData a =>
Term s (PAsData a) -> Term s a
pfromData (forall (s :: S) (a :: PType) (b :: PType).
Term s (PBuiltinPair a b :--> b)
psndBuiltin forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
#$ forall (a :: PType) (list :: PType -> PType) (s :: S).
PIsListLike list a =>
Term s (list a :--> a)
ptryFromSingleton forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# forall (s :: S) (a :: PType). Term s a -> Term s (PInner a)
pto (forall (a :: PType) (s :: S). Term s (PMaybe a :--> a)
pfromJust forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
#$ forall (k :: PType) (v :: PType) (s :: S) (any :: KeyGuarantees).
(PIsData k, PIsData v) =>
Term s (k :--> (PMap any k v :--> PMaybe v))
plookup forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# Term s PCurrencySymbol
thisPolicy forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# forall (s :: S) (a :: PType). Term s a -> Term s (PInner a)
pto Term s (PValue keys amounts)
mint))

hasUniqueInput ::
  forall (s :: S).
  Term s (PTxOutRef :--> PTxInInfo :--> PBool)
hasUniqueInput :: forall (s :: S). Term s (PTxOutRef :--> (PTxInInfo :--> PBool))
hasUniqueInput =
  forall a (b :: PType) (s :: S) (c :: PType).
(PLamN a b s, HasCallStack) =>
(Term s c -> a) -> Term s (c :--> b)
plam forall a b. (a -> b) -> a -> b
$ \Term s PTxOutRef
ref Term s PTxInInfo
txInInfo -> Term s PTxOutRef
ref forall (t :: PType) (s :: S).
PEq t =>
Term s t -> Term s t -> Term s PBool
#== (forall (name :: Symbol) (b :: PType) (p :: PType) (s :: S)
       (a :: PType) (as :: [PLabeledType]) (n :: Nat).
(PDataFields p, as ~ PFields p, n ~ PLabelIndex name as,
 KnownNat n, a ~ PUnLabel (IndexList n as), PFromDataable a b) =>
Term s (p :--> b)
pfield @"outRef" forall (s :: S) (a :: PType) (b :: PType).
HasCallStack =>
Term s (a :--> b) -> Term s a -> Term s b
# Term s PTxInInfo
txInInfo)