PTryFrom tests for V3 types

plutarch-ledger-api/plutarch-ledger-api.cabal

@@ -87,5 +87,8 @@ test-suite tests
   import:         test-lang
   type:           exitcode-stdio-1.0
   main-is:        Main.hs
-  build-depends:  plutarch-orphanage
+  build-depends:
+    , plutarch-orphanage
+    , prettyprinter
+
   hs-source-dirs: test

plutarch-ledger-api/src/Plutarch/LedgerApi/Contexts.hs

@@ -43,7 +43,7 @@ import Plutarch.DataRepr (
   PDataFields,
  )
 import Plutarch.LedgerApi.AssocMap qualified as AssocMap
-import Plutarch.LedgerApi.Credential (PCredential, PStakingCredential)
+import Plutarch.LedgerApi.Credential (PCredential)
 import Plutarch.LedgerApi.Crypto (PPubKeyHash)
 import Plutarch.LedgerApi.Interval qualified as Interval
 import Plutarch.LedgerApi.Scripts (
@@ -253,7 +253,7 @@ instance PTryFrom PData (PAsData PDelegatee)
 
 -- | @since 3.1.0
 data PTxCert (s :: S)
-  = PTxCertRegStaking (Term s (PDataRecord '["_0" ':= PCredential, "_1" ':= PMaybeData Value.PCurrencySymbol]))
+  = PTxCertRegStaking (Term s (PDataRecord '["_0" ':= PCredential, "_1" ':= PMaybeData Value.PLovelace]))
   | PTxCertUnRegStaking (Term s (PDataRecord '["_0" ':= PCredential, "_1" ':= PMaybeData Value.PLovelace]))
   | PTxCertDelegStaking (Term s (PDataRecord '["_0" ':= PCredential, "_1" ':= PDelegatee]))
   | PTxCertRegDeleg (Term s (PDataRecord '["_0" ':= PCredential, "_1" ':= PDelegatee, "_2" ':= Value.PLovelace]))
@@ -826,10 +826,10 @@ newtype PTxInfo (s :: S)
               '[ "inputs" ':= PBuiltinList (PAsData PTxInInfo)
                , "referenceInputs" ':= PBuiltinList (PAsData PTxInInfo)
                , "outputs" ':= PBuiltinList (PAsData PTxOut)
-               , "fee" ':= Value.PValue 'AssocMap.Sorted 'Value.Positive
-               , "mint" ':= Value.PValue 'AssocMap.Sorted 'Value.NonZero -- value minted by transaction
+               , "fee" ':= Value.PLovelace
+               , "mint" ':= Value.PValue 'AssocMap.Sorted 'Value.NoGuarantees -- value minted by transaction
                , "txCerts" ':= PBuiltinList (PAsData PTxCert)
-               , "wdrl" ':= AssocMap.PMap 'AssocMap.Unsorted PStakingCredential PInteger -- Staking withdrawals
+               , "wdrl" ':= AssocMap.PMap 'AssocMap.Unsorted PCredential Value.PLovelace -- Staking withdrawals
                , "validRange" ':= Interval.PInterval PPosixTime
                , "signatories" ':= PBuiltinList (PAsData PPubKeyHash)
                , "redeemers" ':= AssocMap.PMap 'AssocMap.Unsorted PScriptPurpose PRedeemer

plutarch-ledger-api/test/Main.hs

@@ -10,15 +10,20 @@ import Plutarch.LedgerApi qualified as PlutarchLA
 import Plutarch.Lift (PUnsafeLiftDecl (PLifted))
 import Plutarch.Prelude (
   PAsData,
+  PData,
   PIsData,
+  PTryFrom,
   S,
   pconstant,
   pdata,
   pfromData,
   plift,
+  ptryFrom,
  )
 import PlutusLedgerApi.V3 qualified as PlutusLA
 import PlutusLedgerApi.V3.Orphans ()
+import Prettyprinter (Pretty (pretty), layoutCompact)
+import Prettyprinter.Render.String (renderString)
 import Test.QuickCheck (
   Arbitrary (arbitrary, shrink),
   forAllShrinkShow,
@@ -86,6 +91,29 @@ main = do
             , pIsDataLaws @PlutarchLA.PLovelace
             , pIsDataLaws @(PlutarchLA.PValue PlutarchLA.Unsorted PlutarchLA.NonZero)
             ]
+        , adjustOption slightlyFewerTests $
+            testGroup
+              "PTryFrom"
+              [ ptryFromLaws @PlutarchLA.PAddress
+              , ptryFromLaws @PlutarchLA.PCredential
+              , ptryFromLaws @PlutarchLA.PStakingCredential
+              , ptryFromLaws @PlutarchLA.PPubKeyHash
+              , ptryFromLaws @PlutarchLA.PPosixTime
+              , ptryFromLaws @(PlutarchLA.PExtended PlutarchLA.PPosixTime)
+              , ptryFromLaws @(PlutarchLA.PLowerBound PlutarchLA.PPosixTime)
+              , ptryFromLaws @(PlutarchLA.PUpperBound PlutarchLA.PPosixTime)
+              , ptryFromLaws @(PlutarchLA.PInterval PlutarchLA.PPosixTime)
+              , ptryFromLaws @PlutarchLA.PScriptHash
+              , ptryFromLaws @PlutarchLA.PDatum
+              , ptryFromLaws @PlutarchLA.PRedeemer
+              , ptryFromLaws @PlutarchLA.PDatumHash
+              , ptryFromLaws @PlutarchLA.PRedeemerHash
+              , ptryFromLaws @PlutarchLA.PCurrencySymbol
+              , ptryFromLaws @PlutarchLA.PTokenName
+              , ptryFromLaws @PlutarchLA.PLovelace
+              -- , ptryFromLaws @(PlutarchLA.PValue PlutarchLA.Unsorted PlutarchLA.NonZero)
+              -- Need PAsData handler because Plutarch is special
+              ]
         ]
     , testGroup
         "V3"
@@ -143,6 +171,34 @@ main = do
             , pIsDataLaws @PlutarchLA.PTxOut
             , pIsDataLaws @PlutarchLA.POutputDatum
             ]
+        , adjustOption slightlyFewerTests $
+            testGroup
+              "PTryFrom"
+              [ ptryFromLaws @PlutarchLA.PColdCommitteeCredential
+              , ptryFromLaws @PlutarchLA.PHotCommitteeCredential
+              , ptryFromLaws @PlutarchLA.PDRepCredential
+              , ptryFromLaws @PlutarchLA.PDRep
+              , ptryFromLaws @PlutarchLA.PDelegatee
+              , ptryFromLaws @PlutarchLA.PTxCert
+              , ptryFromLaws @PlutarchLA.PVoter
+              , ptryFromLaws @PlutarchLA.PVote
+              , ptryFromLaws @PlutarchLA.PGovernanceActionId
+              , ptryFromLaws @PlutarchLA.PCommittee
+              , ptryFromLaws @PlutarchLA.PConstitution
+              , ptryFromLaws @PlutarchLA.PProtocolVersion
+              , ptryFromLaws @PlutarchLA.PChangedParameters
+              , ptryFromLaws @PlutarchLA.PGovernanceAction
+              , ptryFromLaws @PlutarchLA.PProposalProcedure
+              , ptryFromLaws @PlutarchLA.PScriptPurpose
+              , ptryFromLaws @PlutarchLA.PScriptInfo
+              , ptryFromLaws @PlutarchLA.PTxInInfo
+              , adjustOption fewerTests $ ptryFromLaws @PlutarchLA.PTxInfo
+              , adjustOption fewerTests $ ptryFromLaws @PlutarchLA.PScriptContext
+              , ptryFromLaws @PlutarchLA.PTxId
+              , ptryFromLaws @PlutarchLA.PTxOutRef
+              , ptryFromLaws @PlutarchLA.PTxOut
+              , ptryFromLaws @PlutarchLA.POutputDatum
+              ]
         ]
     ]
   where
@@ -153,6 +209,9 @@ main = do
     -- TODO: Fix those.
     fewerTests :: QuickCheckTests -> QuickCheckTests
     fewerTests = const 500
+    -- PTryFrom tests run slow too
+    slightlyFewerTests :: QuickCheckTests -> QuickCheckTests
+    slightlyFewerTests = (`quot` 2)
 
 -- Properties
 
@@ -217,3 +276,30 @@ pIsDataLaws =
           plift (pfromData . punsafeCoerce @_ @_ @(PAsData a) . pconstant . PlutusLA.toData $ x) === x
     coerceName :: String
     coerceName = "plift . pfromData . punsafeCoerce @(PAsData " <> groupName <> ") . pconstant . toData = id"
+
+ptryFromLaws ::
+  forall (a :: S -> Type).
+  ( Arbitrary (PLifted a)
+  , Show (PLifted a)
+  , PUnsafeLiftDecl a
+  , Eq (PLifted a)
+  , Typeable a
+  , PTryFrom PData a
+  , PlutusLA.ToData (PLifted a)
+  , Pretty (PLifted a)
+  ) =>
+  TestTree
+ptryFromLaws = testGroup groupName [pDataAgreementProp]
+  where
+    groupName :: String
+    groupName = tyConName . typeRepTyCon $ typeRep @a
+    pDataAgreementProp :: TestTree
+    pDataAgreementProp = testProperty "can parse toData of original"
+      . forAllShrinkShow arbitrary shrink prettyShow
+      $ \(x :: PLifted a) ->
+        plift (ptryFrom @a (pconstant . PlutusLA.toData $ x) fst) === x
+
+-- Helpers
+
+prettyShow :: forall (a :: Type). Pretty a => a -> String
+prettyShow = renderString . layoutCompact . pretty

plutarch-orphanage/src/PlutusLedgerApi/V1/Orphans/Value.hs

@@ -1,6 +1,9 @@
 {-# OPTIONS_GHC -Wno-orphans #-}
 
 module PlutusLedgerApi.V1.Orphans.Value (
+  -- * Specialized Value wrappers
+  FeeValue (..),
+  getFeeValue,
   UTxOValue (..),
   getUtxoValue,
   NonAdaValue (..),
@@ -24,12 +27,15 @@ import Test.QuickCheck (
   Function (function),
   Gen,
   NonEmptyList (NonEmpty),
+  NonNegative (NonNegative),
   Positive (Positive),
   chooseBoundedIntegral,
   chooseInt,
   frequency,
   functionMap,
   getNonEmpty,
+  getNonNegative,
+  getPositive,
   resize,
   scale,
   sized,
@@ -75,7 +81,12 @@ instance Function PLA.CurrencySymbol where
   {-# INLINEABLE function #-}
   function = functionMap coerce PLA.CurrencySymbol
 
-{- | A Value with positive Ada, suitable for 'PLA.TxOut'.
+{- | A 'PLA.Value' suitable for 'PLA.TxOut'. Specifically:
+
+* The `PLA.Value` is sorted by both keys (meaning 'PLA.CurrencySymbol' and
+  'PLA.TokenName');
+* There exists an Ada amount; and
+* All amounts are positive.
 
 = Note
 
@@ -85,7 +96,7 @@ be /very/ certain that the Value being wrapped satisfies the invariants
 described above: failing to do so means all guarantees of this type are off
 the table.
 
-@since 1.0.0
+@since 1.0.1
 -}
 newtype UTxOValue = UTxOValue PLA.Value
   deriving
@@ -101,18 +112,46 @@ newtype UTxOValue = UTxOValue PLA.Value
 -- | @since 1.0.0
 instance Arbitrary UTxOValue where
   {-# INLINEABLE arbitrary #-}
-  -- Generate a NonAdaValue, then force a positive Ada value into it.
   arbitrary =
     UTxOValue <$> do
-      NonAdaValue v <- arbitrary
       Positive adaQuantity <- arbitrary
-      pure $ v <> Value.singleton "" "" adaQuantity
+      -- Set of non-Ada currency symbols
+      csSet <- Set.fromList <$> liftArbitrary (PLA.CurrencySymbol . getBlake2b244Hash <$> arbitrary)
+      let cses = Set.toList csSet
+      -- For each key, generate a set of token names that aren't Ada, and a
+      -- positive value
+      table <- traverse (scale (`quot` 8) . mkInner) cses
+      -- Jam the Ada value in there
+      let table' = (Value.adaSymbol, [(Value.adaToken, adaQuantity)]) : table
+      pure . Value.Value . AssocMap.unsafeFromList . fmap (fmap AssocMap.unsafeFromList) $ table'
+    where
+      mkInner :: PLA.CurrencySymbol -> Gen (PLA.CurrencySymbol, [(PLA.TokenName, Integer)])
+      mkInner cs =
+        (cs,) <$> do
+          -- Set of non-Ada token names
+          tnSet <- Set.fromList <$> liftArbitrary genNonAdaTokenName
+          let asList = Set.toList tnSet
+          traverse (\tn -> (tn,) . getPositive <$> arbitrary) asList
+      genNonAdaTokenName :: Gen PLA.TokenName
+      genNonAdaTokenName =
+        PLA.TokenName . PlutusTx.toBuiltin @ByteString . BS.pack <$> do
+          len <- chooseInt (1, 32)
+          -- ASCII printable range
+          vectorOf len . chooseBoundedIntegral $ (33, 126)
   {-# INLINEABLE shrink #-}
-  shrink (UTxOValue v) =
-    UTxOValue <$> do
-      v' <- shrink v
-      guard (Value.valueOf v' "" "" > 0)
-      pure v'
+  shrink (UTxOValue (Value.Value v)) =
+    UTxOValue . Value.Value <$> do
+      -- To ensure we don't break anything, we shrink in only two ways:
+      --
+      -- 1. Dropping keys (outer or inner)
+      -- 2. Shrinking amounts
+      --
+      -- To make this a bit easier on ourselves, we first 'unpack' the Value
+      -- completely, shrink the resulting (nested) list, then 'repack'. As neither
+      -- of these changes affect order or uniqueness, we're safe.
+      let asList = fmap AssocMap.toList <$> AssocMap.toList v
+      shrunk <- liftShrink (\(cs, inner) -> (cs,) <$> liftShrink (\(tn, amount) -> (tn,) . getPositive <$> shrink (Positive amount)) inner) asList
+      pure . AssocMap.unsafeFromList . fmap (fmap AssocMap.unsafeFromList) $ shrunk
 
 -- | @since 1.0.0
 deriving via PLA.Value instance CoArbitrary UTxOValue
@@ -258,3 +297,50 @@ instance Arbitrary1 NonEmptyList where
     NonEmpty <$> case ell of
       [] -> []
       (x : xs) -> (:) <$> shrinkInner x <*> liftShrink shrinkInner xs
+
+{- | A 'PLA.Value' containing only Ada, suitable for fees. Furthermore, the
+Ada quantity is non-negative.
+
+= Note
+
+This is designed to act as a modifier, and thus, we expose the constructor
+even though it preserves invariants. If you use the constructor directly,
+be /very/ certain that the Value being wrapped satisfies the invariants
+described above: failing to do so means all guarantees of this type are off
+the table.
+
+@since 1.0.0
+-}
+newtype FeeValue = FeeValue PLA.Value
+  deriving
+    ( -- | @since 1.0.0
+      Eq
+    )
+    via PLA.Value
+  deriving stock
+    ( -- | @since 1.0.0
+      Show
+    )
+
+-- | @since 1.0.0
+instance Arbitrary FeeValue where
+  {-# INLINEABLE arbitrary #-}
+  arbitrary = FeeValue . PLA.singleton PLA.adaSymbol PLA.adaToken . getNonNegative <$> arbitrary
+  {-# INLINEABLE shrink #-}
+  shrink (FeeValue v) =
+    FeeValue . PLA.singleton PLA.adaSymbol PLA.adaToken <$> do
+      let adaAmount = Value.valueOf v PLA.adaSymbol PLA.adaToken
+      NonNegative adaAmount' <- shrink (NonNegative adaAmount)
+      pure adaAmount'
+
+-- | @since 1.0.0
+deriving via PLA.Value instance CoArbitrary FeeValue
+
+-- | @since 1.0.0
+instance Function FeeValue where
+  {-# INLINEABLE function #-}
+  function = functionMap coerce FeeValue
+
+-- | @since 1.0.0
+getFeeValue :: FeeValue -> PLA.Value
+getFeeValue = coerce