Merge branch 'master' into emiflake/stake

src/Agora/AuthorityToken.hs

@@ -5,18 +5,20 @@ module Agora.AuthorityToken (
   AuthorityToken (..),
 ) where
 
---------------------------------------------------------------------------------
+import Plutarch.Api.V1 (
+  PScriptContext (..),
+  PScriptPurpose (..),
+  PTxInInfo (..),
+  PTxInfo (..),
+  PTxOut (..),
+ )
+import Plutarch.List (pfoldr')
+import Plutarch.Monadic qualified as P
+import Plutus.V1.Ledger.Value (AssetClass)
 
 import Prelude
 
 --------------------------------------------------------------------------------
-import Plutus.V1.Ledger.Value (AssetClass (..))
-
---------------------------------------------------------------------------------
-
-import Plutarch.Api.V1
-import Plutarch.List (pfoldr')
-import Plutarch.Prelude
 
 import Agora.SafeMoney
 
@@ -29,8 +31,8 @@ import Agora.SafeMoney
      _this_ token's existence in order to prevent incorrect minting.
 -}
 newtype AuthorityToken = AuthorityToken
-  { -- | Token that must move in order for minting this to be valid.
-    authority :: AssetClass
+  { authority :: AssetClass
+  -- ^ Token that must move in order for minting this to be valid.
   }
 
 --------------------------------------------------------------------------------
@@ -40,49 +42,35 @@ authorityTokenPolicy ::
   Term s (PData :--> PScriptContext :--> PUnit)
 authorityTokenPolicy params =
   plam $ \_redeemer ctx' ->
-    pmatch ctx' $ \(PScriptContext ctx) ->
-      let txInfo' = pfromData $ pfield @"txInfo" # ctx
-          purpose' = pfromData $ pfield @"purpose" # ctx
-
-          inputs =
-            pmatch txInfo' $ \(PTxInfo txInfo) ->
-              pfromData $ pfield @"inputs" # txInfo
-
-          authorityTokenInputs =
+    pmatch ctx' $ \(PScriptContext ctx') -> P.do
+      ctx <- pletFields @'["txInfo", "purpose"] ctx'
+      PTxInfo txInfo' <- pmatch $ pfromData ctx.txInfo
+      txInfo <- pletFields @'["inputs", "mint"] txInfo'
+      let inputs = txInfo.inputs :: Term _ (PBuiltinList (PAsData PTxInInfo))
+      let authorityTokenInputs =
             pfoldr'
-              ( \txInInfo' acc ->
-                  pmatch (pfromData txInInfo') $ \(PTxInInfo txInInfo) ->
-                    let txOut' =
-                          pfromData $ pfield @"resolved" # txInInfo
-                        txOutValue =
-                          pmatch txOut' $
-                            \(PTxOut txOut) ->
-                              pfromData $ pfield @"value" # txOut
-                     in passetClassValueOf' params.authority # txOutValue + acc
+              ( \txInInfo' acc -> P.do
+                  PTxInInfo txInInfo <- pmatch (pfromData txInInfo')
+                  PTxOut txOut' <- pmatch $ pfromData $ pfield @"resolved" # txInInfo
+                  txOut <- pletFields @'["value"] txOut'
+                  let txOutValue = pfromData txOut.value
+                  passetClassValueOf' params.authority # txOutValue + acc
               )
-              # (0 :: Term s PInteger)
+              # 0
               # inputs
-
-          -- We incur the cost twice here. This will be fixed upstream in Plutarch.
-          mintedValue =
-            pmatch txInfo' $ \(PTxInfo txInfo) ->
-              pfromData $ pfield @"mint" # txInfo
-
-          tokenMoved = 0 #< authorityTokenInputs
-       in pmatch purpose' $ \case
-            PMinting sym' ->
-              let sym = pfromData $ pfield @"_0" # sym'
-                  mintedATs = passetClassValueOf # sym # pconstant "" # mintedValue
-               in pif
-                    (0 #< mintedATs)
-                    ( pif
-                        tokenMoved
-                        -- The authority token moved, we are good to go for minting.
-                        (pconstant ())
-                        (ptraceError "Authority token did not move in minting GATs")
-                    )
-                    -- We minted 0 or less Authority Tokens, we are good to go.
-                    -- Burning is always allowed.
-                    (pconstant ())
-            _ ->
-              ptraceError "Wrong script type"
+      let mintedValue = pfromData txInfo.mint
+      let tokenMoved = 0 #< authorityTokenInputs
+      PMinting sym' <- pmatch $ pfromData ctx.purpose
+      let sym = pfromData $ pfield @"_0" # sym'
+      let mintedATs = passetClassValueOf # sym # pconstant "" # mintedValue
+      pif
+        (0 #< mintedATs)
+        ( pif
+            tokenMoved
+            -- The authority token moved, we are good to go for minting.
+            (pconstant ())
+            (ptraceError "Authority token did not move in minting GATs")
+        )
+        -- We minted 0 or less Authority Tokens, we are good to go.
+        -- Burning is always allowed.
+        (pconstant ())

src/Agora/SafeMoney.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE UndecidableInstances #-}
 {-# OPTIONS_GHC -Wwarn=missing-methods #-}
 {-# OPTIONS_GHC -Wwarn=unused-imports #-}
 

src/Agora/SafeMoney/QQ.hs

@@ -4,10 +4,8 @@
 
 module Agora.SafeMoney.QQ (discrete) where
 
-import Control.Arrow ((&&&))
-import Data.Ratio (denominator, numerator)
-import Debug.Trace
 import GHC.Real (Ratio ((:%)))
+import Language.Haskell.TH qualified as TH (Type)
 import Language.Haskell.TH.Quote (QuasiQuoter (QuasiQuoter))
 import Language.Haskell.TH.Syntax (
   Dec (TySynD),
@@ -20,18 +18,15 @@ import Language.Haskell.TH.Syntax (
   Type (AppT, ConT, LitT, PromotedTupleT),
   lookupTypeName,
   reify,
-  reifyType,
  )
-import PlutusTx.Ratio (unsafeRatio)
 import Text.ParserCombinators.ReadP (readP_to_S, skipSpaces)
-import Text.Read (lexP, readMaybe, readPrec_to_P)
+import Text.Read (lexP, readPrec_to_P)
 import Text.Read.Lex (Lexeme (Ident, Number), Number, numberToFixed, numberToRational)
 import Prelude
 
 --------------------------------------------------------------------------------
 
 import Plutarch.Internal (punsafeCoerce)
-import Plutarch.Prelude hiding (Type)
 
 import Agora.SafeMoney
 
@@ -81,7 +76,7 @@ parseDiscreteRatioExp s =
 errorDiscretePat :: String -> Q Pat
 errorDiscretePat _ = fail "Cannot use 'discrete' in a pattern context."
 
-errorDiscreteType :: String -> Q Type
+errorDiscreteType :: String -> Q TH.Type
 errorDiscreteType _ = fail "Cannot use 'discrete' in a type context."
 
 errorDiscreteDiscretelaration :: String -> Q [Dec]

src/Agora/Stake.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE UndecidableInstances #-}
 
 -- | Vote-lockable stake UTXOs holding GT
 module Agora.Stake (
@@ -22,7 +23,6 @@ import Plutarch.DataRepr (
   PIsDataReprInstances (PIsDataReprInstances),
  )
 import Plutarch.Internal
-import Plutarch.Prelude
 
 --------------------------------------------------------------------------------
 
@@ -46,14 +46,14 @@ data StakeAction (gt :: MoneyClass) (s :: S)
 
 newtype StakeDatum (gt :: MoneyClass) (s :: S) = StakeDatum
   { getStakeDatum ::
-      ( Term
-          s
-          ( PDataRecord
-              '[ "stakedAmount" ':= Discrete gt
-               , "owner" ':= PPubKeyHash
-               ]
-          )
-      )
+    ( Term
+        s
+        ( PDataRecord
+            '[ "stakedAmount" ':= Discrete gt
+             , "owner" ':= PPubKeyHash
+             ]
+        )
+    )
   }
   deriving stock (GHC.Generic)
   deriving anyclass (Generic)
@@ -65,10 +65,10 @@ newtype StakeDatum (gt :: MoneyClass) (s :: S) = StakeDatum
 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)
+-- pfindDatum :: Term s (PDatumHash :--> PTxInfo :--> PMaybe PDatum)
+-- pfindDatum = phoistAcyclic $
+--   plam $ \_datumHash _txInfo -> unTermCont $ do
+--     pure (pcon PNothing)
 
 stakePolicy ::
   forall (gt :: MoneyClass) s.

src/PPrelude.hs

@@ -0,0 +1,7 @@
+module PPrelude (
+  module Prelude,
+  module Plutarch.Prelude,
+) where
+
+import Plutarch.Prelude
+import Prelude