{-# LANGUAGE TemplateHaskell #-}

{- |
Module: Agora.Treasury
Maintainer: jack@mlabs.city
Description: Treasury scripts.

Contains the datum, redeemer and validator for a template DAO
treasury.
-}
module Agora.Treasury (module Agora.Treasury) where

import Agora.AuthorityToken (singleAuthorityTokenBurned)
import GHC.Generics qualified as GHC
import Generics.SOP (Generic, I (I))
import Plutarch.Api.V1 (PValidator)
import Plutarch.Api.V1.Contexts (PScriptPurpose (PMinting))
import "plutarch" Plutarch.Api.V1.Value (PValue)
import Plutarch.DataRepr (
  DerivePConstantViaData (..),
  PIsDataReprInstances (PIsDataReprInstances),
 )
import Plutarch.Extra.TermCont (pguardC, pletC, pmatchC, ptryFromC)
import Plutarch.Lift (PConstantDecl (..), PLifted (..), PUnsafeLiftDecl)
import Plutarch.TryFrom ()
import PlutusLedgerApi.V1.Value (CurrencySymbol)
import PlutusTx qualified

{- | Redeemer for Treasury actions.

     @since 0.1.0
-}
data TreasuryRedeemer
  = -- | Allow transaction to pass by delegating to GAT burn.
    SpendTreasuryGAT
  deriving stock
    ( -- | @since 0.1.0
      TreasuryRedeemer -> TreasuryRedeemer -> Bool
(TreasuryRedeemer -> TreasuryRedeemer -> Bool)
-> (TreasuryRedeemer -> TreasuryRedeemer -> Bool)
-> Eq TreasuryRedeemer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TreasuryRedeemer -> TreasuryRedeemer -> Bool
$c/= :: TreasuryRedeemer -> TreasuryRedeemer -> Bool
== :: TreasuryRedeemer -> TreasuryRedeemer -> Bool
$c== :: TreasuryRedeemer -> TreasuryRedeemer -> Bool
Eq
    , -- | @since 0.1.0
      Int -> TreasuryRedeemer -> ShowS
[TreasuryRedeemer] -> ShowS
TreasuryRedeemer -> String
(Int -> TreasuryRedeemer -> ShowS)
-> (TreasuryRedeemer -> String)
-> ([TreasuryRedeemer] -> ShowS)
-> Show TreasuryRedeemer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [TreasuryRedeemer] -> ShowS
$cshowList :: [TreasuryRedeemer] -> ShowS
show :: TreasuryRedeemer -> String
$cshow :: TreasuryRedeemer -> String
showsPrec :: Int -> TreasuryRedeemer -> ShowS
$cshowsPrec :: Int -> TreasuryRedeemer -> ShowS
Show
    , -- | @since 0.1.0
      (forall x. TreasuryRedeemer -> Rep TreasuryRedeemer x)
-> (forall x. Rep TreasuryRedeemer x -> TreasuryRedeemer)
-> Generic TreasuryRedeemer
forall x. Rep TreasuryRedeemer x -> TreasuryRedeemer
forall x. TreasuryRedeemer -> Rep TreasuryRedeemer x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TreasuryRedeemer x -> TreasuryRedeemer
$cfrom :: forall x. TreasuryRedeemer -> Rep TreasuryRedeemer x
GHC.Generic
    )

-- | @since 0.1.0
PlutusTx.makeIsDataIndexed
  ''TreasuryRedeemer
  [ ('SpendTreasuryGAT, 0)
  ]

--------------------------------------------------------------------------------

{- | Plutarch level type representing valid redeemers of the
     treasury.

     @since 0.1.0
-}
newtype PTreasuryRedeemer (s :: S)
  = -- | Alters treasury parameters, subject to the burning of a
    --   governance authority token.
    PSpendTreasuryGAT (Term s (PDataRecord '[]))
  deriving stock
    ( -- | @since 0.1.0
      (forall x. PTreasuryRedeemer s -> Rep (PTreasuryRedeemer s) x)
-> (forall x. Rep (PTreasuryRedeemer s) x -> PTreasuryRedeemer s)
-> Generic (PTreasuryRedeemer s)
forall x. Rep (PTreasuryRedeemer s) x -> PTreasuryRedeemer s
forall x. PTreasuryRedeemer s -> Rep (PTreasuryRedeemer s) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (s :: S) x.
Rep (PTreasuryRedeemer s) x -> PTreasuryRedeemer s
forall (s :: S) x.
PTreasuryRedeemer s -> Rep (PTreasuryRedeemer s) x
$cto :: forall (s :: S) x.
Rep (PTreasuryRedeemer s) x -> PTreasuryRedeemer s
$cfrom :: forall (s :: S) x.
PTreasuryRedeemer s -> Rep (PTreasuryRedeemer s) x
GHC.Generic
    )
  deriving anyclass
    ( -- | @since 0.1.0
      All @[Type] (SListI @Type) (Code (PTreasuryRedeemer s))
All @[Type] (SListI @Type) (Code (PTreasuryRedeemer s))
-> (PTreasuryRedeemer s -> Rep (PTreasuryRedeemer s))
-> (Rep (PTreasuryRedeemer s) -> PTreasuryRedeemer s)
-> Generic (PTreasuryRedeemer s)
Rep (PTreasuryRedeemer s) -> PTreasuryRedeemer s
PTreasuryRedeemer s -> Rep (PTreasuryRedeemer s)
forall a.
All @[Type] (SListI @Type) (Code a)
-> (a -> Rep a) -> (Rep a -> a) -> Generic a
forall {s :: S}.
All @[Type] (SListI @Type) (Code (PTreasuryRedeemer s))
forall (s :: S). Rep (PTreasuryRedeemer s) -> PTreasuryRedeemer s
forall (s :: S). PTreasuryRedeemer s -> Rep (PTreasuryRedeemer s)
to :: Rep (PTreasuryRedeemer s) -> PTreasuryRedeemer s
$cto :: forall (s :: S). Rep (PTreasuryRedeemer s) -> PTreasuryRedeemer s
from :: PTreasuryRedeemer s -> Rep (PTreasuryRedeemer s)
$cfrom :: forall (s :: S). PTreasuryRedeemer s -> Rep (PTreasuryRedeemer s)
Generic
    , -- | @since 0.1.0
      PIsData PTreasuryRedeemer
PlutusType PTreasuryRedeemer
PlutusType PTreasuryRedeemer
-> PIsData PTreasuryRedeemer
-> (forall (s :: S).
    PTreasuryRedeemer s
    -> Term s (PDataSum (PIsDataReprRepr PTreasuryRedeemer)))
-> (forall (s :: S) (b :: PType).
    Term s (PDataSum (PIsDataReprRepr PTreasuryRedeemer))
    -> (PTreasuryRedeemer s -> Term s b) -> Term s b)
-> PIsDataRepr PTreasuryRedeemer
forall (s :: S).
PTreasuryRedeemer s
-> Term s (PDataSum (PIsDataReprRepr PTreasuryRedeemer))
forall (s :: S) (b :: PType).
Term s (PDataSum (PIsDataReprRepr PTreasuryRedeemer))
-> (PTreasuryRedeemer s -> Term s b) -> Term s b
forall (a :: PType).
PlutusType a
-> PIsData a
-> (forall (s :: S). a s -> Term s (PDataSum (PIsDataReprRepr a)))
-> (forall (s :: S) (b :: PType).
    Term s (PDataSum (PIsDataReprRepr a))
    -> (a s -> Term s b) -> Term s b)
-> PIsDataRepr a
pmatchRepr :: forall (s :: S) (b :: PType).
Term s (PDataSum (PIsDataReprRepr PTreasuryRedeemer))
-> (PTreasuryRedeemer s -> Term s b) -> Term s b
$cpmatchRepr :: forall (s :: S) (b :: PType).
Term s (PDataSum (PIsDataReprRepr PTreasuryRedeemer))
-> (PTreasuryRedeemer s -> Term s b) -> Term s b
pconRepr :: forall (s :: S).
PTreasuryRedeemer s
-> Term s (PDataSum (PIsDataReprRepr PTreasuryRedeemer))
$cpconRepr :: forall (s :: S).
PTreasuryRedeemer s
-> Term s (PDataSum (PIsDataReprRepr PTreasuryRedeemer))
PIsDataRepr
    )
  deriving
    ( -- | @since 0.1.0
      PCon PTreasuryRedeemer
PMatch PTreasuryRedeemer
PCon PTreasuryRedeemer
-> PMatch PTreasuryRedeemer
-> (forall (s :: S) (b :: PType).
    PTreasuryRedeemer s -> Term s (PInner PTreasuryRedeemer b))
-> (forall (s :: S) (b :: PType).
    Term s (PInner PTreasuryRedeemer b)
    -> (PTreasuryRedeemer s -> Term s b) -> Term s b)
-> PlutusType PTreasuryRedeemer
forall (s :: S) (b :: PType).
Term s (PInner PTreasuryRedeemer b)
-> (PTreasuryRedeemer s -> Term s b) -> Term s b
forall (s :: S) (b :: PType).
PTreasuryRedeemer s -> Term s (PInner PTreasuryRedeemer b)
forall (a :: PType).
PCon a
-> PMatch a
-> (forall (s :: S) (b :: PType). a s -> Term s (PInner a b))
-> (forall (s :: S) (b :: PType).
    Term s (PInner a b) -> (a s -> Term s b) -> Term s b)
-> PlutusType a
pmatch' :: forall (s :: S) (b :: PType).
Term s (PInner PTreasuryRedeemer b)
-> (PTreasuryRedeemer s -> Term s b) -> Term s b
$cpmatch' :: forall (s :: S) (b :: PType).
Term s (PInner PTreasuryRedeemer b)
-> (PTreasuryRedeemer s -> Term s b) -> Term s b
pcon' :: forall (s :: S) (b :: PType).
PTreasuryRedeemer s -> Term s (PInner PTreasuryRedeemer b)
$cpcon' :: forall (s :: S) (b :: PType).
PTreasuryRedeemer s -> Term s (PInner PTreasuryRedeemer b)
PlutusType
    , -- | @since 0.1.0
      (forall (s :: S).
 Term s (PAsData PTreasuryRedeemer) -> Term s PTreasuryRedeemer)
-> (forall (s :: S). Term s PTreasuryRedeemer -> Term s PData)
-> PIsData PTreasuryRedeemer
forall (s :: S).
Term s (PAsData PTreasuryRedeemer) -> Term s PTreasuryRedeemer
forall (s :: S). Term s PTreasuryRedeemer -> Term s PData
forall (a :: PType).
(forall (s :: S). Term s (PAsData a) -> Term s a)
-> (forall (s :: S). Term s a -> Term s PData) -> PIsData a
pdataImpl :: forall (s :: S). Term s PTreasuryRedeemer -> Term s PData
$cpdataImpl :: forall (s :: S). Term s PTreasuryRedeemer -> Term s PData
pfromDataImpl :: forall (s :: S).
Term s (PAsData PTreasuryRedeemer) -> Term s PTreasuryRedeemer
$cpfromDataImpl :: forall (s :: S).
Term s (PAsData PTreasuryRedeemer) -> Term s PTreasuryRedeemer
PIsData
    )
    via PIsDataReprInstances PTreasuryRedeemer

-- | @since 0.1.0
deriving via
  PAsData (PIsDataReprInstances PTreasuryRedeemer)
  instance
    PTryFrom PData (PAsData PTreasuryRedeemer)

-- | @since 0.1.0
instance PUnsafeLiftDecl PTreasuryRedeemer where
  type PLifted PTreasuryRedeemer = TreasuryRedeemer

-- | @since 0.1.0
deriving via
  (DerivePConstantViaData TreasuryRedeemer PTreasuryRedeemer)
  instance
    (PConstantDecl TreasuryRedeemer)

--------------------------------------------------------------------------------

{- | Validator ensuring that transactions consuming the treasury
     do so in a valid manner.

     @since 0.1.0
-}
treasuryValidator ::
  -- | Governance Authority Token that can unlock this validator.
  CurrencySymbol ->
  ClosedTerm PValidator
treasuryValidator :: CurrencySymbol -> ClosedTerm PValidator
treasuryValidator CurrencySymbol
gatCs' = (Term s PData
 -> Term s PData -> Term s PScriptContext -> Term s POpaque)
-> Term s PValidator
forall a (b :: PType) (s :: S) (c :: PType).
PLamN a b s =>
(Term s c -> a) -> Term s (c :--> b)
plam ((Term s PData
  -> Term s PData -> Term s PScriptContext -> Term s POpaque)
 -> Term s PValidator)
-> (Term s PData
    -> Term s PData -> Term s PScriptContext -> Term s POpaque)
-> Term s PValidator
forall a b. (a -> b) -> a -> b
$ \Term s PData
_datum Term s PData
redeemer Term s PScriptContext
ctx' -> TermCont @POpaque s (Term s POpaque) -> Term s POpaque
forall (a :: PType) (s :: S). TermCont @a s (Term s a) -> Term s a
unTermCont (TermCont @POpaque s (Term s POpaque) -> Term s POpaque)
-> TermCont @POpaque s (Term s POpaque) -> Term s POpaque
forall a b. (a -> b) -> a -> b
$ do
  (Term s (PAsData PTreasuryRedeemer)
treasuryRedeemer, Reduce @Type (PTryFromExcess PData (PAsData PTreasuryRedeemer) s)
_) <- Term s PData
-> TermCont
     @POpaque
     s
     (Term s (PAsData PTreasuryRedeemer),
      Reduce @Type (PTryFromExcess PData (PAsData PTreasuryRedeemer) s))
forall (b :: PType) (r :: PType) (a :: PType) (s :: S).
PTryFrom a b =>
Term s a
-> TermCont @r s (Term s b, Reduce @Type (PTryFromExcess a b s))
ptryFromC Term s PData
redeemer

  -- plet required fields from script context.
  HRec
  (BoundTerms
     (PFields PScriptContext)
     (Bindings
        (PFields PScriptContext)
        ((':) @Symbol "txInfo" ((':) @Symbol "purpose" ('[] @Symbol))))
     s)
ctx <- ((HRec
    (BoundTerms
       (PFields PScriptContext)
       (Bindings
          (PFields PScriptContext)
          ((':) @Symbol "txInfo" ((':) @Symbol "purpose" ('[] @Symbol))))
       s)
  -> Term s POpaque)
 -> Term s POpaque)
-> TermCont
     @POpaque
     s
     (HRec
        (BoundTerms
           (PFields PScriptContext)
           (Bindings
              (PFields PScriptContext)
              ((':) @Symbol "txInfo" ((':) @Symbol "purpose" ('[] @Symbol))))
           s))
forall a (s :: S) (r :: PType).
((a -> Term s r) -> Term s r) -> TermCont @r s a
tcont (((HRec
     (BoundTerms
        (PFields PScriptContext)
        (Bindings
           (PFields PScriptContext)
           ((':) @Symbol "txInfo" ((':) @Symbol "purpose" ('[] @Symbol))))
        s)
   -> Term s POpaque)
  -> Term s POpaque)
 -> TermCont
      @POpaque
      s
      (HRec
         (BoundTerms
            (PFields PScriptContext)
            (Bindings
               (PFields PScriptContext)
               ((':) @Symbol "txInfo" ((':) @Symbol "purpose" ('[] @Symbol))))
            s)))
-> ((HRec
       (BoundTerms
          (PFields PScriptContext)
          (Bindings
             (PFields PScriptContext)
             ((':) @Symbol "txInfo" ((':) @Symbol "purpose" ('[] @Symbol))))
          s)
     -> Term s POpaque)
    -> Term s POpaque)
-> TermCont
     @POpaque
     s
     (HRec
        (BoundTerms
           (PFields PScriptContext)
           (Bindings
              (PFields PScriptContext)
              ((':) @Symbol "txInfo" ((':) @Symbol "purpose" ('[] @Symbol))))
           s))
forall a b. (a -> b) -> a -> b
$ forall (fs :: [Symbol]) (a :: PType) (s :: S) (b :: PType)
       (ps :: [PLabeledType]) (bs :: [ToBind]).
(PDataFields a,
 (ps :: [PLabeledType]) ~ (PFields a :: [PLabeledType]),
 (bs :: [ToBind]) ~ (Bindings ps fs :: [ToBind]),
 BindFields ps bs) =>
Term s a -> (HRecOf a fs s -> Term s b) -> Term s b
pletFields @["txInfo", "purpose"] Term s PScriptContext
ctx'

  -- Ensure that script is for burning i.e. minting a negative amount.
  PMinting Term
  s
  (PDataRecord
     ((':)
        @PLabeledType ("_0" ':= PCurrencySymbol) ('[] @PLabeledType)))
_ <- Term s PScriptPurpose -> TermCont @POpaque s (PScriptPurpose s)
forall {r :: PType} (a :: PType) (s :: S).
PMatch a =>
Term s a -> TermCont @r s (a s)
pmatchC HRec
  (BoundTerms
     (PFields PScriptContext)
     (Bindings
        (PFields PScriptContext)
        ((':) @Symbol "txInfo" ((':) @Symbol "purpose" ('[] @Symbol))))
     s)
ctx.purpose

  -- Ensure redeemer type is valid.
  PSpendTreasuryGAT Term s (PDataRecord ('[] @PLabeledType))
_ <- Term s PTreasuryRedeemer
-> TermCont @POpaque s (PTreasuryRedeemer s)
forall {r :: PType} (a :: PType) (s :: S).
PMatch a =>
Term s a -> TermCont @r s (a s)
pmatchC (Term s PTreasuryRedeemer
 -> TermCont @POpaque s (PTreasuryRedeemer s))
-> Term s PTreasuryRedeemer
-> TermCont @POpaque s (PTreasuryRedeemer s)
forall a b. (a -> b) -> a -> b
$ Term s (PAsData PTreasuryRedeemer) -> Term s PTreasuryRedeemer
forall (a :: PType) (s :: S).
PIsData a =>
Term s (PAsData a) -> Term s a
pfromData Term s (PAsData PTreasuryRedeemer)
treasuryRedeemer

  -- Get the minted value from txInfo.
  Term s (PAsData PTxInfo)
txInfo' <- Term s (PAsData PTxInfo)
-> TermCont @POpaque s (Term s (PAsData PTxInfo))
forall {r :: PType} (s :: S) (a :: PType).
Term s a -> TermCont @r s (Term s a)
pletC HRec
  (BoundTerms
     (PFields PScriptContext)
     (Bindings
        (PFields PScriptContext)
        ((':) @Symbol "txInfo" ((':) @Symbol "purpose" ('[] @Symbol))))
     s)
ctx.txInfo
  HRec
  ((':)
     @(Symbol, Type)
     '("mint", Term s (PAsData (PValue 'Sorted 'NoGuarantees)))
     ('[] @(Symbol, Type)))
txInfo <- ((HRec
    ((':)
       @(Symbol, Type)
       '("mint", Term s (PAsData (PValue 'Sorted 'NoGuarantees)))
       ('[] @(Symbol, Type)))
  -> Term s POpaque)
 -> Term s POpaque)
-> TermCont
     @POpaque
     s
     (HRec
        ((':)
           @(Symbol, Type)
           '("mint", Term s (PAsData (PValue 'Sorted 'NoGuarantees)))
           ('[] @(Symbol, Type))))
forall a (s :: S) (r :: PType).
((a -> Term s r) -> Term s r) -> TermCont @r s a
tcont (((HRec
     ((':)
        @(Symbol, Type)
        '("mint", Term s (PAsData (PValue 'Sorted 'NoGuarantees)))
        ('[] @(Symbol, Type)))
   -> Term s POpaque)
  -> Term s POpaque)
 -> TermCont
      @POpaque
      s
      (HRec
         ((':)
            @(Symbol, Type)
            '("mint", Term s (PAsData (PValue 'Sorted 'NoGuarantees)))
            ('[] @(Symbol, Type)))))
-> ((HRec
       ((':)
          @(Symbol, Type)
          '("mint", Term s (PAsData (PValue 'Sorted 'NoGuarantees)))
          ('[] @(Symbol, Type)))
     -> Term s POpaque)
    -> Term s POpaque)
-> TermCont
     @POpaque
     s
     (HRec
        ((':)
           @(Symbol, Type)
           '("mint", Term s (PAsData (PValue 'Sorted 'NoGuarantees)))
           ('[] @(Symbol, Type))))
forall a b. (a -> b) -> a -> b
$ forall (fs :: [Symbol]) (a :: PType) (s :: S) (b :: PType)
       (ps :: [PLabeledType]) (bs :: [ToBind]).
(PDataFields a,
 (ps :: [PLabeledType]) ~ (PFields a :: [PLabeledType]),
 (bs :: [ToBind]) ~ (Bindings ps fs :: [ToBind]),
 BindFields ps bs) =>
Term s a -> (HRecOf a fs s -> Term s b) -> Term s b
pletFields @'["mint"] Term s (PAsData PTxInfo)
txInfo'
  let mint :: Term _ (PValue _ _)
      mint :: Term s (PValue 'Sorted 'NoGuarantees)
mint = HRec
  ((':)
     @(Symbol, Type)
     '("mint", Term s (PAsData (PValue 'Sorted 'NoGuarantees)))
     ('[] @(Symbol, Type)))
txInfo.mint

  Term s PCurrencySymbol
gatCs <- Term s PCurrencySymbol
-> TermCont @POpaque s (Term s PCurrencySymbol)
forall {r :: PType} (s :: S) (a :: PType).
Term s a -> TermCont @r s (Term s a)
pletC (Term s PCurrencySymbol
 -> TermCont @POpaque s (Term s PCurrencySymbol))
-> Term s PCurrencySymbol
-> TermCont @POpaque s (Term s PCurrencySymbol)
forall a b. (a -> b) -> a -> b
$ PLifted PCurrencySymbol -> Term s PCurrencySymbol
forall (p :: PType) (s :: S). PLift p => PLifted p -> Term s p
pconstant PLifted PCurrencySymbol
CurrencySymbol
gatCs'

  Term s (PString @S) -> Term s PBool -> TermCont @POpaque s ()
forall {r :: PType} (s :: S).
Term s (PString @S) -> Term s PBool -> TermCont @r s ()
pguardC Term s (PString @S)
"A single authority token has been burned" (Term s PBool -> TermCont @POpaque s ())
-> Term s PBool -> TermCont @POpaque s ()
forall a b. (a -> b) -> a -> b
$
    Term s PCurrencySymbol
-> Term s (PAsData PTxInfo)
-> Term s (PValue 'Sorted 'NoGuarantees)
-> Term s PBool
forall (keys :: KeyGuarantees) (amounts :: AmountGuarantees)
       (s :: S).
Term s PCurrencySymbol
-> Term s (PAsData PTxInfo)
-> Term s (PValue keys amounts)
-> Term s PBool
singleAuthorityTokenBurned Term s PCurrencySymbol
gatCs Term s (PAsData PTxInfo)
txInfo' Term s (PValue 'Sorted 'NoGuarantees)
mint

  Term s POpaque -> TermCont @POpaque s (Term s POpaque)
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Term s POpaque -> TermCont @POpaque s (Term s POpaque))
-> (Term s (PUnit @S) -> Term s POpaque)
-> Term s (PUnit @S)
-> TermCont @POpaque s (Term s POpaque)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term s (PUnit @S) -> Term s POpaque
forall (s :: S) (a :: PType). Term s a -> Term s POpaque
popaque (Term s (PUnit @S) -> TermCont @POpaque s (Term s POpaque))
-> Term s (PUnit @S) -> TermCont @POpaque s (Term s POpaque)
forall a b. (a -> b) -> a -> b
$ PLifted (PUnit @S) -> Term s (PUnit @S)
forall (p :: PType) (s :: S). PLift p => PLifted p -> Term s p
pconstant ()