WIP Stake policy

agora.cabal

@@ -79,6 +79,7 @@ common deps
     , serialise
     , template-haskell
     , text
+    , generics-sop
 
 common test-deps
   build-depends:
@@ -95,6 +96,8 @@ library
   import:          lang, deps
   exposed-modules:
     Agora.AuthorityToken
+    Agora.Stake
+    Agora.Voting
     Agora.SafeMoney
     Agora.SafeMoney.QQ
   other-modules:

flake.lock

@@ -1400,7 +1400,6 @@
         "hercules-ci-effects": "hercules-ci-effects",
         "hs-memory": "hs-memory",
         "nixpkgs": [
-          "plutarch",
           "haskell-nix",
           "nixpkgs-unstable"
         ],
@@ -1410,17 +1409,17 @@
         "th-extras": "th-extras"
       },
       "locked": {
-        "lastModified": 1643799364,
-        "narHash": "sha256-ud/YkMtBKcx0yrHOboA7uTPtGCt5LCOipF0m2W6LqxU=",
+        "lastModified": 1644875667,
+        "narHash": "sha256-eNKEubOfkVGmDX1HbbCTbtIjEyXfxlYedrWuwhOLVrQ=",
         "owner": "Plutonomicon",
         "repo": "plutarch",
-        "rev": "1fd4db27152625184e559cfb465d225a0995a56b",
+        "rev": "a0cbe99921aad7c5df9239cb0240933e4d9b2eaa",
         "type": "github"
       },
       "original": {
         "owner": "Plutonomicon",
         "repo": "plutarch",
-        "rev": "1fd4db27152625184e559cfb465d225a0995a56b",
+        "rev": "a0cbe99921aad7c5df9239cb0240933e4d9b2eaa",
         "type": "github"
       }
     },

flake.nix

@@ -13,7 +13,7 @@
     "github:input-output-hk/plutus?rev=65bad0fd53e432974c3c203b1b1999161b6c2dce";
 
   inputs.plutarch.url =
-    "github:Plutonomicon/plutarch?rev=1fd4db27152625184e559cfb465d225a0995a56b";
+    "github:Plutonomicon/plutarch?rev=a0cbe99921aad7c5df9239cb0240933e4d9b2eaa";
 
   inputs.goblins.url =
     "github:input-output-hk/goblins?rev=cde90a2b27f79187ca8310b6549331e59595e7ba";

src/Agora/AuthorityToken.hs

@@ -37,9 +37,9 @@ newtype AuthorityToken = AuthorityToken
 
 authorityTokenPolicy ::
   AuthorityToken ->
-  Term s (PData :--> PData :--> PScriptContext :--> PUnit)
+  Term s (PData :--> PScriptContext :--> PUnit)
 authorityTokenPolicy params =
-  plam $ \_datum _redeemer ctx' ->
+  plam $ \_redeemer ctx' ->
     pmatch ctx' $ \(PScriptContext ctx) ->
       let txInfo' = pfromData $ pfield @"txInfo" # ctx
           purpose' = pfromData $ pfield @"purpose" # ctx

src/Agora/Stake.hs

@@ -0,0 +1,94 @@
+{-# LANGUAGE PolyKinds #-}
+
+-- | Vote-lockable stake UTXOs holding GT
+module Agora.Stake (
+  StakeDatum (..),
+  StakeAction (..),
+  Stake (..),
+  stakePolicy,
+) where
+
+--------------------------------------------------------------------------------
+
+import GHC.Generics qualified as GHC
+import Generics.SOP (Generic, I (I))
+import Prelude
+
+--------------------------------------------------------------------------------
+
+import Plutarch.Api.V1
+import Plutarch.DataRepr (
+  PDataFields,
+  PIsDataReprInstances (PIsDataReprInstances),
+ )
+import Plutarch.Internal
+import Plutarch.Prelude
+
+--------------------------------------------------------------------------------
+
+import Agora.SafeMoney
+
+--------------------------------------------------------------------------------
+
+data Stake (gt :: MoneyClass) = Stake
+
+data StakeAction (gt :: MoneyClass) (s :: S)
+  = -- | Deposit or withdraw a discrete amount of the staked governance token
+    DepositWithdraw (Term s (PDataRecord '["delta" ':= Discrete gt]))
+  | -- | Destroy a stake, retrieving its LQ, the minimum ADA and any other assets
+    Destroy (Term s (PDataRecord '[]))
+  deriving stock (GHC.Generic)
+  deriving anyclass (Generic)
+  deriving anyclass (PIsDataRepr)
+  deriving
+    (PlutusType, PIsData)
+    via PIsDataReprInstances (StakeAction gt)
+
+newtype StakeDatum (gt :: MoneyClass) (s :: S) = StakeDatum
+  { getStakeDatum ::
+      ( Term
+          s
+          ( PDataRecord
+              '[ "stakedAmount" ':= Discrete gt
+               , "owner" ':= PPubKeyHash
+               ]
+          )
+      )
+  }
+  deriving stock (GHC.Generic)
+  deriving anyclass (Generic)
+  deriving anyclass (PIsDataRepr)
+  deriving
+    (PlutusType, PIsData, PDataFields)
+    via (PIsDataReprInstances (StakeDatum gt))
+
+assert :: Term s PString -> Term s PBool -> TermCont @r s ()
+assert errorMessage check = TermCont $ \k -> pif check (k ()) (ptraceError errorMessage)
+
+pfindDatum :: Term s (PDatumHash :--> PTxInfo :--> PMaybe PDatum)
+pfindDatum = phoistAcyclic $
+  plam $ \_datumHash _txInfo -> unTermCont $ do
+    pure (pcon PNothing)
+
+stakePolicy ::
+  forall (gt :: MoneyClass) s.
+  Stake gt ->
+  Term s (PData :--> PScriptContext :--> PUnit)
+stakePolicy _stake =
+  plam $ \_redeemer ctx -> unTermCont $ do
+    PScriptContext ctx' <- tcont $ pmatch ctx
+    ctx'' <- tcont $ pletFields @'["txInfo", "purpose"] ctx'
+    PTxInfo txInfo <- tcont $ pmatch $ pfromData (hrecField @"txInfo" ctx'')
+    txInfo' <- tcont $ pletFields @'["signatories", "outputs"] txInfo
+    let outputs = hrecField @"outputs" txInfo'
+
+    assert "Created stake must be owned by a signer of this transaction" $
+      pany
+        # ( plam $ \txOut -> unTermCont $ do
+              PTxOut txOut' <- tcont $ pmatch (pfromData txOut)
+              _txOut'' <- tcont $ pletFields @'["value", "datumHash"] txOut'
+              pure (pcon PTrue)
+          )
+        # outputs
+
+    pure (pcon PUnit)

src/Agora/Voting.hs

@@ -0,0 +1,4 @@
+-- | Types for votes and vote counting
+module Agora.Voting (Vote (..)) where
+
+data Vote = InFavorOf | OpposedTo