From 6702bfcd94497f2541a5938b71cf737900bf6c96 Mon Sep 17 00:00:00 2001 From: Emily Martins Date: Thu, 24 Mar 2022 15:43:21 +0100 Subject: [PATCH] apply suggestions and fix remaining haddock suggestions --- Makefile | 5 ++++- agora-test/Spec/Model/MultiSig.hs | 10 +++++++++- agora-test/Spec/Sample/Stake.hs | 15 ++++++++++++--- agora-test/Spec/Util.hs | 19 ++++++++++++++----- agora/Agora/MultiSig.hs | 1 + agora/Agora/SafeMoney.hs | 14 +++++--------- agora/Agora/SafeMoney/QQ.hs | 2 +- agora/Agora/Stake.hs | 14 +++++++------- agora/Agora/Utils.hs | 14 +++++++------- agora/PPrelude.hs | 10 ++++++++++ 10 files changed, 70 insertions(+), 34 deletions(-) diff --git a/Makefile b/Makefile index e155973..a2a17e7 100644 --- a/Makefile +++ b/Makefile @@ -23,7 +23,10 @@ format: git ls-tree -r HEAD --full-tree --name-only | grep -E '.*\.cabal' | xargs cabal-fmt -i format_check: - find -name '*.hs' -not -path './dist-*/*' | xargs fourmolu $(FORMAT_EXTENSIONS) -m check + find -name '*.hs' \ + -not -path './dist*/*' \ + -not -path './haddock/*' \ + | xargs fourmolu $(FORMAT_EXTENSIONS) -m check haddock: cabal haddock --haddock-html --haddock-hoogle --builddir=haddock diff --git a/agora-test/Spec/Model/MultiSig.hs b/agora-test/Spec/Model/MultiSig.hs index 67fea2d..15dcfae 100644 --- a/agora-test/Spec/Model/MultiSig.hs +++ b/agora-test/Spec/Model/MultiSig.hs @@ -1,3 +1,10 @@ +{- | +Module : Spec.Model.MultiSig +Maintainer : emi@haskell.fyi +Description: apropos-tx model and tests for 'MultiSig' functions + +apropos-tx model and tests for 'MultiSig' functions +-} module Spec.Model.MultiSig ( plutarchTests, genTests, @@ -7,7 +14,6 @@ import Data.List (intersect) -------------------------------------------------------------------------------- -import Plutarch (compile) import Plutus.V1.Ledger.Api ( Script, ScriptContext (scriptContextPurpose), @@ -165,6 +171,7 @@ instance HasScriptRunner MultiSigProp MultiSigModel where (pcon PUnit) perror +-- | Consistency tests for the 'HasParameterisedGenerator' instance of 'MultiSigModel' genTests :: TestTree genTests = testGroup "genTests" $ @@ -175,6 +182,7 @@ genTests = Yes ] +-- | Tests for the 'HasScriptRunner' instance of 'MultiSigModel' plutarchTests :: TestTree plutarchTests = testGroup "plutarchTests" $ diff --git a/agora-test/Spec/Sample/Stake.hs b/agora-test/Spec/Sample/Stake.hs index a2fa049..4bb0073 100644 --- a/agora-test/Spec/Sample/Stake.hs +++ b/agora-test/Spec/Sample/Stake.hs @@ -58,25 +58,30 @@ import Spec.Util (datumPair, toDatumHash) -------------------------------------------------------------------------------- +-- | 'Stake' parameters for 'LQ'. stake :: Stake LQ stake = Stake +-- | 'Stake' policy instance. policy :: MintingPolicy policy = mkMintingPolicy (stakePolicy stake) policySymbol :: CurrencySymbol policySymbol = mintingPolicySymbol policy +-- | A sample 'PubKeyHash'. signer :: PubKeyHash signer = "8a30896c4fd5e79843e4ca1bd2cdbaa36f8c0bc3be7401214142019c" +-- | 'Stake' validator instance. validator :: Validator validator = mkValidator (stakeValidator stake) +-- | 'TokenName' that represents the hash of the 'Stake' validator. validatorHashTN :: TokenName validatorHashTN = let ValidatorHash vh = validatorHash validator in TokenName vh --- | This script context should be a valid transaction +-- | This script context should be a valid transaction. stakeCreation :: ScriptContext stakeCreation = let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST @@ -105,7 +110,7 @@ stakeCreation = , scriptContextPurpose = Minting policySymbol } --- | This ScriptContext should fail because the datum has too much GT +-- | This ScriptContext should fail because the datum has too much GT. stakeCreationWrongDatum :: ScriptContext stakeCreationWrongDatum = let datum :: Datum @@ -115,7 +120,7 @@ stakeCreationWrongDatum = , scriptContextPurpose = Minting policySymbol } --- | This ScriptContext should fail because the datum has too much GT +-- | This ScriptContext should fail because the datum has too much GT. stakeCreationUnsigned :: ScriptContext stakeCreationUnsigned = ScriptContext @@ -128,11 +133,15 @@ stakeCreationUnsigned = -------------------------------------------------------------------------------- +-- | Config for creating a ScriptContext that deposits or withdraws. data DepositWithdrawExample = DepositWithdrawExample { startAmount :: Integer + -- ^ The amount of GT stored before the transaction. , delta :: Integer + -- ^ The amount of GT deposited or withdrawn from the Stake. } +-- | Create a ScriptContext that deposits or withdraws, given the config for it. stakeDepositWithdraw :: DepositWithdrawExample -> ScriptContext stakeDepositWithdraw config = let st = Value.singleton policySymbol validatorHashTN 1 -- Stake ST diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs index 240ff3a..33f23be 100644 --- a/agora-test/Spec/Util.hs +++ b/agora-test/Spec/Util.hs @@ -7,7 +7,7 @@ module Spec.Util ( validatorSucceedsWith, validatorFailsWith, - -- * Plutus land utils + -- * Plutus-land utils datumHash, toDatum, toDatumHash, @@ -30,13 +30,11 @@ import Test.Tasty.HUnit (assertFailure, testCase) -------------------------------------------------------------------------------- -import Plutarch import Plutarch.Api.V1 (PMintingPolicy, PValidator) import Plutarch.Builtin (pforgetData) import Plutarch.Crypto (pblake2b_256) import Plutarch.Evaluate (evalScript) import Plutarch.Lift (PUnsafeLiftDecl (PLifted)) -import Plutarch.Prelude () import Plutus.V1.Ledger.Contexts (ScriptContext) import Plutus.V1.Ledger.Scripts (Datum (Datum), DatumHash (DatumHash), Script) import PlutusTx.Builtins qualified as PlutusTx @@ -44,6 +42,7 @@ import PlutusTx.IsData qualified as PlutusTx -------------------------------------------------------------------------------- +-- | Check that a policy script succeeds, given a name and arguments. policySucceedsWith :: ( PLift redeemer , PlutusTx.ToData (PLifted redeemer) @@ -61,6 +60,7 @@ policySucceedsWith tag policy redeemer scriptContext = # pconstant scriptContext ) +-- | Check that a policy script fails, given a name and arguments. policyFailsWith :: ( PLift redeemer , PlutusTx.ToData (PLifted redeemer) @@ -78,6 +78,7 @@ policyFailsWith tag policy redeemer scriptContext = # pconstant scriptContext ) +-- | Check that a validator script succeeds, given a name and arguments. validatorSucceedsWith :: ( PLift datum , PlutusTx.ToData (PLifted datum) @@ -99,6 +100,7 @@ validatorSucceedsWith tag policy datum redeemer scriptContext = # pconstant scriptContext ) +-- | Check that a validator script fails, given a name and arguments. validatorFailsWith :: ( PLift datum , PlutusTx.ToData (PLifted datum) @@ -120,6 +122,7 @@ validatorFailsWith tag policy datum redeemer scriptContext = # pconstant scriptContext ) +-- | Check that an arbitrary script doesn't error when evaluated, given a name. scriptSucceeds :: String -> Script -> TestTree scriptSucceeds name script = testCase name $ do let (res, _budget, traces) = evalScript script @@ -130,6 +133,7 @@ scriptSucceeds name script = testCase name $ do Right _v -> pure () +-- | Check that an arbitrary script **does** error when evaluated, given a name. scriptFails :: String -> Script -> TestTree scriptFails name script = testCase name $ do let (res, _budget, traces) = evalScript script @@ -142,7 +146,7 @@ scriptFails name script = testCase name $ do -------------------------------------------------------------------------------- -{- | Create a pair from data for use in 'txInfoData' +{- | Create a pair from data for use in 'txInfoData'. Example: @ @@ -152,13 +156,18 @@ scriptFails name script = testCase name $ do datumPair :: PlutusTx.ToData a => a -> (DatumHash, Datum) datumPair = (,) <$> toDatumHash <*> toDatum +-- | Calculate the blake2b-256 hash of a Datum. datumHash :: Datum -> DatumHash datumHash (Datum data') = toDatumHash data' +-- | Convenience function to create a Datum from any type that implements ToData. toDatum :: PlutusTx.ToData a => a -> Datum toDatum = Datum . PlutusTx.toBuiltinData --- Shamelessly go through plutus. +{- | Calculate the blake2b-256 hash of any type that implements ToData + + Shamelessly go through plutus. +-} toDatumHash :: PlutusTx.ToData a => a -> DatumHash toDatumHash datum = DatumHash $ diff --git a/agora/Agora/MultiSig.hs b/agora/Agora/MultiSig.hs index 1e8a548..6e8270d 100644 --- a/agora/Agora/MultiSig.hs +++ b/agora/Agora/MultiSig.hs @@ -10,6 +10,7 @@ A basic N of M multisignature validation function. module Agora.MultiSig ( validatedByMultisig, pvalidatedByMultisig, + PMultiSig (..), MultiSig (..), ) where diff --git a/agora/Agora/SafeMoney.hs b/agora/Agora/SafeMoney.hs index 6730bc7..bec07c5 100644 --- a/agora/Agora/SafeMoney.hs +++ b/agora/Agora/SafeMoney.hs @@ -9,7 +9,6 @@ module Agora.SafeMoney ( -- * Types MoneyClass, PDiscrete, - Discrete, -- * Utility functions paddDiscrete, @@ -44,11 +43,11 @@ import Plutarch.Monadic qualified as P -------------------------------------------------------------------------------- -import Agora.Utils +import Agora.Utils (passetClassValueOf, psingletonValue) -------------------------------------------------------------------------------- --- | Type-level unique identifier for an `AssetClass` +-- | Type-level unique identifier for an 'Plutus.V1.Ledger.Value.AssetClass' type MoneyClass = ( -- AssetClass Symbol @@ -63,10 +62,6 @@ newtype PDiscrete (mc :: MoneyClass) (s :: S) = PDiscrete (Term s PInteger) deriving (PlutusType, PIsData, PEq, POrd) via (DerivePNewtype (PDiscrete mc) PInteger) -newtype Discrete (mc :: MoneyClass) - = Discrete Integer - deriving stock (Show) - -- | Check if one 'PDiscrete' is greater than another. pgeqDiscrete :: forall (mc :: MoneyClass) (s :: S). Term s (PDiscrete mc :--> PDiscrete mc :--> PBool) pgeqDiscrete = phoistAcyclic $ @@ -75,7 +70,7 @@ pgeqDiscrete = phoistAcyclic $ PDiscrete y' <- pmatch y y' #<= x' --- | Conjure zero discrete unit for any moneyclass +-- | Returns a zero-value 'PDiscrete' unit for any 'MoneyClass'. pzeroDiscrete :: forall (mc :: MoneyClass) (s :: S). Term s (PDiscrete mc) pzeroDiscrete = phoistAcyclic $ pcon (PDiscrete 0) @@ -114,7 +109,8 @@ pvalueDiscrete = phoistAcyclic $ # f {- | Get a `PValue` from a `PDiscrete`. - __NOTE__: `pdiscreteValue` after `pvalueDiscrete` loses information + __NOTE__: `pdiscreteValue` after `pvalueDiscrete` is not a round-trip. + It filters for a particular 'MoneyClass'. -} pdiscreteValue :: forall (moneyClass :: MoneyClass) (ac :: Symbol) (n :: Symbol) (scale :: Nat) s. diff --git a/agora/Agora/SafeMoney/QQ.hs b/agora/Agora/SafeMoney/QQ.hs index 96ec4c7..3fdf161 100644 --- a/agora/Agora/SafeMoney/QQ.hs +++ b/agora/Agora/SafeMoney/QQ.hs @@ -40,7 +40,7 @@ import Agora.SafeMoney (MoneyClass, PDiscrete) {- | Generate 'PDiscrete' values tagged by a particular MoneyClass @ - [discrete| 123.456 ADA |] :: 'Term' s ('PDiscrete' 'ADA') + [discrete| 123.456 'Agora.SafeMoney.ADA' |] :: 'Term' s ('PDiscrete' 'Agora.SafeMoney.ADA') @ -} discrete :: QuasiQuoter diff --git a/agora/Agora/Stake.hs b/agora/Agora/Stake.hs index 39f1eb1..3929449 100644 --- a/agora/Agora/Stake.hs +++ b/agora/Agora/Stake.hs @@ -72,8 +72,8 @@ import Agora.Utils ( paddValue, passert, pfindTxInByTxOutRef, - pgeqBy, - pgeqBy', + pgeqByClass, + pgeqByClass', pgeqBySymbol, psingletonValue, psymbolValueOf, @@ -233,8 +233,8 @@ stakePolicy _stake = let valueCorrect = foldr1 (#&&) - [ pgeqBy' (AssetClass ("", "")) # value # expectedValue - , pgeqBy' + [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue + , pgeqByClass' ( AssetClass ( fromString . symbolVal $ Proxy @ac , fromString . symbolVal $ Proxy @n @@ -242,7 +242,7 @@ stakePolicy _stake = ) # value # expectedValue - , pgeqBy + , pgeqByClass # ownSymbol # tn # value @@ -333,8 +333,8 @@ stakeValidator stake = let valueCorrect = foldr1 (#&&) - [ pgeqBy' (AssetClass ("", "")) # value # expectedValue - , pgeqBy' + [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue + , pgeqByClass' ( AssetClass ( fromString . symbolVal $ Proxy @ac , fromString . symbolVal $ Proxy @n diff --git a/agora/Agora/Utils.hs b/agora/Agora/Utils.hs index 8f70a2f..4b599c8 100644 --- a/agora/Agora/Utils.hs +++ b/agora/Agora/Utils.hs @@ -19,9 +19,9 @@ module Agora.Utils ( psymbolValueOf, passetClassValueOf, passetClassValueOf', - pgeqBy, + pgeqByClass, pgeqBySymbol, - pgeqBy', + pgeqByClass', pfindTxInByTxOutRef, psingletonValue, pfindMap, @@ -184,13 +184,13 @@ passetClassValueOf' (AssetClass (sym, token)) = passetClassValueOf # pconstant sym # pconstant token -- | Return '>=' on two values comparing by only a particular AssetClass -pgeqBy :: Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PValue :--> PBool) -pgeqBy = +pgeqByClass :: Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PValue :--> PBool) +pgeqByClass = phoistAcyclic $ plam $ \cs tn a b -> passetClassValueOf # cs # tn # b #<= passetClassValueOf # cs # tn # a --- | Return '>=' on two values comparing by only a particular AssetClass +-- | Return '>=' on two values comparing by only a particular CurrencySymbol pgeqBySymbol :: Term s (PCurrencySymbol :--> PValue :--> PValue :--> PBool) pgeqBySymbol = phoistAcyclic $ @@ -198,8 +198,8 @@ pgeqBySymbol = psymbolValueOf # cs # b #<= psymbolValueOf # cs # a -- | Return '>=' on two values comparing by only a particular Haskell-level AssetClass -pgeqBy' :: AssetClass -> Term s (PValue :--> PValue :--> PBool) -pgeqBy' ac = +pgeqByClass' :: AssetClass -> Term s (PValue :--> PValue :--> PBool) +pgeqByClass' ac = phoistAcyclic $ plam $ \a b -> passetClassValueOf' ac # b #<= passetClassValueOf' ac # a diff --git a/agora/PPrelude.hs b/agora/PPrelude.hs index 3a8025b..8fba4be 100644 --- a/agora/PPrelude.hs +++ b/agora/PPrelude.hs @@ -1,7 +1,17 @@ +{- | +Module : PPrelude +Maintainer : emi@haskell.fyi +Description: Prelude imported throughout this project + +Prelude imported throughout this project +-} module PPrelude ( module Prelude, module Plutarch.Prelude, + module Plutarch, ) where +-- These are not exported by Plutarch.Prelude, for some reason. Maybe we can 'fix' this upstream? +import Plutarch (ClosedTerm, compile) import Plutarch.Prelude import Prelude