agora/agora/Agora/Utils.hs

{-# LANGUAGE QuantifiedConstraints #-}

{- |
Module     : Agora.Utils
Maintainer : emi@haskell.fyi
Description: Plutarch utility functions that should be upstreamed or don't belong anywhere else.

Plutarch utility functions that should be upstreamed or don't belong anywhere else.
-}
module Agora.Utils (
  scriptHashToAddress,
  pstringIntercalate,
  punwords,
  pisNothing,
  pisDNothing,
  ptoScottEncodingT,
  ptaggedSymbolValueOf,
  ptag,
  puntag,
  phashDatum,
  puncurryTuple,
  psubtractSortedValue,
  pisSubValueOf,
  pfindInputWithStateThreadToken,
) where

import Plutarch.Api.V1 (AmountGuarantees (Positive), KeyGuarantees (Sorted))
import Plutarch.Api.V1.AssocMap (punionWith)
import Plutarch.Api.V1.AssocMap qualified as AssocMap
import Plutarch.Api.V1.Scripts (PDatumHash (PDatumHash))
import Plutarch.Api.V2 (
  AmountGuarantees (NoGuarantees),
  PCurrencySymbol,
  PMaybeData (PDNothing),
  PTuple,
  PTxInInfo,
  PValue,
 )
import Plutarch.Builtin (pforgetData, pserialiseData)
import Plutarch.Crypto (pblake2b_256)
import Plutarch.DataRepr (punDataSum)
import Plutarch.Extra.AssetClass (PAssetClass, PAssetClassData, ptoScottEncoding)
import Plutarch.Extra.Field (pletAll)
import Plutarch.Extra.Functor (PFunctor (pfmap))
import Plutarch.Extra.Tagged (PTagged)
import Plutarch.Extra.Value (psymbolValueOf)
import Plutarch.Num (PNum (pnegate, (#+)))
import Plutarch.Unsafe (punsafeCoerce, punsafeDowncast)
import PlutusLedgerApi.V2 (
  Address (Address),
  Credential (ScriptCredential),
  ScriptHash,
 )

{- | Create an 'Address' from a given 'ScriptHash' with no 'PlutusLedgerApi.V1.Credential.StakingCredential'.

     @since 1.0.0
-}
scriptHashToAddress :: ScriptHash -> Address
scriptHashToAddress vh = Address (ScriptCredential vh) Nothing

-- | @since 1.0.0
pstringIntercalate ::
  forall (s :: S).
  Term s PString ->
  [Term s PString] ->
  Term s PString
pstringIntercalate _ [x] = x
pstringIntercalate i (x : xs) = x <> i <> pstringIntercalate i xs
pstringIntercalate _ _ = ""

-- | @since 1.0.0
punwords ::
  forall (s :: S).
  [Term s PString] ->
  Term s PString
punwords = pstringIntercalate " "

-- | @since 1.0.0
pisNothing ::
  forall (a :: PType) (s :: S).
  Term s (PMaybe a :--> PBool)
pisNothing = phoistAcyclic $
  plam $
    flip pmatch $ \case
      PNothing -> pconstant True
      _ -> pconstant False

-- | @since 1.0.0
pisDNothing ::
  forall (a :: PType) (s :: S).
  Term s (PMaybeData a :--> PBool)
pisDNothing = phoistAcyclic $
  plam $
    flip pmatch $ \case
      PDNothing _ -> pconstant True
      _ -> pconstant False

-- | @since 1.0.0
ptoScottEncodingT ::
  forall {k :: Type} (unit :: k) (s :: S).
  Term s (PTagged unit PAssetClassData :--> PTagged unit PAssetClass)
ptoScottEncodingT = phoistAcyclic $
  plam $ \d ->
    punsafeDowncast $ ptoScottEncoding #$ pto d

{- | Get the sum of all values belonging to a particular tagged 'CurrencySymbol'.

     @since 1.0.0
-}
ptaggedSymbolValueOf ::
  forall
    {k :: Type}
    (unit :: k)
    (keys :: KeyGuarantees)
    (amounts :: AmountGuarantees)
    (s :: S).
  Term s (PTagged unit PCurrencySymbol :--> (PValue keys amounts :--> PInteger))
ptaggedSymbolValueOf = phoistAcyclic $ plam $ \tcs -> psymbolValueOf # pto tcs

-- | @since 1.0.0
ptag ::
  forall {k :: Type} (tag :: k) (a :: PType) (s :: S).
  Term s a ->
  Term s (PTagged tag a)
ptag = punsafeDowncast

-- | @since 1.0.0
puntag ::
  forall {k :: Type} (tag :: k) (a :: PType) (s :: S).
  Term s (PTagged tag a) ->
  Term s a
puntag = pto

{- | Hash the given datum using the correct algorithm(blake2b_256).

     Note: check the discussion here: https://github.com/input-output-hk/cardano-ledger/issues/2941.

     @since 1.0.0
-}
phashDatum ::
  forall (a :: PType) (s :: S).
  PIsData a =>
  Term s (a :--> PDatumHash)
phashDatum =
  phoistAcyclic $
    plam $
      pcon
        . PDatumHash
        . (pblake2b_256 #)
        . (pserialiseData #)
        . pforgetData
        . pdata

puncurryTuple ::
  forall (c :: PType) (a :: PType) (b :: PType) (s :: S).
  (PIsData a, PIsData b) =>
  Term s ((a :--> b :--> c) :--> PTuple a b :--> c)
puncurryTuple = phoistAcyclic $
  plam $
    \f ((punDataSum #) -> r) ->
      pletAll r $ \rF -> f # rF._0 # rF._1

psubtractSortedValue ::
  forall (ag :: AmountGuarantees) (s :: S).
  Term
    s
    ( PValue 'Sorted ag
        :--> PValue 'Sorted ag
        :--> PValue 'Sorted 'NoGuarantees
    )
psubtractSortedValue = phoistAcyclic $ plam $ \a b ->
  punsafeCoerce $
    punionWith
      # (punionWith # plam (#+))
      # pto a
      #$ pfmap
      # (pfmap # pnegate)
      # pto b

pisNonNegativeValue ::
  forall (kg :: KeyGuarantees) (am :: AmountGuarantees) (s :: S).
  Term s (PValue kg am :--> PBool)
pisNonNegativeValue =
  phoistAcyclic $
    plam $
      (AssocMap.pall # (AssocMap.pall # plam (0 #<=)) #)
        . pto

pisSubValueOf ::
  forall (s :: S).
  Term
    s
    ( PValue 'Sorted 'Positive
        :--> PValue 'Sorted 'Positive
        :--> PBool
    )
pisSubValueOf = phoistAcyclic $ plam $ \vl vr ->
  pisNonNegativeValue
    #$ psubtractSortedValue
    # vl
    # vr

{- | Find an input containing exactly one token with the given currency symbol

     @since 1.0.0
-}
pfindInputWithStateThreadToken ::
  forall tag.
  ClosedTerm
    ( PTagged tag PCurrencySymbol
        :--> PBuiltinList PTxInInfo
        :--> PMaybe PTxInInfo
    )
pfindInputWithStateThreadToken = plam $ \tokenSymbol inputs ->
  pfind
    # ( plam $ \input ->
          ptaggedSymbolValueOf
            # tokenSymbol
            # (pfield @"value" # (pfield @"resolved" # input))
            #== 1
      )
    # inputs