Merge branch 'master' of github.com:Liqwid-Labs/agora into jhodgdev/treasury-tests

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

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 $

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" $

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

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

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)

agora/Agora/MultiSig.hs

@@ -10,6 +10,7 @@ A basic N of M multisignature validation function.
 module Agora.MultiSig (
   validatedByMultisig,
   pvalidatedByMultisig,
+  PMultiSig (..),
   MultiSig (..),
 ) where
 

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.

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

agora/Agora/Stake.hs

@@ -72,8 +72,8 @@ import Agora.Utils (
   paddValue,
   passert,
   pfindTxInByTxOutRef,
-  pgeqBy,
+  pgeqByClass,
-  pgeqBy',
+  pgeqByClass',
   pgeqBySymbol,
   psingletonValue,
   psymbolValueOf,
@@ -233,8 +233,8 @@ stakePolicy _stake =
                     let valueCorrect =
                           foldr1
                             (#&&)
-                            [ pgeqBy' (AssetClass ("", "")) # value # expectedValue
+                            [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
-                            , pgeqBy'
+                            , 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
+                      [ pgeqByClass' (AssetClass ("", "")) # value # expectedValue
-                      , pgeqBy'
+                      , pgeqByClass'
                           ( AssetClass
                               ( fromString . symbolVal $ Proxy @ac
                               , fromString . symbolVal $ Proxy @n

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)
+pgeqByClass :: Term s (PCurrencySymbol :--> PTokenName :--> PValue :--> PValue :--> PBool)
-pgeqBy =
+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)
+pgeqByClass' :: AssetClass -> Term s (PValue :--> PValue :--> PBool)
-pgeqBy' ac =
+pgeqByClass' ac =
   phoistAcyclic $
     plam $ \a b ->
       passetClassValueOf' ac # b #<= passetClassValueOf' ac # a

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