content: {-# LANGUAGE TemplateHaskell #-}
  {-# LANGUAGE NoFieldSelectors #-}
  
  {- |
  Module     : Agora.Stake
  Maintainer : emi@haskell.fyi
  Description: Vote-lockable stake UTXOs holding GT.
  
  Vote-lockable stake UTXOs holding GT.
  -}
  module Agora.Stake (
    -- * Haskell-land
    StakeDatum (..),
    StakeRedeemer (..),
    ProposalAction (..),
    ProposalLock (..),
  
    -- * Plutarch-land
    PStakeDatum (..),
    PStakeRedeemer (..),
    PProposalAction (..),
    PProposalLock (..),
    PStakeRole (..),
  
    -- * Validation context
    PSignedBy (..),
    PSigContext (..),
    PStakeRedeemerContext (..),
    PStakeRedeemerHandlerContext (..),
    PProposalContext (..),
    PStakeRedeemerHandler,
    StakeRedeemerImpl (..),
  
    -- * Utility functions
    pstakeLocked,
    pnumCreatedProposals,
    pextractVoteOption,
    pgetStakeRoles,
    pisVoter,
    pisCreator,
    pisCosigner,
    pisIrrelevant,
    presolveStakeInputDatum,
  ) where
  
  import Agora.Proposal (
    PProposalDatum,
    PProposalId,
    PProposalRedeemer,
    PResultTag,
    ProposalId,
    ResultTag,
   )
  import Agora.Proposal.Time (PProposalTime)
  import Agora.SafeMoney (GTTag, StakeSTTag)
  import Data.Tagged (Tagged)
  import Generics.SOP qualified as SOP
  import Plutarch.Api.V1 (PCredential, PPOSIXTime)
  import Plutarch.Api.V2 (
    KeyGuarantees (Unsorted),
    PDatum,
    PDatumHash,
    PMap,
    PMaybeData,
    PTxInInfo,
    PTxInfo,
   )
  import Plutarch.DataRepr (
    DerivePConstantViaData (DerivePConstantViaData),
    PDataFields,
   )
  import Plutarch.Extra.Applicative (ppureIf)
  import Plutarch.Extra.AssetClass (PAssetClass)
  import Plutarch.Extra.IsData (
    DerivePConstantViaDataList (DerivePConstantViaDataList),
    ProductIsData (ProductIsData),
   )
  import Plutarch.Extra.Maybe (passertPJust, pjust, pnothing)
  import Plutarch.Extra.ScriptContext (ptryFromOutputDatum)
  import Plutarch.Extra.Sum (PSum (PSum))
  import Plutarch.Extra.Tagged (PTagged)
  import Plutarch.Extra.Traversable (pfoldMap)
  import Plutarch.Extra.Value (passetClassValueOfT)
  import Plutarch.Lift (PConstantDecl, PUnsafeLiftDecl (PLifted))
  import PlutusLedgerApi.V2 (Credential, POSIXTime)
  import PlutusTx qualified
  import "liqwid-plutarch-extra" Plutarch.Extra.List (pfindJust, pmapMaybe)
  
  --------------------------------------------------------------------------------
  
  {- | The action that was performed on a particular proposal.
  
       @since 1.0.0
  -}
  data ProposalAction
    = -- | The stake was used to create a proposal.
      --
      --   This kind of lock is placed upon the creation of a proposal, in order
      --    to limit creation of proposals per stake.
      --
      --   See also: https://github.com/Liqwid-Labs/agora/issues/68
      Created
    | -- | The stake was used to vote on a proposal.
      --
      --   This kind of lock is placed while voting on a proposal, in order to
      --    prevent depositing and withdrawing when votes are in place.
      Voted
        ResultTag
        -- ^ The option which was voted on. This allows votes to be retracted.
        POSIXTime
        -- ^ The upper bound of the transaction time range when the lock is created.
    | -- | The stake was used to cosign a proposal.`
      Cosigned
    deriving stock
      ( -- | @since 1.0.0
        Show
      , -- | @since 1.0.0
        Generic
      )
  
  PlutusTx.makeIsDataIndexed
    ''ProposalAction
    [ ('Created, 0)
    , ('Voted, 1)
    , ('Cosigned, 2)
    ]
  
  {- | Locks that are stored in the stake datums for various purposes.
  
       NOTE: Due to retracting votes always being possible,
       this lock will only lock with contention on the proposal.
  
       FIXME: Contention on Proposals could create contention
       on voting which in turn creates contention on stakers.
  
       Vaguely this is the dependency graph for this locking
       interaction. Both the stake validator and the proposal
       validator are only able to check for one another through
       the datum belonging to the ST:
  
       @
       ┌─────────────────┐   ┌────────────────────┐
       │ Stake Validator ├─┐ │ Proposal Validator │
       └────────┬────────┘ │ └──────┬─────┬───────┘
                │          │        │     │
                │        ┌─┼────────┘     │
                ▼        │ │              ▼
       ┌──────────────┐  │ │ ┌─────────────────┐
       │ Stake Policy │◄─┘ └►│ Proposal Policy │
       └──────────────┘      └─────────────────┘
       @
  
       @since 1.0.0
  -}
  data ProposalLock = ProposalLock
    { proposalId :: ProposalId
    -- ^ The identifier of the proposal.
    , action :: ProposalAction
    -- ^ The action that has been performed.
    }
    deriving stock
      ( -- | @since 0.1.0
        Show
      , -- | @since 0.1.0
        Generic
      )
    deriving anyclass
      ( -- | @since 0.1.0
        SOP.Generic
      )
    deriving
      ( -- | @since 0.1.0
        PlutusTx.ToData
      , -- | @since 0.1.0
        PlutusTx.FromData
      )
      via (ProductIsData ProposalLock)
  
  {- | Haskell-level redeemer for Stake scripts.
  
       @since 1.0.0
  -}
  data StakeRedeemer
    = -- | Deposit or withdraw a discrete amount of the staked governance token.
      --   Stake must be unlocked.
      DepositWithdraw (Tagged GTTag Integer)
    | -- | Destroy a stake, retrieving its GT, the minimum ADA and any other assets.
      --   Stake must be unlocked.
      Destroy
    | -- | Permit a Vote to be added onto a 'Agora.Proposal.Proposal'.
      --   This also adds a lock to the 'lockedBy' field. See 'ProposalLock'.
      --   This needs to be done in sync with casting a vote, otherwise
      --   it's possible for a lock to be permanently placed on the stake,
      --   and then the funds are lost.
      PermitVote
    | -- | Retract a vote, removing it from the 'lockedBy' field. See 'ProposalLock'.
      --   This action checks for permission of the 'Agora.Proposal.Proposal'. Finished proposals are
      --   always allowed to have votes retracted and won't affect the Proposal datum,
      --   allowing 'Stake's to be unlocked.
      RetractVotes
    | -- | The owner can delegate the stake to another user, allowing the
      --    delegate to vote on prooposals with the stake.
      DelegateTo Credential
    | -- | Revoke the existing delegation.
      ClearDelegate
    deriving stock
      ( -- | @since 0.1.0
        Show
      , -- | @since 0.1.0
        Generic
      )
  
  PlutusTx.makeIsDataIndexed
    ''StakeRedeemer
    [ ('DepositWithdraw, 0)
    , ('Destroy, 1)
    , ('PermitVote, 2)
    , ('RetractVotes, 3)
    , ('DelegateTo, 4)
    , ('ClearDelegate, 5)
    ]
  
  {- | Haskell-level datum for Stake scripts.
  
       @since 0.1.0
  -}
  data StakeDatum = StakeDatum
    { stakedAmount :: Tagged GTTag Integer
    -- ^ Tracks the amount of governance token staked in the datum.
    --   This also acts as the voting weight for 'Agora.Proposal.Proposal's.
    , owner :: Credential
    -- ^ The hash of the public key this stake belongs to.
    --
    -- TODO Support for MultiSig/Scripts is tracked here:
    --      https://github.com/Liqwid-Labs/agora/issues/45
    , delegatedTo :: Maybe Credential
    -- ^ To whom this stake has been delegated.
    , lockedBy :: [ProposalLock]
    -- ^ The current proposals locking this stake. This field must be empty
    --   for the stake to be usable for deposits and withdrawals.
    }
    deriving stock
      ( -- | @since 0.1.0
        Show
      , -- | @since 0.1.0
        Generic
      )
    deriving anyclass
      ( -- | @since 0.1.0
        SOP.Generic
      )
    deriving
      ( -- | @since 0.1.0
        PlutusTx.ToData
      , -- | @since 0.1.0
        PlutusTx.FromData
      )
      via (ProductIsData StakeDatum)
  
  --------------------------------------------------------------------------------
  
  {- | Plutarch-level datum for Stake scripts.
  
       @since 0.1.0
  -}
  newtype PStakeDatum (s :: S) = PStakeDatum
    { getStakeDatum ::
        Term
          s
          ( PDataRecord
              '[ "stakedAmount" ':= PTagged GTTag PInteger
               , "owner" ':= PCredential
               , "delegatedTo" ':= PMaybeData (PAsData PCredential)
               , "lockedBy" ':= PBuiltinList (PAsData PProposalLock)
               ]
          )
    }
    deriving stock
      ( -- | @since 0.1.0
        Generic
      )
    deriving anyclass
      ( -- | @since 0.1.0
        PlutusType
      , -- | @since 0.1.0
        PIsData
      , -- | @since 0.1.0
        PEq
      , -- | @since 1.0.0
        PDataFields
      , -- | @since 1.0.0
        PShow
      )
  
  -- | @since 1.0.0
  instance DerivePlutusType PStakeDatum where
    type DPTStrat _ = PlutusTypeNewtype
  
  -- | @since 1.0.0
  instance PUnsafeLiftDecl PStakeDatum where
    type PLifted PStakeDatum = StakeDatum
  
  -- | @since 0.1.0
  deriving via
    (DerivePConstantViaDataList StakeDatum PStakeDatum)
    instance
      (PConstantDecl StakeDatum)
  
  -- | @since 0.1.0
  instance PTryFrom PData (PAsData PStakeDatum)
  
  {- | Plutarch-level redeemer for Stake scripts.
  
       @since 1.0.0
  -}
  data PStakeRedeemer (s :: S)
    = -- | Deposit or withdraw a discrete amount of the staked governance token.
      PDepositWithdraw (Term s (PDataRecord '["delta" ':= PTagged GTTag PInteger]))
    | -- | Destroy a stake, retrieving its GT, the minimum ADA and any other assets.
      PDestroy (Term s (PDataRecord '[]))
    | PPermitVote (Term s (PDataRecord '[]))
    | PRetractVotes (Term s (PDataRecord '[]))
    | PDelegateTo (Term s (PDataRecord '["pkh" ':= PCredential]))
    | PClearDelegate (Term s (PDataRecord '[]))
    deriving stock
      ( -- | @since 0.1.0
        Generic
      )
    deriving anyclass
      ( -- | @since 0.1.0
        PlutusType
      , -- | @since 0.1.0
        PIsData
      )
  
  -- | @since 0.2.0
  instance DerivePlutusType PStakeRedeemer where
    type DPTStrat _ = PlutusTypeData
  
  -- | @since 0.1.0
  instance PTryFrom PData PStakeRedeemer
  
  -- | @since 0.1.0
  instance PUnsafeLiftDecl PStakeRedeemer where
    type PLifted PStakeRedeemer = StakeRedeemer
  
  -- | @since 0.1.0
  deriving via
    (DerivePConstantViaData StakeRedeemer PStakeRedeemer)
    instance
      (PConstantDecl StakeRedeemer)
  
  {- | Plutarch-level version of 'ProposalAction'.
  
      @since 1.0.0
  -}
  data PProposalAction (s :: S)
    = PCreated (Term s (PDataRecord '[]))
    | PVoted
        ( Term
            s
            ( PDataRecord
                '[ "votedFor" ':= PResultTag
                 , "createdAt" ':= PPOSIXTime
                 ]
            )
        )
    | PCosigned (Term s (PDataRecord '[]))
    deriving stock
      ( -- | @since 1.0.0
        Generic
      )
    deriving anyclass
      ( -- | @since 1.0.0
        PlutusType
      , -- | @since 1.0.0
        PIsData
      , -- | @since 1.0.0
        PEq
      , -- | @since 1.0.0
        PShow
      )
  
  -- | @since 1.0.0
  instance DerivePlutusType PProposalAction where
    type DPTStrat _ = PlutusTypeData
  
  -- | @since 1.0.0
  instance PUnsafeLiftDecl PProposalAction where
    type PLifted _ = ProposalAction
  
  -- | @since 1.0.0
  deriving via
    (DerivePConstantViaData ProposalAction PProposalAction)
    instance
      (PConstantDecl ProposalAction)
  
  -- | @since 1.0.0
  instance PTryFrom PData PProposalAction
  
  {- | Plutarch-level version of 'ProposalLock'.
  
       @since 1.0.0
  -}
  newtype PProposalLock (s :: S)
    = PProposalLock
        ( Term
            s
            ( PDataRecord
                '[ "proposalId" ':= PProposalId
                 , "action" ':= PProposalAction
                 ]
            )
        )
    deriving stock
      ( -- | @since 0.1.0
        Generic
      )
    deriving anyclass
      ( -- | @since 0.1.0
        PlutusType
      , -- | @since 0.1.0
        PIsData
      , -- | @since 0.1.0
        PEq
      , -- | @since 1.0.0
        PDataFields
      , -- | @since 0.2.0
        PShow
      )
  
  -- | @since 0.2.0
  instance DerivePlutusType PProposalLock where
    type DPTStrat _ = PlutusTypeNewtype
  
  -- | @since 0.2.0
  instance PTryFrom PData (PAsData PProposalLock)
  
  -- | @since 0.1.0
  instance PUnsafeLiftDecl PProposalLock where
    type PLifted PProposalLock = ProposalLock
  
  -- | @since 0.1.0
  deriving via
    (DerivePConstantViaDataList ProposalLock PProposalLock)
    instance
      (PConstantDecl ProposalLock)
  
  --------------------------------------------------------------------------------
  
  {- | Check whether a Stake is locked. If it is locked, various actions are unavailable.
  
       @since 0.2.0
  -}
  pstakeLocked :: forall (s :: S). Term s (PStakeDatum :--> PBool)
  pstakeLocked = phoistAcyclic $
    plam $ \stakeDatum ->
      pnot #$ pnull #$ pfield @"lockedBy" @(PBuiltinList _) # pto stakeDatum
  
  {- | Get the number of *alive* proposals that were created by the given stake.
  
       @since 0.2.0
  -}
  pnumCreatedProposals ::
    forall (s :: S).
    Term s (PBuiltinList (PAsData PProposalLock) :--> PInteger)
  pnumCreatedProposals =
    phoistAcyclic $
      plam $ \l ->
        pto $
          pfoldMap
            # plam
              ( \lock ->
                  let action = pfromData $ pfield @"action" # lock
                   in pmatch action $ \case
                        PCreated _ -> pcon $ PSum 1
                        _ -> mempty
              )
            # l
  
  {- | The role of a stake for a particular proposal. Scott-encoded.
  
       @since 1.0.0
  -}
  data PStakeRole (s :: S)
    = -- | The stake was used to vote on the proposal.
      PVoter
        (Term s PResultTag)
        -- ^ The option which was voted for.
    | -- | The stake was used to create the proposal.
      PCreator
    | -- | The stake was used to cosign the propsoal.
      PCosigner
    deriving stock
      ( -- | @since 1.0.0
        Generic
      )
    deriving anyclass
      ( -- | @since 1.0.0
        PlutusType
      )
  
  -- | @since 1.0.0
  instance DerivePlutusType PStakeRole where
    type DPTStrat _ = PlutusTypeScott
  
  -- | @since 1.0.0
  type PStakeRoles = PList PStakeRole
  
  --------------------------------------------------------------------------------
  
  {- | Who authorizes the transaction?
  
       @since 1.0.0
  -}
  data PSignedBy (s :: S)
    = -- | The stake owner authorized the transaction.
      PSignedByOwner
    | -- | The delegate authorized the transaction.
      PSignedByDelegate
    | -- | Both owner and delegate didn't authorize.
      PUnknownSig
    deriving stock
      ( -- | @since 1.0.0
        Generic
      )
    deriving anyclass
      ( -- | @since 1.0.0
        PlutusType
      )
  
  -- | @since 1.0.0
  instance DerivePlutusType PSignedBy where
    type DPTStrat _ = PlutusTypeScott
  
  {- | The signature context.
  
       @since 1.0.0
  -}
  data PSigContext (s :: S) = PSigContext
    { owner :: Term s PCredential
    , delegatee :: Term s (PMaybeData (PAsData PCredential))
    , signedBy :: Term s PSignedBy
    }
    deriving stock
      ( -- | @since 1.0.0
        Generic
      )
    deriving anyclass
      ( -- | @since 1.0.0
        PlutusType
      )
  
  -- | @since 1.0.0
  instance DerivePlutusType PSigContext where
    type DPTStrat _ = PlutusTypeScott
  
  {- | The metadata carried by the stake redeemer. See also 'StakeRedeemer'.
  
       @since 1.0.0
  -}
  data PStakeRedeemerContext (s :: S)
    = -- | See also 'DepositWithdraw'.
      PDepositWithdrawDelta (Term s (PTagged GTTag PInteger))
    | -- | See also 'DelegateTo'.
      PSetDelegateTo (Term s PCredential)
    | PNoMetadata
    deriving stock
      ( -- | @since 1.0.0
        Generic
      )
    deriving anyclass
      ( -- | @since 1.0.0
        PlutusType
      )
  
  -- | @since 1.0.0
  instance DerivePlutusType PStakeRedeemerContext where
    type DPTStrat _ = PlutusTypeScott
  
  {- | The usage of proposal in the transaction.
  
       @since 1.0.0
  -}
  data PProposalContext (s :: S)
    = -- | A proposal is spent.
      PSpendProposal
        (Term s PProposalDatum)
        (Term s PProposalRedeemer)
        (Term s PProposalTime)
    | -- | A new proposal is created.
      PNewProposal
        (Term s PProposalId)
    | -- | No proposal is spent or created.
      PNoProposal
    deriving stock
      ( -- | @since 1.0.0
        Generic
      )
    deriving anyclass
      ( -- | @since 1.0.0
        PlutusType
      )
  
  -- | @since 1.0.0
  instance DerivePlutusType PProposalContext where
    type DPTStrat _ = PlutusTypeScott
  
  {- | Context required in order for redeemer handlers to peform validation.
  
       @1.0.0
  -}
  data PStakeRedeemerHandlerContext (s :: S) = PStakeRedeemerHandlerContext
    { stakeInputDatums :: Term s (PList PStakeDatum)
    , stakeOutputDatums :: Term s (PList PStakeDatum)
    , redeemerContext :: Term s PStakeRedeemerContext
    , sigContext :: Term s PSigContext
    , proposalContext :: Term s PProposalContext
    , extraTxContext :: Term s PTxInfo
    }
    deriving stock
      ( -- | @since 1.0.0
        Generic
      )
    deriving anyclass
      ( -- | @since 1.0.0
        PlutusType
      )
  
  -- | @since 1.0.0
  instance DerivePlutusType PStakeRedeemerHandlerContext where
    type DPTStrat _ = PlutusTypeScott
  
  {- | The plutarch type signature of the redeemer handlers.
  
       A redeemer handler is a piece of validation logic that performs a unique
        set of checks for its corresponding stake redeemer.
  
       @since 1.0.0
  -}
  type PStakeRedeemerHandler = PStakeRedeemerHandlerContext :--> PUnit
  
  {- | A collection of stake redeemer handlers for each stake redeemers.
  
       @since 1.0.0
  -}
  data StakeRedeemerImpl (s :: S) = StakeRedeemerImpl
    { onDepositWithdraw :: Term s PStakeRedeemerHandler
    -- ^ Handler for 'DepositWithdraw'.
    , onDestroy :: Term s PStakeRedeemerHandler
    -- ^ Handler for 'Destroy'.
    , onPermitVote :: Term s PStakeRedeemerHandler
    -- ^ Handler for 'permitVotes'.
    , onRetractVote :: Term s PStakeRedeemerHandler
    -- ^ Handler for 'RetractVotes'.
    , onDelegateTo :: Term s PStakeRedeemerHandler
    -- ^ Handler for 'DelegateTo'.
    , onClearDelegate :: Term s PStakeRedeemerHandler
    -- ^ handler for 'ClearDelegate'.
    }
  
  --------------------------------------------------------------------------------
  
  {- | Return true if the stake was used to voted on the proposal.
  
       @since 1.0.0
  -}
  pisVoter :: forall (s :: S). Term s (PStakeRoles :--> PBool)
  pisVoter =
    phoistAcyclic $
      pany
        #$ plam
          ( \r -> pmatch r $ \case
              PVoter _ -> pconstant True
              _ -> pconstant False
          )
  
  {- | Return true if the stake was used to create the proposal.
  
       @since 1.0.0
  -}
  pisCreator :: forall (s :: S). Term s (PStakeRoles :--> PBool)
  pisCreator =
    phoistAcyclic $
      pany
        #$ plam
          ( \r -> pmatch r $ \case
              PCreator -> pconstant True
              _ -> pconstant False
          )
  
  {- | Return true if the stake was used to cosign the proposal.
  
       @since 1.0.0
  -}
  pisCosigner :: forall (s :: S). Term s (PStakeRoles :--> PBool)
  pisCosigner =
    phoistAcyclic $
      pany
        #$ plam
          ( \r -> pmatch r $ \case
              PCosigner -> pconstant True
              _ -> pconstant False
          )
  
  {- | Return true if the stake isn't related to the proposal.
  
       @since 1.0.0
  -}
  pisIrrelevant :: forall (s :: S). Term s (PStakeRoles :--> PBool)
  pisIrrelevant = pnull
  
  {- | Get the role of a stake for the proposal specified by the poroposal id,
        given the 'StakeDatum.lockedBy' field of the stake.
  
       @since 1.0.0
  -}
  pgetStakeRoles ::
    forall (s :: S).
    Term
      s
      ( PProposalId
          :--> PBuiltinList (PAsData PProposalLock)
          :--> PStakeRoles
      )
  pgetStakeRoles = phoistAcyclic $
    plam $ \pid ->
      let getStakeRole = flip (pletFields @'["proposalId", "action"]) $
            \lockF ->
              ppureIf
                # (pid #== lockF.proposalId)
                #$ pmatch lockF.action
                $ \case
                  PCreated _ -> pcon PCreator
                  PVoted ((pfield @"votedFor" #) -> tag) ->
                    pcon $ PVoter tag
                  PCosigned _ -> pcon PCosigner
       in pmapMaybe # plam (getStakeRole . pfromData)
  
  {- | Get the outcome that was voted for.
  
       @since 1.0.0
  -}
  pextractVoteOption :: forall (s :: S). Term s (PStakeRoles :--> PResultTag)
  pextractVoteOption =
    phoistAcyclic $
      plam $
        (passertPJust # "not voter" #)
          . ( pfindJust
                # plam
                  ( flip pmatch $ \case
                      PVoter r -> pjust # r
                      _ -> pnothing
                  )
                #
            )
  
  {- | Resolve stake datum, if the given `PTxInInfo` represents a stake input.
       Return nothing otherwise.
  
       The first parameter is the assetclass of SST.
  
       @since 1.0.0
  -}
  presolveStakeInputDatum ::
    forall (s :: S).
    Term
      s
      ( PTagged StakeSTTag PAssetClass
          :--> PMap 'Unsorted PDatumHash PDatum
          :--> PTxInInfo
          :--> PMaybe PStakeDatum
      )
  presolveStakeInputDatum = phoistAcyclic $
    plam $ \sstClass datums ->
      flip
        (pletFields @'["value", "datum", "address"])
        ( \txOutF ->
            let isStakeUTxO =
                  passetClassValueOfT
                    # sstClass
                    # txOutF.value
                    #== 1
  
                datum =
                  ptrace "Resolve stake datum" $
                    pfromData $
                      ptryFromOutputDatum @(PAsData PStakeDatum)
                        # txOutF.datum
                        # datums
             in pif
                  isStakeUTxO
                  (pjust # datum)
                  pnothing
        )
        . (pfield @"resolved" #)
  