Style guide

examples/AuctionExample.hs

@@ -11,7 +11,29 @@
 
 -}
 
-module AuctionExample (AuctionTest, AuctionDatum, auctionTest) where
+module AuctionExample (
+  AuctionTest (
+    AuctionTest,
+    stateRef,
+    otherInputsWithDatum,
+    auctionRedeemer
+  ),
+  AuctionTestRedeemer (
+    TestRedeemerBid,
+    testRedeemerBidder,
+    testRedeemerBidMagnitude,
+    selfOutputs,
+    bidderOutputs,
+    TestRedeemerClose
+  ),
+  SelfOutput (
+    SelfOutput,
+    selfDatum,
+    selfValue
+  ),
+  AuctionDatum,
+  auctionTest,
+) where
 
 import GHC.Generics qualified as GHC
 

examples/Spec.hs

@@ -1,26 +1,31 @@
 module Main where
 
+import Data.Map qualified as Map
+
 import Hedgehog qualified
 import Hedgehog.Main qualified as Hedgehog
 
 import PlutusLedgerApi.V2 qualified as Plutus
 
+import Hedgehog.Plutus.Gen
+import Hedgehog.Plutus.TestData
 import Hedgehog.Plutus.TxTest (
+  ChainState (ChainState, csMock, csMps, csScripts),
   txTestBad,
   txTestBadAdjunction,
   txTestGood,
   txTestGoodAdjunction,
  )
 
-import AuctionExample (auctionTest)
+import AuctionExample
 
 main :: IO ()
 main =
   Hedgehog.defaultMain
     [ Hedgehog.checkParallel $
         Hedgehog.Group
           "Auction example tests"
-          []
+          [("good data adjuncts for bid", goodBidAdjunction)]
     ]
 
 -- ("good data adjuncts for bid", goodBidAdjunction)
@@ -34,9 +39,33 @@ main =
 
 goodBidAdjunction :: Hedgehog.Property
 goodBidAdjunction = Hedgehog.property $ do
-  initialState <- _
+  initMock <- initMockState _ _ _
+  let initialState =
+        ChainState
+          { csMock = initMock
+          , csScripts = _
+          , csMps = Map.empty
+          }
   datum <- Hedgehog.forAll _
-  good <- Hedgehog.forAll _
+  good <- Hedgehog.forAll $ do
+    pure $
+      AuctionTest
+        { stateRef = G _
+        , otherInputsWithDatum = G ()
+        , auctionRedeemer =
+            G $
+              TestRedeemerBid
+                { testRedeemerBidder = G _
+                , testRedeemerBidMagnitude = G _
+                , selfOutputs =
+                    G $
+                      SelfOutput
+                        { selfDatum = G ()
+                        , selfValue = G ()
+                        }
+                , bidderOutputs = G ()
+                }
+        }
   txTestGoodAdjunction auctionTest initialState datum good
 
 goodCloseAdjunction :: Hedgehog.Property

src/Hedgehog/Plutus/Adjunction.hs

@@ -11,6 +11,7 @@ import Data.Kind (Type)
 import Hedgehog (annotateShow, (===))
 import Hedgehog qualified
 
+type Adjunction :: Type -> Type -> Type
 data Adjunction b a = Adjunction
   { lower :: !(a -> b)
   , raise :: !(b -> a)

src/Hedgehog/Plutus/Diff.hs

@@ -8,6 +8,7 @@ module Hedgehog.Plutus.Diff (
   patch,
 ) where
 
+import Data.Kind (Constraint, Type)
 import GHC.Generics qualified as GHC
 
 import Data.Coerce (coerce)
@@ -38,22 +39,24 @@ import PlutusLedgerApi.V1 (
  )
 import PlutusTx.Monoid (Group (inv))
 
+type Diff' :: Type -> Constraint
 class Diff' a where
   type Patch a
 
   diff' :: a -> a -> Patch a
 
   patch' :: Patch a -> a -> a
 
+type Diff :: Type -> Constraint
 class (Eq a, Diff' a) => Diff a
 instance (Eq a, Diff' a) => Diff a
 
-diff :: (Diff a) => a -> a -> Maybe (Patch a)
+diff :: forall (a :: Type). (Diff a) => a -> a -> Maybe (Patch a)
 diff a b
   | a == b = Nothing
   | otherwise = Just (diff' a b)
 
-patch :: (Diff' a) => Maybe (Patch a) -> a -> a
+patch :: forall (a :: Type). (Diff' a) => Maybe (Patch a) -> a -> a
 patch mp c = maybe c (`patch'` c) mp
 
 instance Diff' (Simple a) where
@@ -62,6 +65,7 @@ instance Diff' (Simple a) where
   diff' _ = coerce
   patch' b _ = Simple b
 
+type Patch' :: Type -> Type
 newtype Patch' a = Patch' (Maybe (Patch a))
 
 deriving stock instance (Eq (Patch a)) => Eq (Patch' a)
@@ -73,6 +77,7 @@ instance (All Diff as) => Diff' (NP I as) where
   diff' = hcliftA2 (Proxy @Diff) (\(I a) (I b) -> Patch' $ diff a b)
   patch' = hcliftA2 (Proxy @Diff) (\(Patch' p) (I c) -> I $ patch p c)
 
+type ConsPatch :: [Type] -> Type
 data ConsPatch xs = ConsPatch (NP I xs) (Maybe (Patch (NP I xs)))
 
 deriving stock instance
@@ -107,8 +112,10 @@ instance (All2 Diff xss) => Diff' (NS (NP I) xss) where
   patch' ((S ps)) (S cs) = S $ patch' ps cs
   patch' ps _ = hmap (\(ConsPatch bs _) -> bs) ps
 
+type Pair :: (k -> Type) -> k -> Type
 data Pair f a = Pair (f a) (f a)
 
+type SOPPatch :: Type -> Type
 newtype SOPPatch a = SOPPatch (NS ConsPatch (GCode a))
 
 deriving stock instance

src/Hedgehog/Plutus/Gen.hs

@@ -2,6 +2,8 @@
 
 module Hedgehog.Plutus.Gen where
 
+import Data.Kind (Type)
+
 import Control.Monad ((>=>))
 import Control.Monad.State (MonadState (get), StateT, evalStateT, modify)
 import Control.Monad.Trans (lift)
@@ -25,20 +27,22 @@ import Cardano.Simple.Ledger.Slot qualified as Simple
 import Plutus.Model qualified as Model
 import Plutus.Model.Stake qualified as Model
 
+type User :: Type
 data User = User
   { user :: !Model.User
   , userName :: !String
   , userOutputs :: ![Output]
   }
 
+type Output :: Type
 data Output = Output
   { outputRef :: !Plutus.TxOutRef
   , output :: !Plutus.TxOut
   , outputDatum :: !(Maybe Plutus.Datum)
   }
 
 initMockState ::
-  forall m.
+  forall (m :: Type -> Type).
   (Monad m) =>
   Map String (Plutus.PubKeyHash -> m [(Plutus.TxOut, Maybe Plutus.Datum)]) ->
   Map Plutus.ScriptHash (String, m [(Plutus.TxOut, Maybe Plutus.Datum)]) ->
@@ -127,6 +131,7 @@ initMockState users scripts cfg = (`evalStateT` 0) $ do
     scripts' :: StateT Integer m (Map Plutus.ScriptHash (String, [Output]))
     scripts' = traverse (traverse mkOutputs) scripts
 
+    initStake :: Model.Stake
     initStake =
       Model.Stake
         { stake'pools = Map.empty

src/Hedgehog/Plutus/Generics.hs

@@ -3,6 +3,10 @@ module Hedgehog.Plutus.Generics (
   Generically (Generically),
 ) where
 
+import Data.Kind (Type)
+
+type Simple :: Type -> Type
 newtype Simple a = Simple a
 
+type Generically :: Type -> Type
 newtype Generically a = Generically a

src/Hedgehog/Plutus/ScriptContext.hs

@@ -28,13 +28,15 @@ import Plutus.Model qualified as Model
 
 import Hedgehog.Plutus.TestSingleScript (txRunScript)
 
+type ScriptTx :: ScriptType -> Type
 data ScriptTx st = ScriptTx
   { scriptTx :: Model.Tx
   , scriptTxPurpose :: ScriptPurpose st
   }
 
 deriving stock instance Show (ScriptPurpose st) => Show (ScriptTx st)
 
+type ScriptType :: Type
 data ScriptType = Spend Type | Mint | Reward | Certify
 
 type DatumOf :: ScriptType -> Type
@@ -58,6 +60,7 @@ data ScriptContext redeemer st = ScriptContext
   , contextTxInfo :: !Plutus.TxInfo
   }
 
+type ChainState :: Type
 data ChainState = ChainState
   { csMock :: Model.Mock
   , csScripts :: Map Plutus.ScriptHash (Model.Versioned Model.Validator)
@@ -75,22 +78,28 @@ instance Pretty ChainState where
       , "steps   : " <> pretty (second show <$> Map.toList mps)
       ]
 
-scriptTxValid :: ScriptTx st -> Model.Mock -> Bool
+scriptTxValid :: forall (st :: ScriptType). ScriptTx st -> Model.Mock -> Bool
 scriptTxValid ScriptTx {scriptTx, scriptTxPurpose} m =
   isRight $
     txRunScript
       m
       scriptTx
       (plutusScriptPurpose scriptTxPurpose)
 
-plutusScriptContext :: ScriptContext d st -> Plutus.ScriptContext
+plutusScriptContext ::
+  forall (d :: Type) (st :: ScriptType).
+  ScriptContext d st ->
+  Plutus.ScriptContext
 plutusScriptContext
   ScriptContext
     { contextTxInfo = txInfo
     , contextPurpose = sp
     } = Plutus.ScriptContext txInfo (plutusScriptPurpose sp)
 
-plutusScriptPurpose :: ScriptPurpose st -> Plutus.ScriptPurpose
+plutusScriptPurpose ::
+  forall (st :: ScriptType).
+  ScriptPurpose st ->
+  Plutus.ScriptPurpose
 plutusScriptPurpose (Spending ref) = Plutus.Spending ref
 plutusScriptPurpose (Minting cs) = Plutus.Minting cs
 plutusScriptPurpose (Rewarding sc) = Plutus.Rewarding sc

src/Hedgehog/Plutus/TestData.hs

@@ -8,7 +8,7 @@
 module Hedgehog.Plutus.TestData (
   Bad,
   Good,
-  Good',
+  Good' (G),
   TestData (validate, generalise),
   test,
   testDataAdjunction,

src/Hedgehog/Plutus/TestSingleScript.hs

@@ -158,6 +158,7 @@ txRunScript
       outs = fmap ((mockUtxos Map.!) . Simple.txInRef) ins
 
 txRunScript' ::
+  forall (era :: Type).
   ( Alonzo.ExtendedUTxO era
   , Ledger.AlonzoEraTx era
   , Ledger.Script era ~ Alonzo.AlonzoScript era
@@ -199,10 +200,11 @@ txRunScript' pparams ei sysS utxo tx sp = do
       scr'
       =<< txGetData pparams ei sysS tx utxo lang sp rptr
   where
-    orError :: String -> Maybe b -> Either a b
+    orError :: forall (a :: Type) (b :: Type). String -> Maybe b -> Either a b
     orError msg = maybe (error msg) Right
 
 txGetData ::
+  forall (era :: Type).
   ( Alonzo.ExtendedUTxO era
   , Ledger.AlonzoEraTx era
   , Ledger.Script era ~ Alonzo.AlonzoScript era
@@ -217,14 +219,16 @@ txGetData ::
   Ledger.RdmrPtr ->
   Maybe [Ledger.Data era]
 txGetData pparams ei sysS tx utxo lang sp rptr = do
-  let ws = tx ^. Ledger.witsTxL
-      rdmr = fst $ Ledger.unRedeemers (ws ^. Ledger.rdmrsWitsL) Map.! rptr
-      dats = Ledger.unTxDats $ ws ^. Ledger.datsWitsL
+  let
+    ws = tx ^. Ledger.witsTxL
+    rdmr = fst $ Ledger.unRedeemers (ws ^. Ledger.rdmrsWitsL) Map.! rptr
+    dats = Ledger.unTxDats $ ws ^. Ledger.datsWitsL
   info <-
     either (const Nothing) Just $ Alonzo.txInfo pparams lang ei sysS utxo tx
   pure $ getData dats utxo info sp rdmr
 
 getData ::
+  forall (era :: Type).
   (Alonzo.ExtendedUTxO era) =>
   Map (Ledger.DataHash (Ledger.Crypto era)) (Ledger.Data era) ->
   Ledger.UTxO era ->
@@ -243,6 +247,6 @@ getData dats utxo inf sp rdmr = datum <> [rdmr, Alonzo.valContext inf sp]
           Ledger.NoDatum -> Nothing
       _ -> Nothing
 
-unsafeFromEither :: (Show a) => Either a b -> b
+unsafeFromEither :: forall (a :: Type) (b :: Type). (Show a) => Either a b -> b
 unsafeFromEither (Left a) = error $ "unsafeFromEither: " <> show a
 unsafeFromEither (Right b) = b