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.hs b/agora-test/Spec.hs index d326e84..502cb27 100644 --- a/agora-test/Spec.hs +++ b/agora-test/Spec.hs @@ -11,6 +11,7 @@ import Test.Tasty (defaultMain, testGroup) import Spec.Model.MultiSig qualified as MultiSig import Spec.Stake qualified as Stake +-- | The Agora test suite main :: IO () main = defaultMain $ 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/Stake.hs b/agora-test/Spec/Stake.hs index f432e1b..8064ddf 100644 --- a/agora-test/Spec/Stake.hs +++ b/agora-test/Spec/Stake.hs @@ -1,3 +1,10 @@ +{- | +Module : Spec.Stake +Maintainer : emi@haskell.fyi +Description: Tests for Stake policy and validator + +Tests for Stake policy and validator +-} module Spec.Stake (tests) where -------------------------------------------------------------------------------- @@ -20,6 +27,7 @@ import Spec.Util (policyFailsWith, policySucceedsWith, toDatum, validatorFailsWi -------------------------------------------------------------------------------- +-- | Stake tests tests :: [TestTree] tests = [ testGroup diff --git a/agora-test/Spec/Util.hs b/agora-test/Spec/Util.hs index 240ff3a..4350e45 100644 --- a/agora-test/Spec/Util.hs +++ b/agora-test/Spec/Util.hs @@ -1,3 +1,10 @@ +{- | +Module : Spec.Util +Maintainer : emi@haskell.fyi +Description: Utility functions for testing Plutarch scripts with ScriptContext + +Utility functions for testing Plutarch scripts with ScriptContext +-} module Spec.Util ( -- * Testing utils scriptSucceeds, @@ -7,7 +14,7 @@ module Spec.Util ( validatorSucceedsWith, validatorFailsWith, - -- * Plutus land utils + -- * Plutus-land utils datumHash, toDatum, toDatumHash, @@ -21,7 +28,7 @@ import Prelude -------------------------------------------------------------------------------- import Codec.Serialise (serialise) -import Data.ByteString.Lazy qualified as LBS +import Data.ByteString.Lazy qualified as ByteString.Lazy -------------------------------------------------------------------------------- @@ -30,13 +37,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 +49,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 +67,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 +85,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 +107,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 +129,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 +140,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 +153,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,17 +163,22 @@ 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 $ PlutusTx.toBuiltin $ plift $ pblake2b_256 - # pconstant (LBS.toStrict $ serialise $ PlutusTx.toData datum) + # pconstant (ByteString.Lazy.toStrict $ serialise $ PlutusTx.toData datum) 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