Merge pull request #235 from Liqwid-Labs/connor/treasury-effect

Treasury withdrawal effect rework

.gitignore

@@ -25,3 +25,8 @@ TAGS
 # Haddock files and Hoogle databases 
 haddock 
 hoo
+
+.pre-commit-config.yaml
+
+agora-test/goldens/agora.json
+agora-test/goldens/agoraDebug.json

agora-specs/Sample/Effect/TreasuryWithdrawal.hs

@@ -6,175 +6,208 @@ Description: Sample based testing for Treasury Withdrawal Effect
 This module provides samples for Treasury Withdrawal Effect tests.
 -}
 module Sample.Effect.TreasuryWithdrawal (
-  validator,
+  runEffect,
-  inputTreasury,
+  Parameters (..),
-  inputUser,
+  Validity (..),
-  inputGAT,
+  totallyValidParameters,
-  inputCollateral,
+  mkTestTree,
-  outputTreasury,
-  outputUser,
-  buildReceiversOutputFromDatum,
-  currSymbol,
-  users,
-  treasuries,
-  buildScriptContext,
 ) where
 
 import Agora.Effect.TreasuryWithdrawal (
-  TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
+  TreasuryWithdrawalDatum (..),
  )
+import Control.Composition ((.*))
+import Data.Foldable (Foldable (fold))
+import Data.List (singleton)
 import Data.Map ((!))
+import Data.Map.Ordered (OMap)
+import Data.Map.Ordered qualified as Map
+import Data.Semigroup (mtimesDefault)
 import Plutarch.Api.V2 (scriptHash)
+import Plutarch.Context (credential, input, mint, output, script, withInlineDatum, withRef, withRefTxId, withValue)
 import Plutarch.Script (Script)
-import PlutusLedgerApi.V1.Interval qualified as Interval (always)
+import PlutusLedgerApi.V1.Value qualified as Value (scale, singleton)
-import PlutusLedgerApi.V1.Value qualified as Value (singleton)
 import PlutusLedgerApi.V2 (
-  Address (Address),
   Credential (..),
-  CurrencySymbol,
+  TxId,
-  DatumHash (DatumHash),
-  OutputDatum (OutputDatumHash),
-  PubKeyHash,
-  Redeemer (Redeemer),
-  ScriptContext (..),
-  ScriptHash (ScriptHash),
-  ScriptPurpose (Spending),
-  TokenName (TokenName),
-  TxInInfo (TxInInfo),
-  TxInfo (..),
-  TxOut (..),
   TxOutRef (TxOutRef),
   Value,
-  toBuiltinData,
  )
-import PlutusTx.AssocMap qualified as AssocMap
+import PlutusLedgerApi.V3 (ScriptHash)
-import Sample.Shared (agoraScripts, authorityTokenSymbol)
+import Sample.Shared (agoraScripts, authorityTokenPolicy, authorityTokenSymbol, signer, signer2, trScriptHash, trValidator)
-import Test.Util (scriptCredentials, userCredentials)
+import Test.Specification (SpecificationTree, group, testPolicy, testValidator)
+import Test.Util (CombinableBuilder, mkMinting, mkSpending, subtractValue, validatorHashes)
 
--- | A sample Currency Symbol.
+data Parameters = Parameters
-currSymbol :: CurrencySymbol
+  { shouldDeliver ::
-currSymbol = authorityTokenSymbol
+      OMap Credential Value
+  , treasuryInputCount :: Integer
+  , badReceivedValue :: Bool
+  , badReceivers :: Bool
+  , badReceiverOrder :: Bool
+  , badTreasuryPaybackValue :: Bool
+  }
 
--- | A sample 'PubKeyHash'.
+data Validity = Validity
-signer :: PubKeyHash
+  { forGATPolicy :: Bool
-signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c"
+  , forEffectValidator :: Bool
+  , forTreasury :: Bool
+  }
 
--- | List of users who the effect will pay to.
+effectValidator :: Script
-users :: [Credential]
+effectValidator = agoraScripts ! "agora:treasuryWithdrawalValidator"
-users = userCredentials
 
--- | List of users who the effect will pay to.
+effectHash :: ScriptHash
-treasuries :: [Credential]
+effectHash = scriptHash effectValidator
-treasuries = scriptCredentials
 
-inputGAT :: TxInInfo
+mkEffectDatum :: Parameters -> TreasuryWithdrawalDatum
-inputGAT =
+mkEffectDatum ps =
-  TxInInfo
+  TreasuryWithdrawalDatum
-    (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+    { receivers = Map.assocs ps.shouldDeliver
-    TxOut
+    , treasuries = [ScriptCredential trScriptHash]
-      { txOutAddress = Address (ScriptCredential $ scriptHash validator) Nothing
-      , txOutValue = Value.singleton currSymbol validatorHashTN 1 -- Stake ST
-      , txOutDatum = OutputDatumHash (DatumHash "")
-      , txOutReferenceScript = Nothing
-      }
-
--- | Create an input given the index of the treasury and the 'Value' at this input.
-inputTreasury :: Int -> Value -> TxInInfo
-inputTreasury indx val =
-  TxInInfo
-    (TxOutRef "" 1)
-    TxOut
-      { txOutAddress = Address (treasuries !! indx) Nothing
-      , txOutValue = val
-      , txOutDatum = OutputDatumHash (DatumHash "")
-      , txOutReferenceScript = Nothing
-      }
-
--- | Create a input given the index of the user and the 'Value' at this input.
-inputUser :: Int -> Value -> TxInInfo
-inputUser indx val =
-  TxInInfo
-    (TxOutRef "" 1)
-    TxOut
-      { txOutAddress = Address (users !! indx) Nothing
-      , txOutValue = val
-      , txOutDatum = OutputDatumHash (DatumHash "")
-      , txOutReferenceScript = Nothing
-      }
-
--- | Create a input representing the collateral given by a user.
-inputCollateral :: Int -> TxInInfo
-inputCollateral indx =
-  TxInInfo -- Initiator
-    (TxOutRef "" 1)
-    TxOut
-      { txOutAddress = Address (users !! indx) Nothing
-      , txOutValue = Value.singleton "" "" 2000000
-      , txOutDatum = OutputDatumHash (DatumHash "")
-      , txOutReferenceScript = Nothing
-      }
-
--- | Create an output at the nth treasury with the given 'Value'.
-outputTreasury :: Int -> Value -> TxOut
-outputTreasury indx val =
-  TxOut
-    { txOutAddress = Address (treasuries !! indx) Nothing
-    , txOutValue = val
-    , txOutDatum = OutputDatumHash (DatumHash "")
-    , txOutReferenceScript = Nothing
     }
 
--- | Create an output at the nth user with the given 'Value'.
+effectRef :: TxOutRef
-outputUser :: Int -> Value -> TxOut
+effectRef = TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 0
-outputUser indx val =
+
-  TxOut
+treasuryTxId :: TxId
-    { txOutAddress = Address (users !! indx) Nothing
+treasuryTxId = "0ca36f3a357bc69579ab2531aecd1e7d3714d993c7820f40b864be15"
-    , txOutValue = val
+
-    , txOutDatum = OutputDatumHash (DatumHash "")
+mkEffectInputBuilder :: forall b. CombinableBuilder b => Parameters -> b
-    , txOutReferenceScript = Nothing
+mkEffectInputBuilder ps =
+  let mkGATValue = Value.singleton authorityTokenSymbol ""
+   in mconcat
+        [ mint $ mkGATValue (-1)
+        , input $
+            mconcat
+              [ script effectHash
+              , withRef effectRef
+              , withInlineDatum $ mkEffectDatum ps
+              , withValue $ mkGATValue 1
+              ]
+        ]
+
+mkTreasuryInputBuilder ::
+  forall b.
+  CombinableBuilder b =>
+  Parameters ->
+  b
+mkTreasuryInputBuilder ps =
+  mtimesDefault ps.treasuryInputCount $
+    input $
+      mconcat
+        [ script trScriptHash
+        , withRefTxId treasuryTxId
+        , withInlineDatum ()
+        , withValue $ fold ps.shouldDeliver
+        ]
+
+mkTreasuryPaybackOutputBuilder ::
+  forall b.
+  CombinableBuilder b =>
+  Parameters ->
+  b
+mkTreasuryPaybackOutputBuilder ps =
+  let sentAmount = fold ps.shouldDeliver
+      inputAmount =
+        flip Value.scale sentAmount $
+          if ps.badTreasuryPaybackValue
+            then 1
+            else ps.treasuryInputCount
+      paybackValue = inputAmount `subtractValue` sentAmount
+   in output $
+        mconcat
+          [ script trScriptHash
+          , withValue paybackValue
+          , withInlineDatum ()
+          ]
+
+mkReceiverOutputBuilder ::
+  forall b.
+  CombinableBuilder b =>
+  Parameters ->
+  b
+mkReceiverOutputBuilder ps =
+  let mkOutputValue =
+        if ps.badReceivedValue
+          then const $ Value.singleton "" "bruh" 1
+          else id
+      mkFinalOutputs =
+        mconcat
+          . (if ps.badReceiverOrder then reverse else id)
+          . (if ps.badReceivers then drop 1 else id)
+      mkOutput :: _ -> _ -> b
+      mkOutput cred value =
+        output $
+          mconcat
+            [ credential cred
+            , withValue $ mkOutputValue value
+            , withInlineDatum ()
+            ]
+      rawOutputs =
+        foldMap (uncurry $ singleton .* mkOutput) $
+          Map.assocs ps.shouldDeliver
+   in mkFinalOutputs rawOutputs
+
+runEffect :: forall b. CombinableBuilder b => Parameters -> b
+runEffect ps =
+  foldMap
+    ($ ps)
+    [ mkEffectInputBuilder
+    , mkTreasuryInputBuilder
+    , mkReceiverOutputBuilder
+    , mkTreasuryPaybackOutputBuilder
+    ]
+
+totallyValidParameters :: Parameters
+totallyValidParameters =
+  Parameters
+    { shouldDeliver =
+        Map.fromList
+          [ (PubKeyCredential signer, Value.singleton "" "" 42_000_000)
+          , (PubKeyCredential signer2, Value.singleton "" "" 42_000_000)
+          , (ScriptCredential (head validatorHashes), Value.singleton "" "" 42_000_000)
+          ]
+    , treasuryInputCount = 2
+    , badReceivedValue = False
+    , badReceivers = False
+    , badReceiverOrder = False
+    , badTreasuryPaybackValue = False
     }
 
--- | Create a list of the outputs that are required as encoded in 'TreasuryWithdrawalDatum'.
+mkTestTree ::
-buildReceiversOutputFromDatum :: TreasuryWithdrawalDatum -> [TxOut]
+  String ->
-buildReceiversOutputFromDatum (TreasuryWithdrawalDatum xs _) = f <$> xs
+  Parameters ->
+  Validity ->
+  SpecificationTree
+mkTestTree name ps val =
+  group name [effect, treasury, authority]
   where
-    f x =
+    spend = mkSpending runEffect ps
-      TxOut
+    mint = mkMinting runEffect ps
-        { txOutAddress = Address (fst x) Nothing
-        , txOutValue = snd x
-        , txOutDatum = OutputDatumHash (DatumHash "")
-        , txOutReferenceScript = Nothing
-        }
 
--- | Effect validator instance.
+    effect =
-validator :: Script
+      testValidator
-validator = agoraScripts ! "agora:treasuryWithdrawalValidator"
+        val.forEffectValidator
+        "effect"
+        effectValidator
+        (mkEffectDatum ps)
+        ()
+        (spend effectRef)
 
--- | 'TokenName' that represents the hash of the 'Agora.Stake.Stake' validator.
+    treasury =
-validatorHashTN :: TokenName
+      testValidator
-validatorHashTN = let ScriptHash hash = scriptHash validator in TokenName hash
+        val.forTreasury
+        "treasury"
+        trValidator
+        ()
+        ()
+        (spend $ TxOutRef treasuryTxId 1)
 
-buildScriptContext :: [TxInInfo] -> [TxOut] -> ScriptContext
+    authority =
-buildScriptContext inputs outputs =
+      testPolicy
-  let spending = Spending (TxOutRef "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be" 1)
+        val.forGATPolicy
-   in ScriptContext
+        "authority"
-        { scriptContextTxInfo =
+        authorityTokenPolicy
-            TxInfo
+        ()
-              { txInfoInputs = inputs
+        (mint authorityTokenSymbol)
-              , txInfoReferenceInputs = []
-              , txInfoOutputs = outputs
-              , txInfoFee = Value.singleton "" "" 2
-              , txInfoMint = Value.singleton currSymbol validatorHashTN (-1)
-              , txInfoDCert = []
-              , txInfoWdrl = AssocMap.empty
-              , txInfoValidRange = Interval.always
-              , txInfoSignatories = [signer]
-              , txInfoData = AssocMap.empty
-              , txInfoRedeemers =
-                  AssocMap.fromList
-                    [ (spending, Redeemer $ toBuiltinData ())
-                    ]
-              , txInfoId = "0b2086cbf8b6900f8cb65e012de4516cb66b5cb08a9aaba12a8b88be"
-              }
-        , scriptContextPurpose = spending
-        }

agora-specs/Sample/Shared.hs

@@ -58,6 +58,7 @@ module Sample.Shared (
   mockTrEffect,
   mockTrEffectHash,
   trValidator,
+  trScriptHash,
   trCredential,
   wrongEffHash,
 ) where
@@ -276,9 +277,12 @@ gatCs = authorityTokenSymbol
 trValidator :: Script
 trValidator = agoraScripts ! "agora:treasuryValidator"
 
+trScriptHash :: ScriptHash
+trScriptHash = scriptHash trValidator
+
 -- | `ScriptCredential` used for the dummy treasury validator.
 trCredential :: Credential
-trCredential = ScriptCredential $ scriptHash trValidator
+trCredential = ScriptCredential trScriptHash
 
 -- | `TokenName` for GAT generated from address of `mockTrEffect`.
 gatTn :: TokenName

agora-specs/Spec/Effect/TreasuryWithdrawal.hs

@@ -7,172 +7,44 @@ This module specs the Treasury Withdrawal Effect.
 -}
 module Spec.Effect.TreasuryWithdrawal (specs) where
 
-import Agora.Effect.TreasuryWithdrawal (
-  TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
- )
-import PlutusLedgerApi.V1.Value qualified as Value
 import Sample.Effect.TreasuryWithdrawal (
-  buildReceiversOutputFromDatum,
+  Parameters (..),
-  buildScriptContext,
+  Validity (..),
-  inputCollateral,
+  mkTestTree,
-  inputGAT,
+  totallyValidParameters,
-  inputTreasury,
-  inputUser,
-  outputTreasury,
-  outputUser,
-  treasuries,
-  users,
-  validator,
  )
 import Test.Specification (
   SpecificationTree,
-  effectFailsWith,
-  effectSucceedsWith,
-  group,
  )
-import Test.Util (sortValue)
 
 specs :: [SpecificationTree]
 specs =
-  [ group
+  [ mkTestTree
-      "effect"
+      "totally valid"
-      [ effectSucceedsWith
+      totallyValidParameters
-          "Simple"
+      Validity
-          validator
+        { forGATPolicy = True
-          datum1
+        , forEffectValidator = True
-          ( buildScriptContext
+        , forTreasury = True
-              [ inputGAT
+        }
-              , inputCollateral 10
+  , mkTestTree
-              , inputTreasury 1 (asset1 10)
+      "bad received value"
-              ]
+      totallyValidParameters
-              $ outputTreasury 1 (asset1 7)
+        { badReceivedValue = True
-                : buildReceiversOutputFromDatum datum1
+        }
-          )
+      Validity
-      , effectSucceedsWith
+        { forGATPolicy = True
-          "Simple with multiple treasuries "
+        , forEffectValidator = False
-          validator
+        , forTreasury = True
-          datum1
+        }
-          ( buildScriptContext
+  , mkTestTree
-              [ inputGAT
+      "bad receiver order"
-              , inputCollateral 10
+      totallyValidParameters
-              , inputTreasury 1 (asset1 10)
+        { badReceiverOrder = True
-              , inputTreasury 2 (asset1 100)
+        }
-              , inputTreasury 3 (asset1 500)
+      Validity
-              ]
+        { forGATPolicy = True
-              $ [ outputTreasury 1 (asset1 7)
+        , forEffectValidator = False
-                , outputTreasury 2 (asset1 100)
+        , forTreasury = True
-                , outputTreasury 3 (asset1 500)
+        }
-                ]
-                ++ buildReceiversOutputFromDatum datum1
-          )
-      , effectSucceedsWith
-          "Mixed Assets"
-          validator
-          datum2
-          ( buildScriptContext
-              [ inputGAT
-              , inputCollateral 10
-              , inputTreasury 1 (asset1 20)
-              , inputTreasury 2 (asset2 20)
-              ]
-              $ [ outputTreasury 1 (asset1 13)
-                , outputTreasury 2 (asset2 14)
-                ]
-                ++ buildReceiversOutputFromDatum datum2
-          )
-      , effectFailsWith
-          "Pay to uknown 3rd party"
-          validator
-          datum2
-          ( buildScriptContext
-              [ inputGAT
-              , inputCollateral 10
-              , inputTreasury 1 (asset1 20)
-              , inputTreasury 2 (asset2 20)
-              ]
-              $ [ outputUser 100 (asset1 2)
-                , outputTreasury 1 (asset1 11)
-                , outputTreasury 2 (asset2 14)
-                ]
-                ++ buildReceiversOutputFromDatum datum2
-          )
-      , effectFailsWith
-          "Missing receiver"
-          validator
-          datum2
-          ( buildScriptContext
-              [ inputGAT
-              , inputCollateral 10
-              , inputTreasury 1 (asset1 20)
-              , inputTreasury 2 (asset2 20)
-              ]
-              $ [ outputTreasury 1 (asset1 13)
-                , outputTreasury 2 (asset2 14)
-                ]
-                ++ drop 1 (buildReceiversOutputFromDatum datum2)
-          )
-      , effectFailsWith
-          "Unauthorized treasury"
-          validator
-          datum3
-          ( buildScriptContext
-              [ inputGAT
-              , inputCollateral 10
-              , inputTreasury 999 (asset1 20)
-              ]
-              $ outputTreasury 999 (asset1 17)
-                : buildReceiversOutputFromDatum datum3
-          )
-      , effectFailsWith
-          "Prevent transactions besides the withdrawal"
-          validator
-          datum3
-          ( buildScriptContext
-              [ inputGAT
-              , inputTreasury 1 (asset1 20)
-              , inputTreasury 999 (asset1 20)
-              , inputUser 99 (asset2 100)
-              ]
-              $ [ outputTreasury 1 (asset1 17)
-                , outputUser 100 (asset2 100)
-                ]
-                ++ buildReceiversOutputFromDatum datum3
-          )
-      ]
   ]
-  where
-    asset1 =
-      Value.singleton
-        "0d586e057e76238f8c56c0752507bfa45ae13b04f8497a311d4aaa48"
-        "OrangeBottle"
-    asset2 =
-      Value.singleton
-        "7e6aa764bceeba1f7acf47d20f1a2a85440afa2928f8ae96376f4d85"
-        "19721121"
-    datum1 =
-      TreasuryWithdrawalDatum
-        [ (head users, asset1 1)
-        , (users !! 1, asset1 1)
-        , (users !! 2, asset1 1)
-        ]
-        [ treasuries !! 1
-        , treasuries !! 2
-        , treasuries !! 3
-        ]
-    datum2 =
-      TreasuryWithdrawalDatum
-        [ (head users, sortValue $ asset2 5 <> asset1 4)
-        , (users !! 1, sortValue $ asset2 1 <> asset1 2)
-        , (users !! 2, asset1 1)
-        ]
-        [ head treasuries
-        , treasuries !! 1
-        , treasuries !! 2
-        ]
-    datum3 =
-      TreasuryWithdrawalDatum
-        [ (head users, asset1 1)
-        , (users !! 1, asset1 1)
-        , (users !! 2, asset1 1)
-        ]
-        [treasuries !! 1]

agora-test/Golden.hs

@@ -2,7 +2,6 @@ module Golden (testGolden) where
 
 import Agora.Bootstrap qualified as Bootstrap
 import Agora.Linker (linker)
-import Data.ByteString.Lazy qualified as LBS
 import Data.Text qualified as Text
 import Plutarch (Config (Config), TracingMode (DoTracing, NoTracing))
 import ScriptExport.File qualified as ScriptExport
@@ -10,7 +9,7 @@ import ScriptExport.Options qualified as ScriptExport
 import ScriptExport.Types qualified as ScriptExport
 import System.Directory (createDirectoryIfMissing)
 import Test.Tasty (TestTree, testGroup)
-import Test.Tasty.Golden (goldenVsString)
+import Test.Tasty.Golden (goldenVsFile)
 import Test.Tasty.Providers (TestName)
 
 builders :: ScriptExport.Builders
@@ -30,15 +29,24 @@ testGolden =
 
 goldenTest :: TestName -> FilePath -> TestTree
 goldenTest builder outputPath =
-  goldenVsString
+  let mkFilename suffix = outputPath <> builder <> suffix <> ".json"
-    builder
+      goldenFilename = mkFilename "-golden"
-    (outputPath <> builder <> "-golden.json")
+      sampleFilename = mkFilename ""
-    (callExportScript builder outputPath)
+   in goldenVsFile
+        builder
+        goldenFilename
+        sampleFilename
+        $ callExportScript builder outputPath
 
 -- Call the script server and generate an unapplied script set.
-callExportScript :: String -> FilePath -> IO LBS.ByteString
+callExportScript :: String -> FilePath -> IO ()
 callExportScript builder outputPath = do
   _ <- createDirectoryIfMissing False outputPath
-  let sampleFilePath = outputPath <> builder <> ".json"
+  ScriptExport.runFile
-  ScriptExport.runFile builders (ScriptExport.FileOptions {out = outputPath, param = "", builder = Text.pack builder})
+    builders
-  LBS.readFile sampleFilePath
+    ( ScriptExport.FileOptions
+        { out = outputPath
+        , param = ""
+        , builder = Text.pack builder
+        }
+    )

agora-test/goldens/agora-golden.json

@@ -112,12 +112,12 @@
             "version": "ScriptV2"
         },
         "agora:treasuryWithdrawalValidator": {
-            "cborHex": "59058259057f010000323232323232323232323232323232323232323232323232323222223232323232323232323232323253330253370e9001001099192999813a9980f19b873301400f375660566460546054605400260520026466e052000001480084cdc3999119981311119a9998168008912800899111801001991911980080180118178011818000918009119993802200130050023300600500113248001262300300100123253330293233333301902d03037520246eacc0b8c0b00048c8c8c94ccc0b8cdc3a40000042940528981980118178009baa302f3030302f00214a2605c00226602c0226eacc0b4c0acc0b800458c8c0b4c0ac004c0b4004dd61815800a400426464a6660526603e46464a6604aa6604a664466ebcdd398198011ba73033001303000200713301f00137586060605c00a2646464a66605e66e1d200200214a02944c0d0008c0c0004dd5000991818181880099181818188009817981680098178009bac302d00115333029357466664604e444a66605c0022004266006660080046062002605e0024464646666464605844a666064002244a0022a6660626006606a002264446004006606600226644660024644460040066006002244a0026060606a00260046066002466ebc004008c8cdd2a40006605a0046605a0020466062605e00400840022a66605a660400026eb0c0c4c0bc018401058c8c0c4c0c8004c0c0004c0c0004dd618168011bac302d302b302b00114985858c0b4c0b003cdd60090b1815981500698148008b181500118130009baa302630240095333022001149858c08800ccc04c8c8c8c8c80154ccc08ccdc3a400000426464a66604a66e1cdc6800a4070264649329998138008a4c2c604e0062c6eb8004c09c00454ccc08ccdc3a400400426464a66604a66e1cdc6800a4070264649329998138008a4c2c604e0062c6eb8004c09c00458c0a0008c090004dd50009bac0013022001301f0033301023232323200553330203370e900000109919191919191919191919191924ca66605a0022930b1816803192999815999119811918019bab3034001001233223302423003375a606a002002466e212000001001001100116375600860486eac00ccc0908cdd819192999815a9981219b87001480004cdc3800a40702605c0062c6e34004dd71816000991919181900218131bab30310033302623376064a66605866e24dc6800a40802605e0042c6eb8c0b8004c8c0c8008dd698188008009bab302f00100137560026054002604e00ca66604866e1d20000021323253330263370e6e340052038132324994ccc0a000452616302800316375c00260500022a66604866e1d20020021323253330263370e6e340052038132324994ccc0a000452616302800316375c00260500022c6052004604a0026ea8004c09000458c094008c084004dd50009bac001301f001375800a603c0046eb801000488cccccc00c05c068dd480100091998039119b80375a603a00400290001bab0011480008888cccc014cc0180100080048c888c00800cc01000448940048c038894ccc05000448940044ccc00cc05c004888c00800c4c008c0540048894ccc048cdd78011801800891180100189128009118069129998098008801899802180b0009801180a000918059129998088008a50153330103375e602800200629444c008c0480048c028894ccc04000440104cc038c00cc04c004c008c0440052f5c04601044a66601c002294454cc010c00cc0440044c008c03c00488ccc02c00800400c5281198040008010a512333003225333009001120041322533300a300100216133004300c0032337200020066eb8c02cc0300040049281180111299980400088028998031801980580098011804800919180111980100100091801119801001000a5eb7bdb1815d02b9a5573eae8955ceaba1230023754002aae79",
+            "cborHex": "590718590715010000323232323232323232323232323232323232323232323232323232323232323232323232323232323222223232323232323232323232323253330343370e900100109919299981b29981699b873301400f375660746460726072607200260700026466e052000001480084cdc3999119981a91119981080091800911999380220013005002330060050011324800126302700200123253330383233333301903c03f37520246eacc0f4c0ec0048c8c8c94ccc0f4cdc3a400000429405289821001181f0009baa303e303f303e00214a2607a00226602c0226eacc0f0c0e8c0f400458c8c0f0c0e8004c0f0004dd6181d000a400426464a66607066058605a466e1c005200033302070266446660466048e04008004cc0708c8c8c94ccc0f14cc0d4cc88cdd79ba73043002374e608600260800060102646464a66607e66e1d200200214a02944c110008c100004dd5000881d0a99981e198160009bac3040303e006137566080607c0042c6460806082002607e002607e607c6078002607c0026eb0c0f0004cc0708cc0a888004004dd6181e0011980e119299981d1981519181f9820000981f0009bac303e303c00413756607c60780022070607c00266606a444a66607800420022a6660780022c264a6660786605a44a6606a64646464a66608466e1d2002002132323253330453370e90000010a5013375e6e9c010dd3800982500118230009baa004132323253330453370e90010010a5013375e6e9c010dd3800982500118230009baa0043047002304300137540066460866088002608400626466ebcdd30011ba60013756608460800066080006266008607c006607c0042c6080607e0026eb0c0f0008dd6181e181d181d0008a4c2c6078607601e6eb004858c0e8c0e4034c0e000458c0e4008c0d4004dd5181a9819804a9998188008a4c2c60620066604046464646400aa66606466e1d20000021323253330343370e6e340052038132324994ccc0d800452616303600316375c002606c0022a66606466e1d20020021323253330343370e6e340052038132324994ccc0d800452616303600316375c002606c0022c606e00460660026ea8004dd6000981880098170019980e919191919002a99981799b87480000084c8c8c8c8c8c8c8c8c8c8c8c8c926533303c001149858c0f0018c94ccc0e8cc0b88cc0c08cdc42400000200200220022c6eac010c0ccdd580199819919bb03232533303a5330333370e0029000099b87001480e04c0f400c58dc68009bae303b00132323230410043035375660800066606a466ec0c94ccc0eccdc49b8d001481004c0f800858dd7181e8009918208011bad30400010013756607c0020026eac004c0e4004c0d80194ccc0cccdc3a400000426464a66606a66e1cdc6800a40702646493299981b8008a4c2c606e0062c6eb8004c0dc00454ccc0cccdc3a400400426464a66606a66e1cdc6800a40702646493299981b8008a4c2c606e0062c6eb8004c0dc00458c0e0008c0d0004dd500098198008b181a00118180009baa0013758002605c0026eb0014c0b4008dd7002000911999998018130149ba9002001233300722337006eb4c0b000800520003756002290001111199980299803002001000919111801001980200089128009180e9129998118008912800899980198130009111801001898011812000911299981099baf00230030011223002003122500122301c22533302200110031330043025001300230230012233003300d00200130182223330040012300122333008220013005002330060050011300c49894ccc07000448940044c888c00800cc8c88cc00400c008c078008c07c004888ccc011c00010009111998021119980380280100080100091801911ba63300337560046eac0048c00888dd4198019bad002375a002444666600800644004004002460246004002446464466002006004444a6660340022660300060042646464a66603866ebc0080044cc06ccdd8001198049811003181100199980411001002980f0020a99980e19b90375c0046eb80044cc06c018cccc0208800400cc0780100144cc06c00ccccc02088004018014c078010c078008c074010c074004894ccc06000840044cccc00c88004c06c008c064008004804488c0080048c038894ccc0500045280a99980999baf301700100314a226004602a002446466006602c0026eacc058c050004c0580048c030894ccc04800440104cc040c00cc054004c008c04c0052f5c04466008460066eacc05400400488cc00c8c00cdd6980a000800918041129998070008a5115330043003301100113002300f0012233300b00200100314a046601000200429448ccc00c894ccc024004480104c894ccc028c004008584cc010c03000c8cdc80008019bae300b300c00100124a04600444a666010002200a26600c600660160026004601200246460044660040040024600446600400400297adef6c605740ae6955cfaba25573aae848c008dd5000aab9e1",
             "description": "agora:treasuryWithdrawalValidator",
             "params": [
                 "Ply.Core.Types:AsData#Data.Tagged:Tagged#GHC.TypeLits:\"AuthorityTokenTag\"#PlutusLedgerApi.V1.Value:CurrencySymbol"
             ],
-            "rawHex": "59057f010000323232323232323232323232323232323232323232323232323222223232323232323232323232323253330253370e9001001099192999813a9980f19b873301400f375660566460546054605400260520026466e052000001480084cdc3999119981311119a9998168008912800899111801001991911980080180118178011818000918009119993802200130050023300600500113248001262300300100123253330293233333301902d03037520246eacc0b8c0b00048c8c8c94ccc0b8cdc3a40000042940528981980118178009baa302f3030302f00214a2605c00226602c0226eacc0b4c0acc0b800458c8c0b4c0ac004c0b4004dd61815800a400426464a6660526603e46464a6604aa6604a664466ebcdd398198011ba73033001303000200713301f00137586060605c00a2646464a66605e66e1d200200214a02944c0d0008c0c0004dd5000991818181880099181818188009817981680098178009bac302d00115333029357466664604e444a66605c0022004266006660080046062002605e0024464646666464605844a666064002244a0022a6660626006606a002264446004006606600226644660024644460040066006002244a0026060606a00260046066002466ebc004008c8cdd2a40006605a0046605a0020466062605e00400840022a66605a660400026eb0c0c4c0bc018401058c8c0c4c0c8004c0c0004c0c0004dd618168011bac302d302b302b00114985858c0b4c0b003cdd60090b1815981500698148008b181500118130009baa302630240095333022001149858c08800ccc04c8c8c8c8c80154ccc08ccdc3a400000426464a66604a66e1cdc6800a4070264649329998138008a4c2c604e0062c6eb8004c09c00454ccc08ccdc3a400400426464a66604a66e1cdc6800a4070264649329998138008a4c2c604e0062c6eb8004c09c00458c0a0008c090004dd50009bac0013022001301f0033301023232323200553330203370e900000109919191919191919191919191924ca66605a0022930b1816803192999815999119811918019bab3034001001233223302423003375a606a002002466e212000001001001100116375600860486eac00ccc0908cdd819192999815a9981219b87001480004cdc3800a40702605c0062c6e34004dd71816000991919181900218131bab30310033302623376064a66605866e24dc6800a40802605e0042c6eb8c0b8004c8c0c8008dd698188008009bab302f00100137560026054002604e00ca66604866e1d20000021323253330263370e6e340052038132324994ccc0a000452616302800316375c00260500022a66604866e1d20020021323253330263370e6e340052038132324994ccc0a000452616302800316375c00260500022c6052004604a0026ea8004c09000458c094008c084004dd50009bac001301f001375800a603c0046eb801000488cccccc00c05c068dd480100091998039119b80375a603a00400290001bab0011480008888cccc014cc0180100080048c888c00800cc01000448940048c038894ccc05000448940044ccc00cc05c004888c00800c4c008c0540048894ccc048cdd78011801800891180100189128009118069129998098008801899802180b0009801180a000918059129998088008a50153330103375e602800200629444c008c0480048c028894ccc04000440104cc038c00cc04c004c008c0440052f5c04601044a66601c002294454cc010c00cc0440044c008c03c00488ccc02c00800400c5281198040008010a512333003225333009001120041322533300a300100216133004300c0032337200020066eb8c02cc0300040049281180111299980400088028998031801980580098011804800919180111980100100091801119801001000a5eb7bdb1815d02b9a5573eae8955ceaba1230023754002aae79",
+            "rawHex": "590715010000323232323232323232323232323232323232323232323232323232323232323232323232323232323222223232323232323232323232323253330343370e900100109919299981b29981699b873301400f375660746460726072607200260700026466e052000001480084cdc3999119981a91119981080091800911999380220013005002330060050011324800126302700200123253330383233333301903c03f37520246eacc0f4c0ec0048c8c8c94ccc0f4cdc3a400000429405289821001181f0009baa303e303f303e00214a2607a00226602c0226eacc0f0c0e8c0f400458c8c0f0c0e8004c0f0004dd6181d000a400426464a66607066058605a466e1c005200033302070266446660466048e04008004cc0708c8c8c94ccc0f14cc0d4cc88cdd79ba73043002374e608600260800060102646464a66607e66e1d200200214a02944c110008c100004dd5000881d0a99981e198160009bac3040303e006137566080607c0042c6460806082002607e002607e607c6078002607c0026eb0c0f0004cc0708cc0a888004004dd6181e0011980e119299981d1981519181f9820000981f0009bac303e303c00413756607c60780022070607c00266606a444a66607800420022a6660780022c264a6660786605a44a6606a64646464a66608466e1d2002002132323253330453370e90000010a5013375e6e9c010dd3800982500118230009baa004132323253330453370e90010010a5013375e6e9c010dd3800982500118230009baa0043047002304300137540066460866088002608400626466ebcdd30011ba60013756608460800066080006266008607c006607c0042c6080607e0026eb0c0f0008dd6181e181d181d0008a4c2c6078607601e6eb004858c0e8c0e4034c0e000458c0e4008c0d4004dd5181a9819804a9998188008a4c2c60620066604046464646400aa66606466e1d20000021323253330343370e6e340052038132324994ccc0d800452616303600316375c002606c0022a66606466e1d20020021323253330343370e6e340052038132324994ccc0d800452616303600316375c002606c0022c606e00460660026ea8004dd6000981880098170019980e919191919002a99981799b87480000084c8c8c8c8c8c8c8c8c8c8c8c8c926533303c001149858c0f0018c94ccc0e8cc0b88cc0c08cdc42400000200200220022c6eac010c0ccdd580199819919bb03232533303a5330333370e0029000099b87001480e04c0f400c58dc68009bae303b00132323230410043035375660800066606a466ec0c94ccc0eccdc49b8d001481004c0f800858dd7181e8009918208011bad30400010013756607c0020026eac004c0e4004c0d80194ccc0cccdc3a400000426464a66606a66e1cdc6800a40702646493299981b8008a4c2c606e0062c6eb8004c0dc00454ccc0cccdc3a400400426464a66606a66e1cdc6800a40702646493299981b8008a4c2c606e0062c6eb8004c0dc00458c0e0008c0d0004dd500098198008b181a00118180009baa0013758002605c0026eb0014c0b4008dd7002000911999998018130149ba9002001233300722337006eb4c0b000800520003756002290001111199980299803002001000919111801001980200089128009180e9129998118008912800899980198130009111801001898011812000911299981099baf00230030011223002003122500122301c22533302200110031330043025001300230230012233003300d00200130182223330040012300122333008220013005002330060050011300c49894ccc07000448940044c888c00800cc8c88cc00400c008c078008c07c004888ccc011c00010009111998021119980380280100080100091801911ba63300337560046eac0048c00888dd4198019bad002375a002444666600800644004004002460246004002446464466002006004444a6660340022660300060042646464a66603866ebc0080044cc06ccdd8001198049811003181100199980411001002980f0020a99980e19b90375c0046eb80044cc06c018cccc0208800400cc0780100144cc06c00ccccc02088004018014c078010c078008c074010c074004894ccc06000840044cccc00c88004c06c008c064008004804488c0080048c038894ccc0500045280a99980999baf301700100314a226004602a002446466006602c0026eacc058c050004c0580048c030894ccc04800440104cc040c00cc054004c008c04c0052f5c04466008460066eacc05400400488cc00c8c00cdd6980a000800918041129998070008a5115330043003301100113002300f0012233300b00200100314a046601000200429448ccc00c894ccc024004480104c894ccc028c004008584cc010c03000c8cdc80008019bae300b300c00100124a04600444a666010002200a26600c600660160026004601200246460044660040040024600446600400400297adef6c605740ae6955cfaba25573aae848c008dd5000aab9e1",
             "role": "ValidatorRole",
             "version": "ScriptV2"
         }

agora-testlib/Test/Util.hs

@@ -23,6 +23,7 @@ module Test.Util (
   mkSpending,
   mkMinting,
   CombinableBuilder,
+  subtractValue,
 ) where
 
 --------------------------------------------------------------------------------
@@ -45,6 +46,7 @@ import Plutarch.Context (
 import Plutarch.Crypto (pblake2b_256)
 import PlutusLedgerApi.V1.Interval qualified as PlutusTx
 import PlutusLedgerApi.V1.Value (Value (..))
+import PlutusLedgerApi.V1.Value qualified as Value
 import PlutusLedgerApi.V2 (
   Credential (
     PubKeyCredential,
@@ -212,3 +214,8 @@ mkMinting mkBuilder ps cs =
     mkBuilder ps <> withMinting cs
 
 type CombinableBuilder b = (Monoid b, Builder b)
+
+--------------------------------------------------------------------------------
+
+subtractValue :: Value -> Value -> Value
+subtractValue = Value.unionWith (-)

agora.cabal

@@ -226,7 +226,9 @@ library agora-specs
     Spec.Utils
 
   hs-source-dirs:  agora-specs
-  build-depends:   agora-testlib
+  build-depends:
+    , agora-testlib
+    , ordered-containers
 
 test-suite agora-test
   import:         lang, deps, plutarch-prelude, test-deps, test-opts

agora/Agora/Bootstrap.hs

@@ -67,7 +67,7 @@ agoraScripts' conf =
     , envelope "NoOp Validator" noOpValidator
     , envelope "Treasury Withdrawal Validator" treasuryWithdrawalValidator
     , envelope "Mutate Governor Validator" mutateGovernorValidator
-    , envelope "Always Succeeds Policy" $ ((plam $ \_ _ -> popaque $ pcon PUnit) :: Term s PMintingPolicy)
+    , envelope "Always Succeeds Policy" ((plam $ \_ _ -> popaque $ pcon PUnit) :: Term s PMintingPolicy)
     ]
   where
     envelope ::

agora/Agora/Effect/TreasuryWithdrawal.hs

@@ -8,20 +8,17 @@ Description: An Effect that withdraws treasury deposit
 An Effect that withdraws treasury deposit
 -}
 module Agora.Effect.TreasuryWithdrawal (
-  TreasuryWithdrawalDatum (TreasuryWithdrawalDatum),
+  TreasuryWithdrawalDatum (..),
   PTreasuryWithdrawalDatum (PTreasuryWithdrawalDatum),
   treasuryWithdrawalValidator,
 ) where
 
 import Agora.Effect (makeEffect)
 import Agora.SafeMoney (AuthorityTokenTag)
+import Agora.Utils (psubtractSortedValue, puncurryTuple)
 import Generics.SOP qualified as SOP
-import Plutarch.Api.V1 (
+import Plutarch.Api.V1 (PCredential, PCurrencySymbol, PValue)
-  PCredential,
+import Plutarch.Api.V1.Value (pforgetPositive)
-  PCurrencySymbol,
-  PValue,
-  ptuple,
- )
 import Plutarch.Api.V2 (
   AmountGuarantees (Positive),
   KeyGuarantees (Sorted),
@@ -42,11 +39,11 @@ import Plutarch.Extra.IsData (
  )
 import Plutarch.Extra.ScriptContext (pisPubKey)
 import Plutarch.Extra.Tagged (PTagged)
+import Plutarch.Extra.Traversable (pfoldMap)
 import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
 import PlutusLedgerApi.V1.Credential (Credential)
 import PlutusLedgerApi.V1.Value (Value)
 import PlutusTx qualified
-import "liqwid-plutarch-extra" Plutarch.Extra.List (pdeleteFirst)
 import "liqwid-plutarch-extra" Plutarch.Extra.TermCont (
   pguardC,
   pletC,
@@ -141,9 +138,11 @@ instance PTryFrom PData (PAsData PTreasuryWithdrawalDatum)
 
        2. Left over assets should be redirected back to Treasury
 
-     It can be more flexiable over...
+    The output order should be:
 
-     - The number of outputs themselves
+      1. Receiver outputs. They should be in the same order as the 'receivers' field of the datum.
+
+      2. Other outputs: treasury outputs, colleteral outputs, etc.
 
      @since 1.0.0
 -}
@@ -156,54 +155,117 @@ treasuryWithdrawalValidator = plam $
       datumF <- pletAllC datum
       txInfoF <- pletFieldsC @'["outputs", "inputs"] txInfo
 
-      let validateInput :: Term _ (PTxInInfo :--> PBool)
+      let
-          validateInput = plam $ \input -> unTermCont $ do
+        -- Validate the input and if it's from one of the treasuries,
-            inputF <- pletAllC input
+        --  return the value.
+        --
+        -- Only effect inputs, treasury inputs and public key inputs are
+        --  allowed.
+        extractTreasuryInputValue ::
+          Term _ (PTxInInfo :--> PValue 'Sorted 'Positive)
+        extractTreasuryInputValue = plam $ \input -> unTermCont $ do
+          inputF <- pletAllC input
+          resolvedF <- pletFieldsC @'["address", "value"] inputF.resolved
 
-            cred <-
+          cred <- pletC $ pfield @"credential" # resolvedF.address
-              pletC $
-                pfield @"credential"
-                  #$ pfield @"address"
-                  # inputF.resolved
 
-            pure $
+          let isEffectInput =
-              foldl1
+                ptraceIfTrue "Effect input" $
-                (#||)
+                  inputF.outRef #== effectInputRef
-                [ ptraceIfTrue "Effect input" $ inputF.outRef #== effectInputRef
+              isTreasuryInput =
-                , ptraceIfTrue "Treasury input" $ pelem # cred # datumF.treasuries
+                ptraceIfTrue "Treasury input" $
-                , ptraceIfTrue "Collateral input" $ pisPubKey # pfromData cred
+                  pelem # pdata cred # datumF.treasuries
-                ]
+              isPubkeyInput =
+                ptraceIfTrue "Pubkey input" $
+                  pisPubKey # cred
+          pure
+            $ pif
+              (isEffectInput #|| isPubkeyInput)
+              mempty
+            $ pif isTreasuryInput resolvedF.value
+            $ ptraceError "Unknown input"
 
-          validateOutput ::
+        treasuryInputAmount =
-            Term
+          pfoldMap
-              _
+            # extractTreasuryInputValue
-              ( PBuiltinList (PAsData (PTuple PCredential (PValue 'Sorted 'Positive)))
+            # txInfoF.inputs
-                  :--> PTxOut
-                  :--> PBuiltinList (PAsData (PTuple PCredential (PValue 'Sorted 'Positive)))
-              )
-          validateOutput = plam $ \receivers output -> unTermCont $ do
-            outputF <- pletFieldsC @'["address", "value"] output
-            cred <- pletC $ pfield @"credential" # pfromData outputF.address
 
-            let credValue = pdata $ ptuple # cred # outputF.value
+        sentAmout =
+          pfoldMap
+            # plam ((puncurryTuple # plam (const id) #) . pfromData)
+            # pfromData datumF.receivers
 
-                shouldSendToTreasury =
+        treasuryLeftOverAmount =
-                  pif
+          psubtractSortedValue
-                    (pelem # cred # datumF.treasuries)
+            # treasuryInputAmount
-                    receivers
+            # sentAmout
-                    (ptraceError "Invalid receiver")
 
-            pure $
+        remainingOutputs =
-              pmatch (pdeleteFirst # credValue # receivers) $ \case
+          ptrace "Check receiver outputs" $
-                PJust updatedReceivers ->
+            checkReceiverOutputs
-                  ptrace "Receiver output" updatedReceivers
+              # datumF.receivers
-                PNothing ->
+              # txInfoF.outputs
-                  ptrace "Treasury output" shouldSendToTreasury
 
-      pguardC "All input are valid" $
+        extractTreasuryOutputValue ::
-        pall # validateInput # txInfoF.inputs
+          Term _ (PTxOut :--> PValue 'Sorted 'Positive)
+        extractTreasuryOutputValue = plam $
+          flip (pletFields @'["address", "value"]) $ \outputF ->
+            let cred = pfield @"credential" # outputF.address
 
-      pguardC "All receiver get correct output" $
+                isTreasuryOutput =
-        pnull #$ pfoldl # validateOutput # datumF.receivers # txInfoF.outputs
+                  pelem # cred # datumF.treasuries
+             in pif
+                  isTreasuryOutput
+                  outputF.value
+                  mempty
+
+        -- Return the value if it'll be sent to one of the treasuries.
+        treasuryOutputAmount =
+          pfoldMap
+            # extractTreasuryOutputValue
+            # remainingOutputs
+
+      pguardC "Unused treasury should stay at treasury validators" $
+        treasuryLeftOverAmount #== pforgetPositive treasuryOutputAmount
 
       pure . popaque $ pconstant ()
+  where
+    -- Make sure that all the receivers get the correct payment and return the
+    --  remaining outputs.
+    checkReceiverOutputs ::
+      forall (s :: S).
+      Term
+        s
+        ( PBuiltinList
+            (PAsData (PTuple PCredential (PValue 'Sorted 'Positive)))
+            :--> PBuiltinList PTxOut
+            :--> PBuiltinList PTxOut
+        )
+    checkReceiverOutputs = pfix #$ plam $ \self receivers outputs ->
+      pelimList
+        ( \r rs ->
+            pelimList
+              ( \o os -> pletFields @'["value", "address"] o $ \oF ->
+                  let isValidReceiverOutput =
+                        puncurryTuple
+                          # plam
+                            ( \expCred expVal ->
+                                foldl1
+                                  (#&&)
+                                  [ ptraceIfFalse "Valid credential" $
+                                      expCred #== pfield @"credential" # oF.address
+                                  , ptraceIfFalse "Valid value" $
+                                      expVal #== oF.value
+                                  ]
+                            )
+                          # pfromData r
+                   in pif
+                        isValidReceiverOutput
+                        (self # rs # os)
+                        (ptraceError "Invalid receiver output")
+              )
+              (ptraceError "Unable to exhaust receivers")
+              outputs
+        )
+        outputs
+        receivers

agora/Agora/Utils.hs

@@ -18,22 +18,29 @@ module Agora.Utils (
   ptag,
   puntag,
   phashDatum,
+  puncurryTuple,
+  psubtractSortedValue,
 ) where
 
+import Plutarch.Api.V1 (KeyGuarantees (Sorted))
+import Plutarch.Api.V1.AssocMap (punionWith)
 import Plutarch.Api.V1.Scripts (PDatumHash (PDatumHash))
 import Plutarch.Api.V2 (
-  AmountGuarantees,
+  AmountGuarantees (NoGuarantees),
-  KeyGuarantees,
   PCurrencySymbol,
   PMaybeData (PDNothing),
+  PTuple,
   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.Tagged (PTagged)
 import Plutarch.Extra.Value (psymbolValueOf)
-import Plutarch.Unsafe (punsafeDowncast)
+import Plutarch.Num ((#-))
+import Plutarch.Unsafe (punsafeCoerce, punsafeDowncast)
 import PlutusLedgerApi.V2 (
   Address (Address),
   Credential (ScriptCredential),
@@ -139,3 +146,27 @@ phashDatum =
         . (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
+      # pto b