diff --git a/plutus-benchmark/cardano-loans/test/9.6/main.golden.pir b/plutus-benchmark/cardano-loans/test/9.6/main.golden.pir index f4f7b94c4b8..ed5a0572ffa 100644 --- a/plutus-benchmark/cardano-loans/test/9.6/main.golden.pir +++ b/plutus-benchmark/cardano-loans/test/9.6/main.golden.pir @@ -100,19 +100,20 @@ {StakingCredential} stakingCred {all dead. bool} - (\(a : StakingCredential) -> + (\(l1l : StakingCredential) -> /\dead -> Maybe_match {StakingCredential} stakingCred' {bool} - (\(a : StakingCredential) -> + (\(r1r : + StakingCredential) -> StakingCredential_match - a + l1l {bool} (\(l : Credential) -> StakingCredential_match - a + r1r {bool} (\(r : Credential) -> @@ -128,7 +129,7 @@ (b : integer) (c : integer) -> StakingCredential_match - a + r1r {bool} (\(ipv : Credential) -> @@ -248,21 +249,21 @@ {StakingCredential} stakingCred {all dead. bool} - (\(a : StakingCredential) -> + (\(l1l : StakingCredential) -> /\dead -> Maybe_match {StakingCredential} stakingCred' {bool} - (\(a : + (\(r1r : StakingCredential) -> StakingCredential_match - a + l1l {bool} (\(l : Credential) -> StakingCredential_match - a + r1r {bool} (\(r : Credential) -> @@ -280,7 +281,7 @@ (b : integer) (c : integer) -> StakingCredential_match - a + r1r {bool} (\(ipv : Credential) -> diff --git a/plutus-benchmark/cardano-loans/test/9.6/main.golden.uplc b/plutus-benchmark/cardano-loans/test/9.6/main.golden.uplc index fc5f763afc4..811f7b3f1a7 100644 --- a/plutus-benchmark/cardano-loans/test/9.6/main.golden.uplc +++ b/plutus-benchmark/cardano-loans/test/9.6/main.golden.uplc @@ -6288,15 +6288,15 @@ [ False , (case stakingCred - [ (\a -> + [ (\l1l -> case stakingCred' - [ (\a -> + [ (\r1r -> case - a + l1l [ (\l -> case - a + r1r [ (\r -> `$fEqCredential_$c==` l @@ -6309,7 +6309,7 @@ b c -> case - a + r1r [ (\ipv -> False) , (\a' @@ -6373,15 +6373,15 @@ [ False , (case stakingCred - [ (\a -> + [ (\l1l -> case stakingCred' - [ (\a -> + [ (\r1r -> case - a + l1l [ (\l -> case - a + r1r [ (\r -> `$fEqCredential_$c==` l @@ -6394,7 +6394,7 @@ b c -> case - a + r1r [ (\ipv -> False) , (\a' diff --git a/plutus-benchmark/linear-vesting/test/9.6/main.golden.pir b/plutus-benchmark/linear-vesting/test/9.6/main.golden.pir index d92ab58cfb2..e818daec995 100644 --- a/plutus-benchmark/linear-vesting/test/9.6/main.golden.pir +++ b/plutus-benchmark/linear-vesting/test/9.6/main.golden.pir @@ -1376,7 +1376,8 @@ {data} l))) {all dead. bool} - (\(a : data) -> + (\(l1l : + data) -> /\dead -> Maybe_match {data} @@ -1389,7 +1390,7 @@ {data} l))) {bool} - (\(a : + (\(r1r : data) -> let !fail : @@ -1399,7 +1400,7 @@ unit) -> `$mStakingPtr` {bool} - a + l1l (\(a : integer) (b : @@ -1408,7 +1409,7 @@ integer) -> `$mStakingPtr` {bool} - a + r1r (\(a' : integer) (b' : @@ -1452,7 +1453,7 @@ (list data) = unConstrData - a + l1l in case (all dead. @@ -1479,7 +1480,7 @@ (list data) = unConstrData - a + r1r in case (all dead. diff --git a/plutus-benchmark/linear-vesting/test/9.6/main.golden.uplc b/plutus-benchmark/linear-vesting/test/9.6/main.golden.uplc index 47d8a4625d5..db1481edf44 100644 --- a/plutus-benchmark/linear-vesting/test/9.6/main.golden.uplc +++ b/plutus-benchmark/linear-vesting/test/9.6/main.golden.uplc @@ -593,7 +593,7 @@ (force tailList l))) - [ (\a -> + [ (\l1l -> case (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` `$fUnsafeFromDataBuiltinData_$cunsafeFromBuiltinData` @@ -602,7 +602,7 @@ (force tailList l))) - [ (\a -> + [ (\r1r -> (\tup -> force ((\fail -> @@ -645,15 +645,15 @@ r -> r) ]))) ]) (unConstrData - a))) ]) + r1r))) ]) (\ds -> `$mStakingPtr` - a + l1l (\a b c -> `$mStakingPtr` - a + r1r (\a' b' c' -> @@ -675,7 +675,7 @@ (\void -> False)))) (unConstrData - a)) + l1l)) , False ]) , (case (`$fUnsafeFromDataMaybe_$cunsafeFromBuiltinData` diff --git a/plutus-benchmark/nofib/test/9.6/clausify-F5.golden.pir b/plutus-benchmark/nofib/test/9.6/clausify-F5.golden.pir index 76650342603..4857aeb26e8 100644 --- a/plutus-benchmark/nofib/test/9.6/clausify-F5.golden.pir +++ b/plutus-benchmark/nofib/test/9.6/clausify-F5.golden.pir @@ -285,19 +285,19 @@ {bool} True (\(ipv : a) (ipv : List a) -> False)) - (\(x : a) (xs : List a) -> + (\(l1l : a) (l2l : List a) -> /\dead -> List_match {a} eta {bool} False - (\(y : a) (ys : List a) -> + (\(r1r : a) (r2r : List a) -> case (all dead. bool) - (`$dEq` x y) + (`$dEq` l1l r1r) [ (/\dead -> False) - , (/\dead -> `$fEqList_$c==` {a} `$dEq` xs ys) ] + , (/\dead -> `$fEqList_$c==` {a} `$dEq` l2l r2r) ] {all dead. dead})) {all dead. dead} in @@ -469,19 +469,19 @@ {b} eta {bool} - (\(a : a) (b : b) -> + (\(l1l : a) (l2l : b) -> Tuple2_match {a} {b} eta {bool} - (\(a' : a) (b' : b) -> + (\(r1r : a) (r2r : b) -> case (all dead. bool) - (`$p1Ord` {a} v a a') + (`$p1Ord` {a} v l1l r1r) [ (/\dead -> False) , (/\dead -> - `$p1Ord` {b} v b b') ] + `$p1Ord` {b} v l2l r2r) ] {all dead. dead}))) (\(ds : Tuple2 a b) (ds : Tuple2 a b) -> Tuple2_match diff --git a/plutus-benchmark/nofib/test/9.6/knights10-4x4.golden.pir b/plutus-benchmark/nofib/test/9.6/knights10-4x4.golden.pir index 2642029b340..411a8369204 100644 --- a/plutus-benchmark/nofib/test/9.6/knights10-4x4.golden.pir +++ b/plutus-benchmark/nofib/test/9.6/knights10-4x4.golden.pir @@ -640,27 +640,27 @@ {integer} ds {bool} - (\(a : integer) - (b : integer) -> + (\(l1l : integer) + (l2l : integer) -> Tuple2_match {integer} {integer} ds {bool} - (\(a' : integer) - (b' : integer) -> + (\(r1r : integer) + (r2r : integer) -> case (all dead. bool) (equalsInteger - a - a') + l1l + r1r) [ (/\dead -> False) , (/\dead -> equalsInteger - b - b') ] + l2l + r2r) ] {all dead. dead}))) t @@ -900,16 +900,16 @@ {ChessSet} ds {bool} - (\(a : integer) (b : ChessSet) -> + (\(l1l : integer) (l2l : ChessSet) -> Tuple2_match {integer} {ChessSet} ds {bool} - (\(a' : integer) (b' : ChessSet) -> + (\(r1r : integer) (r2r : ChessSet) -> case (all dead. bool) - (equalsInteger a a') + (equalsInteger l1l r1r) [(/\dead -> False), (/\dead -> True)] {all dead. dead}))) depth @@ -1224,29 +1224,29 @@ {ChessSet} eta {bool} - (\(a : integer) - (b : ChessSet) -> + (\(l1l : integer) + (l2l : ChessSet) -> Tuple2_match {integer} {ChessSet} eta {bool} - (\(a' : integer) - (b' : ChessSet) -> + (\(r1r : integer) + (r2r : ChessSet) -> case (all dead. bool) (`$p1Ord` {integer} v - a - a') + l1l + r1r) [ (/\dead -> False) , (/\dead -> `$p1Ord` {ChessSet} v - b - b') ] + l2l + r2r) ] {all dead. dead}))) (\(ds : Tuple2 integer ChessSet) (ds : Tuple2 integer ChessSet) -> diff --git a/plutus-benchmark/nofib/test/9.6/queens4-bt.golden.pir b/plutus-benchmark/nofib/test/9.6/queens4-bt.golden.pir index 0e1331939d2..3c071fb8980 100644 --- a/plutus-benchmark/nofib/test/9.6/queens4-bt.golden.pir +++ b/plutus-benchmark/nofib/test/9.6/queens4-bt.golden.pir @@ -481,19 +481,19 @@ {bool} True (\(ipv : a) (ipv : List a) -> False)) - (\(x : a) (xs : List a) -> + (\(l1l : a) (l2l : List a) -> /\dead -> List_match {a} eta {bool} False - (\(y : a) (ys : List a) -> + (\(r1r : a) (r2r : List a) -> case (all dead. bool) - (`$dEq` x y) + (`$dEq` l1l r1r) [ (/\dead -> False) - , (/\dead -> `$fEqList_$c==` {a} `$dEq` xs ys) ] + , (/\dead -> `$fEqList_$c==` {a} `$dEq` l2l r2r) ] {all dead. dead})) {all dead. dead} in diff --git a/plutus-benchmark/nofib/test/9.6/queens5-fc.golden.pir b/plutus-benchmark/nofib/test/9.6/queens5-fc.golden.pir index 19f7d5909e1..cc8e4bae931 100644 --- a/plutus-benchmark/nofib/test/9.6/queens5-fc.golden.pir +++ b/plutus-benchmark/nofib/test/9.6/queens5-fc.golden.pir @@ -481,19 +481,19 @@ {bool} True (\(ipv : a) (ipv : List a) -> False)) - (\(x : a) (xs : List a) -> + (\(l1l : a) (l2l : List a) -> /\dead -> List_match {a} eta {bool} False - (\(y : a) (ys : List a) -> + (\(r1r : a) (r2r : List a) -> case (all dead. bool) - (`$dEq` x y) + (`$dEq` l1l r1r) [ (/\dead -> False) - , (/\dead -> `$fEqList_$c==` {a} `$dEq` xs ys) ] + , (/\dead -> `$fEqList_$c==` {a} `$dEq` l2l r2r) ] {all dead. dead})) {all dead. dead} in diff --git a/plutus-benchmark/script-contexts/test/V3/Data/9.6/purposeIsWellFormed.golden.pir b/plutus-benchmark/script-contexts/test/V3/Data/9.6/purposeIsWellFormed.golden.pir index df77332b1b2..7446f0af773 100644 --- a/plutus-benchmark/script-contexts/test/V3/Data/9.6/purposeIsWellFormed.golden.pir +++ b/plutus-benchmark/script-contexts/test/V3/Data/9.6/purposeIsWellFormed.golden.pir @@ -8,13 +8,13 @@ let {integer} ds {all dead. bool} - (\(a : integer) -> + (\(l1l : integer) -> /\dead -> Maybe_match {integer} ds {bool} - (\(a : integer) -> equalsInteger a a) + (\(r1r : integer) -> equalsInteger l1l r1r) False) (/\dead -> Maybe_match {integer} ds {bool} (\(ipv : integer) -> False) True) diff --git a/plutus-ledger-api/changelog.d/20251216_175719_bezirg_derive_eq.md b/plutus-ledger-api/changelog.d/20251216_175719_bezirg_derive_eq.md new file mode 100644 index 00000000000..d14decaa8f9 --- /dev/null +++ b/plutus-ledger-api/changelog.d/20251216_175719_bezirg_derive_eq.md @@ -0,0 +1,11 @@ +### Added + +- PlutusTx.Eq MintValue instance + +### Changed + +- Use deriveEq throughout the api + +### Fixed + +- The `instance Eq V3.Cert` diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Address.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Address.hs index e1df5614fbc..58dc4cfa94e 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Address.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Address.hs @@ -26,7 +26,6 @@ import PlutusLedgerApi.V1.Crypto (PubKeyHash) import PlutusLedgerApi.V1.Scripts (ScriptHash) import PlutusTx qualified import PlutusTx.Blueprint.Definition (HasBlueprintDefinition, definitionRef) -import PlutusTx.Bool qualified as PlutusTx import PlutusTx.Eq qualified as PlutusTx import Prettyprinter (Pretty (pretty), parens, (<+>)) @@ -41,19 +40,13 @@ data Address = Address deriving stock (Eq, Ord, Show, Generic) deriving anyclass (NFData, HasBlueprintDefinition) +PlutusTx.deriveEq ''Address + instance Pretty Address where pretty (Address cred stakingCred) = let staking = maybe "no staking credential" pretty stakingCred in pretty cred <+> parens staking -instance PlutusTx.Eq Address where - {-# INLINEABLE (==) #-} - Address cred stakingCred == Address cred' stakingCred' = - cred - PlutusTx.== cred' - PlutusTx.&& stakingCred - PlutusTx.== stakingCred' - {-# INLINEABLE pubKeyHashAddress #-} {-| The address that should be targeted by a transaction output diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Contexts.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Contexts.hs index 70540628e8e..da0918148ab 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Contexts.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Contexts.hs @@ -78,8 +78,7 @@ data TxInInfo = TxInInfo deriving stock (Generic, Haskell.Show, Haskell.Eq) deriving anyclass (HasBlueprintDefinition) -instance Eq TxInInfo where - TxInInfo ref res == TxInInfo ref' res' = ref == ref' && res == res' +deriveEq ''TxInInfo instance Pretty TxInInfo where pretty TxInInfo {txInInfoOutRef, txInInfoResolved} = @@ -95,13 +94,7 @@ data ScriptPurpose deriving anyclass (HasBlueprintDefinition) deriving (Pretty) via (PrettyShow ScriptPurpose) -instance Eq ScriptPurpose where - {-# INLINEABLE (==) #-} - Minting cs == Minting cs' = cs == cs' - Spending ref == Spending ref' = ref == ref' - Rewarding sc == Rewarding sc' = sc == sc' - Certifying cert == Certifying cert' = cert == cert' - _ == _ = False +deriveEq ''ScriptPurpose -- | A pending transaction. This is the view as seen by validator scripts, so some details are stripped out. data TxInfo = TxInfo @@ -129,10 +122,7 @@ data TxInfo = TxInfo deriving stock (Generic, Haskell.Show, Haskell.Eq) deriving anyclass (HasBlueprintDefinition) -instance Eq TxInfo where - {-# INLINEABLE (==) #-} - TxInfo i o f m c w r s d tid == TxInfo i' o' f' m' c' w' r' s' d' tid' = - i == i' && o == o' && f == f' && m == m' && c == c' && w == w' && r == r' && s == s' && d == d' && tid == tid' +deriveEq ''TxInfo instance Pretty TxInfo where pretty TxInfo {txInfoInputs, txInfoOutputs, txInfoFee, txInfoMint, txInfoDCert, txInfoWdrl, txInfoValidRange, txInfoSignatories, txInfoData, txInfoId} = @@ -158,9 +148,7 @@ data ScriptContext = ScriptContext } deriving stock (Generic, Haskell.Eq, Haskell.Show) -instance Eq ScriptContext where - {-# INLINEABLE (==) #-} - ScriptContext info purpose == ScriptContext info' purpose' = info == info' && purpose == purpose' +deriveEq ''ScriptContext instance Pretty ScriptContext where pretty ScriptContext {scriptContextTxInfo, scriptContextPurpose} = diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Credential.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Credential.hs index 313d77b71ff..4c60db93a43 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Credential.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Credential.hs @@ -22,11 +22,23 @@ import PlutusLedgerApi.V1.Crypto (PubKeyHash) import PlutusLedgerApi.V1.Scripts (ScriptHash) import PlutusTx qualified import PlutusTx.Blueprint (HasBlueprintDefinition, definitionRef) -import PlutusTx.Bool qualified as PlutusTx import PlutusTx.Eq qualified as PlutusTx import PlutusTx.Show (deriveShow) import Prettyprinter (Pretty (..), (<+>)) +-- | Credentials required to unlock a transaction output. +data Credential + = {-| The transaction that spends this output must be signed by the private key. + See `Crypto.PubKeyHash`. -} + PubKeyCredential PubKeyHash + | {-| The transaction that spends this output must include the validator script and + be accepted by the validator. See `ScriptHash`. -} + ScriptCredential ScriptHash + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData, HasBlueprintDefinition) + +PlutusTx.deriveEq ''Credential + -- | Staking credential used to assign rewards. data StakingCredential = {-| The staking hash is the `Credential` required to unlock a transaction output. Either @@ -47,43 +59,16 @@ data StakingCredential deriving stock (Eq, Ord, Show, Generic) deriving anyclass (NFData, HasBlueprintDefinition) +PlutusTx.deriveEq ''StakingCredential + instance Pretty StakingCredential where pretty (StakingHash h) = "StakingHash" <+> pretty h pretty (StakingPtr a b c) = "StakingPtr:" <+> pretty a <+> pretty b <+> pretty c -instance PlutusTx.Eq StakingCredential where - {-# INLINEABLE (==) #-} - StakingHash l == StakingHash r = l PlutusTx.== r - StakingPtr a b c == StakingPtr a' b' c' = - a - PlutusTx.== a' - PlutusTx.&& b - PlutusTx.== b' - PlutusTx.&& c - PlutusTx.== c' - _ == _ = False - --- | Credentials required to unlock a transaction output. -data Credential - = {-| The transaction that spends this output must be signed by the private key. - See `Crypto.PubKeyHash`. -} - PubKeyCredential PubKeyHash - | {-| The transaction that spends this output must include the validator script and - be accepted by the validator. See `ScriptHash`. -} - ScriptCredential ScriptHash - deriving stock (Eq, Ord, Show, Generic) - deriving anyclass (NFData, HasBlueprintDefinition) - instance Pretty Credential where pretty (PubKeyCredential pkh) = "PubKeyCredential:" <+> pretty pkh pretty (ScriptCredential val) = "ScriptCredential:" <+> pretty val -instance PlutusTx.Eq Credential where - {-# INLINEABLE (==) #-} - PubKeyCredential l == PubKeyCredential r = l PlutusTx.== r - ScriptCredential a == ScriptCredential a' = a PlutusTx.== a' - _ == _ = False - ---------------------------------------------------------------------------------------------------- -- TH Splices -------------------------------------------------------------------------------------- diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/DCert.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/DCert.hs index fecf84f00ad..3bc478f27ef 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/DCert.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/DCert.hs @@ -74,16 +74,7 @@ data DCert deriving anyclass (NFData, HasBlueprintDefinition) deriving (Pretty) via (PrettyShow DCert) -instance P.Eq DCert where - {-# INLINEABLE (==) #-} - DCertDelegRegKey sc == DCertDelegRegKey sc' = sc P.== sc' - DCertDelegDeRegKey sc == DCertDelegDeRegKey sc' = sc P.== sc' - DCertDelegDelegate sc pkh == DCertDelegDelegate sc' pkh' = sc P.== sc' && pkh P.== pkh' - DCertPoolRegister pid pvfr == DCertPoolRegister pid' pvfr' = pid P.== pid' && pvfr P.== pvfr' - DCertPoolRetire pkh i == DCertPoolRetire pkh' i' = pkh P.== pkh' && i P.== i' - DCertGenesis == DCertGenesis = True - DCertMir == DCertMir = True - _ == _ = False +P.deriveEq ''DCert ---------------------------------------------------------------------------------------------------- -- TH Splices -------------------------------------------------------------------------------------- diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Address.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Address.hs index b834d3850eb..13154a58fb6 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Address.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Address.hs @@ -56,19 +56,13 @@ PlutusTx.asData deriving anyclass (NFData, HasBlueprintDefinition) |] +PlutusTx.deriveEq ''Address + instance Pretty Address where pretty (Address cred stakingCred) = let staking = maybe "no staking credential" pretty stakingCred in pretty cred <+> parens staking -instance PlutusTx.Eq Address where - {-# INLINEABLE (==) #-} - Address cred stakingCred == Address cred' stakingCred' = - cred - PlutusTx.== cred' - PlutusTx.&& stakingCred - PlutusTx.== stakingCred' - {-# INLINEABLE pubKeyHashAddress #-} {-| The address that should be targeted by a transaction output diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Contexts.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Contexts.hs index a06215f8676..742d179af25 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Contexts.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Contexts.hs @@ -120,8 +120,7 @@ PlutusTx.asData makeLift ''TxInInfo -instance Eq TxInInfo where - TxInInfo ref res == TxInInfo ref' res' = ref == ref' && res == res' +deriveEq ''TxInInfo instance Pretty TxInInfo where pretty TxInInfo {txInInfoOutRef, txInInfoResolved} = @@ -141,14 +140,7 @@ PlutusTx.asData |] makeLift ''ScriptPurpose - -instance Eq ScriptPurpose where - {-# INLINEABLE (==) #-} - Minting cs == Minting cs' = cs == cs' - Spending ref == Spending ref' = ref == ref' - Rewarding sc == Rewarding sc' = sc == sc' - Certifying cert == Certifying cert' = cert == cert' - _ == _ = False +deriveEq ''ScriptPurpose {-| A pending transaction. This is the view as seen by validator scripts, so some details are stripped out. -} @@ -184,30 +176,7 @@ PlutusTx.asData |] makeLift ''TxInfo - -instance Eq TxInfo where - {-# INLINEABLE (==) #-} - TxInfo i o f m c w r s d tid == TxInfo i' o' f' m' c' w' r' s' d' tid' = - i - == i' - && o - == o' - && f - == f' - && m - == m' - && c - == c' - && w - == w' - && r - == r' - && s - == s' - && d - == d' - && tid - == tid' +deriveEq ''TxInfo instance Pretty TxInfo where pretty @@ -251,10 +220,7 @@ PlutusTx.asData |] makeLift ''ScriptContext - -instance Eq ScriptContext where - {-# INLINEABLE (==) #-} - ScriptContext info purpose == ScriptContext info' purpose' = info == info' && purpose == purpose' +deriveEq ''ScriptContext instance Pretty ScriptContext where pretty ScriptContext {scriptContextTxInfo, scriptContextPurpose} = diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Credential.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Credential.hs index 160d2781969..82c9be9a7a0 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Credential.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Credential.hs @@ -51,16 +51,12 @@ PlutusTx.asData deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) |] +PlutusTx.deriveEq ''Credential + instance Pretty Credential where pretty (PubKeyCredential pkh) = "PubKeyCredential:" <+> pretty pkh pretty (ScriptCredential val) = "ScriptCredential:" <+> pretty val -instance PlutusTx.Eq Credential where - {-# INLINEABLE (==) #-} - PubKeyCredential l == PubKeyCredential r = l PlutusTx.== r - ScriptCredential a == ScriptCredential a' = a PlutusTx.== a' - _ == _ = False - {-| Staking credential used to assign rewards. The staking hash constructor is the `Credential` required to unlock a @@ -87,22 +83,12 @@ PlutusTx.asData deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) |] +PlutusTx.deriveEq ''StakingCredential + instance Pretty StakingCredential where pretty (StakingHash h) = "StakingHash" <+> pretty h pretty (StakingPtr a b c) = "StakingPtr:" <+> pretty a <+> pretty b <+> pretty c -instance PlutusTx.Eq StakingCredential where - {-# INLINEABLE (==) #-} - StakingHash l == StakingHash r = l PlutusTx.== r - StakingPtr a b c == StakingPtr a' b' c' = - a - PlutusTx.== a' - PlutusTx.&& b - PlutusTx.== b' - PlutusTx.&& c - PlutusTx.== c' - _ == _ = False - ---------------------------------------------------------------------------------------------------- -- TH Splices -------------------------------------------------------------------------------------- diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/DCert.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/DCert.hs index 614d5931b75..9e97d5b5759 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/DCert.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/DCert.hs @@ -66,6 +66,8 @@ PlutusTx.asData deriving (Pretty) via (PrettyShow DCert) |] +P.deriveEq ''DCert + {-# ANN DCertDelegRegKey (SchemaTitle "DCertDelegRegKey") #-} {-# ANN DCertDelegRegKey (SchemaDescription "Delegation key registration certificate") #-} @@ -87,17 +89,6 @@ PlutusTx.asData {-# ANN DCertMir (SchemaTitle "DCertMir") #-} {-# ANN DCertMir (SchemaDescription "MIR key") #-} -instance P.Eq DCert where - {-# INLINEABLE (==) #-} - DCertDelegRegKey sc == DCertDelegRegKey sc' = sc P.== sc' - DCertDelegDeRegKey sc == DCertDelegDeRegKey sc' = sc P.== sc' - DCertDelegDelegate sc pkh == DCertDelegDelegate sc' pkh' = sc P.== sc' && pkh P.== pkh' - DCertPoolRegister pid pvfr == DCertPoolRegister pid' pvfr' = pid P.== pid' && pvfr P.== pvfr' - DCertPoolRetire pkh i == DCertPoolRetire pkh' i' = pkh P.== pkh' && i P.== i' - DCertGenesis == DCertGenesis = True - DCertMir == DCertMir = True - _ == _ = False - ---------------------------------------------------------------------------------------------------- -- TH Splices -------------------------------------------------------------------------------------- diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Tx.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Tx.hs index f74bebf40cd..d479a787ebb 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Tx.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Tx.hs @@ -49,7 +49,6 @@ import Prettyprinter import PlutusTx qualified import PlutusTx.AsData qualified as PlutusTx -import PlutusTx.Bool qualified as PlutusTx import PlutusTx.Builtins qualified as PlutusTx import PlutusTx.Eq qualified as PlutusTx import PlutusTx.Ord qualified as PlutusTx @@ -118,13 +117,7 @@ PlutusTx.asData instance Pretty TxOutRef where pretty TxOutRef {txOutRefId, txOutRefIdx} = pretty txOutRefId <> "!" <> pretty txOutRefIdx -instance PlutusTx.Eq TxOutRef where - {-# INLINEABLE (==) #-} - l == r = - txOutRefId l - PlutusTx.== txOutRefId r - PlutusTx.&& txOutRefIdx l - PlutusTx.== txOutRefIdx r +PlutusTx.deriveEq ''TxOutRef {-| A transaction output, consisting of a target address ('Address'), a value ('Value'), and optionally a datum hash ('DatumHash'). -} @@ -143,15 +136,7 @@ instance Pretty TxOut where pretty TxOut {txOutAddress, txOutValue} = hang 2 $ vsep ["-" <+> pretty txOutValue <+> "addressed to", pretty txOutAddress] -instance PlutusTx.Eq TxOut where - {-# INLINEABLE (==) #-} - l == r = - txOutAddress l - PlutusTx.== txOutAddress r - PlutusTx.&& txOutValue l - PlutusTx.== txOutValue r - PlutusTx.&& txOutDatumHash l - PlutusTx.== txOutDatumHash r +PlutusTx.deriveEq ''TxOut -- | The datum attached to a 'TxOut', if there is one. txOutDatum :: TxOut -> Maybe DatumHash diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs index bd67675bd56..4bf63068525 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Data/Value.hs @@ -317,27 +317,27 @@ instance HasBlueprintSchema Value referencedTypes where , maxItems = Nothing } -instance Haskell.Eq Value where - (==) = eq - -instance Eq Value where +instance PlutusTx.Eq Value where {-# INLINEABLE (==) #-} (==) = eq -instance Haskell.Semigroup Value where - (<>) = unionWith (+) +instance Haskell.Eq Value where + (==) = (PlutusTx.==) instance Semigroup Value where {-# INLINEABLE (<>) #-} (<>) = unionWith (+) -instance Haskell.Monoid Value where - mempty = Value Map.empty +instance Haskell.Semigroup Value where + (<>) = (PlutusTx.<>) -instance Monoid Value where +instance PlutusTx.Monoid Value where {-# INLINEABLE mempty #-} mempty = Value Map.empty +instance Haskell.Monoid Value where + mempty = PlutusTx.mempty + instance Group Value where {-# INLINEABLE inv #-} inv = scale @Integer @Value (-1) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Interval.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Interval.hs index 8cf757b431a..35bfc1db6f2 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Interval.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Interval.hs @@ -238,26 +238,14 @@ instance Pretty a => Pretty (LowerBound a) where pretty (LowerBound a True) = pretty "[" <+> pretty a pretty (LowerBound a False) = pretty "(" <+> pretty a -instance Eq a => Eq (Extended a) where - {-# INLINEABLE (==) #-} - NegInf == NegInf = True - PosInf == PosInf = True - Finite l == Finite r = l == r - _ == _ = False +deriveEq ''Extended +deriveOrd ''Extended +-- MAYBE: get rid of these and switch to deriving stock, when deriveOrd is merged instance Eq a => Haskell.Eq (Extended a) where (==) = (PlutusTx.==) -instance Ord a => Ord (Extended a) where - {-# INLINEABLE compare #-} - NegInf `compare` NegInf = EQ - NegInf `compare` _ = LT - _ `compare` NegInf = GT - PosInf `compare` PosInf = EQ - _ `compare` PosInf = LT - PosInf `compare` _ = GT - Finite l `compare` Finite r = l `compare` r - +-- MAYBE: get rid of these and switch to deriving stock, when deriveOrd is merged instance Ord a => Haskell.Ord (Extended a) where compare = PlutusTx.compare diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Tx.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Tx.hs index 922de33955e..ba7be936a14 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Tx.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Tx.hs @@ -43,7 +43,6 @@ import Prettyprinter (Pretty (pretty), hang, vsep, (<+>)) import PlutusTx.Blueprint.Definition (HasBlueprintDefinition, definitionRef) import PlutusTx.Blueprint.TH (makeIsDataSchemaIndexed) -import PlutusTx.Bool qualified as PlutusTx import PlutusTx.Builtins qualified as PlutusTx import PlutusTx.Eq qualified as PlutusTx import PlutusTx.Lift (makeLift) @@ -102,17 +101,11 @@ data TxOutRef = TxOutRef deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NFData, HasBlueprintDefinition) +PlutusTx.deriveEq ''TxOutRef + instance Pretty TxOutRef where pretty TxOutRef {txOutRefId, txOutRefIdx} = pretty txOutRefId <> "!" <> pretty txOutRefIdx -instance PlutusTx.Eq TxOutRef where - {-# INLINEABLE (==) #-} - l == r = - txOutRefId l - PlutusTx.== txOutRefId r - PlutusTx.&& txOutRefIdx l - PlutusTx.== txOutRefIdx r - {-| A transaction output, consisting of a target address ('Address'), a value ('Value'), and optionally a datum hash ('DatumHash'). -} data TxOut = TxOut @@ -123,20 +116,12 @@ data TxOut = TxOut deriving stock (Show, Eq, Generic) deriving anyclass (NFData, HasBlueprintDefinition) +PlutusTx.deriveEq ''TxOut + instance Pretty TxOut where pretty TxOut {txOutAddress, txOutValue} = hang 2 $ vsep ["-" <+> pretty txOutValue <+> "addressed to", pretty txOutAddress] -instance PlutusTx.Eq TxOut where - {-# INLINEABLE (==) #-} - l == r = - txOutAddress l - PlutusTx.== txOutAddress r - PlutusTx.&& txOutValue l - PlutusTx.== txOutValue r - PlutusTx.&& txOutDatumHash l - PlutusTx.== txOutDatumHash r - -- | The datum attached to a 'TxOut', if there is one. txOutDatum :: TxOut -> Maybe DatumHash txOutDatum TxOut {txOutDatumHash} = txOutDatumHash diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V1/Value.hs b/plutus-ledger-api/src/PlutusLedgerApi/V1/Value.hs index a0a4d86b30c..7e1cf907b36 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V1/Value.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V1/Value.hs @@ -307,27 +307,27 @@ instance HasBlueprintSchema Value referencedTypes where , maxItems = Nothing } -instance Haskell.Eq Value where - (==) = eq - -instance Eq Value where +instance PlutusTx.Eq Value where {-# INLINEABLE (==) #-} (==) = eq -instance Haskell.Semigroup Value where - (<>) = unionWith (+) +instance Haskell.Eq Value where + (==) = (PlutusTx.==) -instance Semigroup Value where +instance PlutusTx.Semigroup Value where {-# INLINEABLE (<>) #-} (<>) = unionWith (+) -instance Haskell.Monoid Value where - mempty = Value Map.empty +instance Haskell.Semigroup Value where + (<>) = (PlutusTx.<>) -instance Monoid Value where +instance PlutusTx.Monoid Value where {-# INLINEABLE mempty #-} mempty = Value Map.empty +instance Haskell.Monoid Value where + mempty = PlutusTx.mempty + instance Group Value where {-# INLINEABLE inv #-} inv = scale @Integer @Value (-1) diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/Contexts.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/Contexts.hs index cb67a4f417a..6514e0c2863 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/Contexts.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/Contexts.hs @@ -70,8 +70,7 @@ data TxInInfo = TxInInfo deriving stock (Generic, Haskell.Show, Haskell.Eq) deriving anyclass (HasBlueprintDefinition) -instance Eq TxInInfo where - TxInInfo ref res == TxInInfo ref' res' = ref == ref' && res == res' +deriveEq ''TxInInfo instance Pretty TxInInfo where pretty TxInInfo {txInInfoOutRef, txInInfoResolved} = @@ -109,6 +108,10 @@ data TxInfo = TxInfo deriving stock (Generic, Haskell.Show, Haskell.Eq) deriving anyclass (HasBlueprintDefinition) +-- TODO: to support this we need to have Eq AssocMap or +-- move to another Map implementation. +-- deriveEq ''TxInfo + instance Pretty TxInfo where pretty TxInfo {txInfoInputs, txInfoReferenceInputs, txInfoOutputs, txInfoFee, txInfoMint, txInfoDCert, txInfoWdrl, txInfoValidRange, txInfoSignatories, txInfoRedeemers, txInfoData, txInfoId} = vsep @@ -135,6 +138,10 @@ data ScriptContext = ScriptContext } deriving stock (Generic, Haskell.Eq, Haskell.Show) +-- TODO: to support this we need to have Eq AssocMap or +-- move to another Map implementation. +-- deriveEq ''ScriptContext + instance Pretty ScriptContext where pretty ScriptContext {scriptContextTxInfo, scriptContextPurpose} = vsep diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Contexts.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Contexts.hs index e4b207987d0..7adbbc87c95 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Contexts.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Contexts.hs @@ -121,11 +121,9 @@ PlutusTx.asData deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) |] +deriveEq ''TxInInfo makeLift ''TxInInfo -instance Eq TxInInfo where - TxInInfo ref res == TxInInfo ref' res' = ref == ref' && res == res' - instance Pretty TxInInfo where pretty TxInInfo {txInInfoOutRef, txInInfoResolved} = pretty txInInfoOutRef <+> "->" <+> pretty txInInfoResolved diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Tx.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Tx.hs index 5589d72f8e2..e635bba2e32 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Tx.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/Data/Tx.hs @@ -53,7 +53,6 @@ import Prettyprinter import PlutusTx qualified import PlutusTx.AsData qualified as PlutusTx -import PlutusTx.Bool qualified as PlutusTx import PlutusTx.Eq qualified as PlutusTx import PlutusLedgerApi.V1.Crypto @@ -85,12 +84,7 @@ PlutusTx.asData deriving anyclass (NFData) |] -instance PlutusTx.Eq OutputDatum where - {-# INLINEABLE (==) #-} - NoOutputDatum == NoOutputDatum = True - (OutputDatumHash dh) == (OutputDatumHash dh') = dh PlutusTx.== dh' - (OutputDatum d) == (OutputDatum d') = d PlutusTx.== d' - _ == _ = False +PlutusTx.deriveEq ''OutputDatum instance Pretty OutputDatum where pretty NoOutputDatum = "no datum" @@ -111,6 +105,8 @@ PlutusTx.asData deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) |] +PlutusTx.deriveEq ''TxOut + instance Pretty TxOut where pretty TxOut {txOutAddress, txOutValue, txOutDatum, txOutReferenceScript} = hang 2 $ @@ -123,19 +119,6 @@ instance Pretty TxOut where , pretty txOutReferenceScript ] -instance PlutusTx.Eq TxOut where - {-# INLINEABLE (==) #-} - (TxOut txOutAddress1 txOutValue1 txOutDatum1 txOutRefScript1) - == (TxOut txOutAddress2 txOutValue2 txOutDatum2 txOutRefScript2) = - txOutAddress1 - PlutusTx.== txOutAddress2 - PlutusTx.&& txOutValue1 - PlutusTx.== txOutValue2 - PlutusTx.&& txOutDatum1 - PlutusTx.== txOutDatum2 - PlutusTx.&& txOutRefScript1 - PlutusTx.== txOutRefScript2 - -- | The public key attached to a 'TxOut', if there is one. txOutPubKey :: TxOut -> Maybe PubKeyHash txOutPubKey = toPubKeyHash . txOutAddress diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V2/Tx.hs b/plutus-ledger-api/src/PlutusLedgerApi/V2/Tx.hs index ea4f6a85bb6..9f9ae9c2b3a 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V2/Tx.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V2/Tx.hs @@ -40,7 +40,6 @@ import GHC.Generics (Generic) import Prettyprinter (Pretty (pretty), hang, vsep, (<+>)) import PlutusTx.Blueprint.TH (makeIsDataSchemaIndexed) -import PlutusTx.Bool qualified as PlutusTx import PlutusTx.Eq qualified as PlutusTx import PlutusTx.Lift (makeLift) @@ -68,12 +67,7 @@ data OutputDatum = NoOutputDatum | OutputDatumHash DatumHash | OutputDatum Datum deriving stock (Show, Eq, Generic) deriving anyclass (NFData, HasBlueprintDefinition) -instance PlutusTx.Eq OutputDatum where - {-# INLINEABLE (==) #-} - NoOutputDatum == NoOutputDatum = True - (OutputDatumHash dh) == (OutputDatumHash dh') = dh PlutusTx.== dh' - (OutputDatum d) == (OutputDatum d') = d PlutusTx.== d' - _ == _ = False +PlutusTx.deriveEq ''OutputDatum instance Pretty OutputDatum where pretty NoOutputDatum = "no datum" @@ -91,6 +85,8 @@ data TxOut = TxOut deriving stock (Show, Eq, Generic) deriving anyclass (NFData, HasBlueprintDefinition) +PlutusTx.deriveEq ''TxOut + instance Pretty TxOut where pretty TxOut {txOutAddress, txOutValue, txOutDatum, txOutReferenceScript} = hang 2 $ @@ -105,19 +101,6 @@ instance Pretty TxOut where , pretty txOutReferenceScript ] -instance PlutusTx.Eq TxOut where - {-# INLINEABLE (==) #-} - TxOut txOutAddress txOutValue txOutDatum txOutRefScript - == TxOut txOutAddress' txOutValue' txOutDatum' txOutRefScript' = - txOutAddress - PlutusTx.== txOutAddress' - PlutusTx.&& txOutValue - PlutusTx.== txOutValue' - PlutusTx.&& txOutDatum - PlutusTx.== txOutDatum' - PlutusTx.&& txOutRefScript - PlutusTx.== txOutRefScript' - -- | The public key attached to a 'TxOut', if there is one. txOutPubKey :: TxOut -> Maybe PubKeyHash txOutPubKey TxOut {txOutAddress} = toPubKeyHash txOutAddress diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/Contexts.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/Contexts.hs index 243cf613304..2b4b137b626 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/Contexts.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/Contexts.hs @@ -163,12 +163,7 @@ data DRep deriving anyclass (HasBlueprintDefinition) deriving (Pretty) via (PrettyShow DRep) -instance PlutusTx.Eq DRep where - {-# INLINEABLE (==) #-} - DRep a == DRep a' = a PlutusTx.== a' - DRepAlwaysAbstain == DRepAlwaysAbstain = Haskell.True - DRepAlwaysNoConfidence == DRepAlwaysNoConfidence = Haskell.True - _ == _ = Haskell.False +PlutusTx.deriveEq ''DRep data Delegatee = DelegStake V2.PubKeyHash @@ -178,13 +173,7 @@ data Delegatee deriving anyclass (HasBlueprintDefinition) deriving (Pretty) via (PrettyShow Delegatee) -instance PlutusTx.Eq Delegatee where - {-# INLINEABLE (==) #-} - DelegStake a == DelegStake a' = a PlutusTx.== a' - DelegVote a == DelegVote a' = a PlutusTx.== a' - DelegStakeVote a b == DelegStakeVote a' b' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' - _ == _ = Haskell.False +PlutusTx.deriveEq ''Delegatee data TxCert = -- | Register staking credential with an optional deposit amount @@ -217,27 +206,7 @@ data TxCert deriving anyclass (HasBlueprintDefinition) deriving (Pretty) via (PrettyShow TxCert) -instance PlutusTx.Eq TxCert where - {-# INLINEABLE (==) #-} - TxCertRegStaking a b == TxCertRegStaking a' b' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' - TxCertUnRegStaking a b == TxCertUnRegStaking a' b' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' - TxCertDelegStaking a b == TxCertDelegStaking a' b' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' - TxCertRegDeleg a b c == TxCertRegDeleg a' b' c' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' PlutusTx.&& c PlutusTx.== c' - TxCertRegDRep a b == TxCertRegDRep a' b' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' - TxCertUpdateDRep a == TxCertUpdateDRep a' = - a PlutusTx.== a' - TxCertUnRegDRep a b == TxCertUnRegDRep a' b' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' - TxCertAuthHotCommittee a b == TxCertAuthHotCommittee a' b' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' - TxCertResignColdCommittee a == TxCertResignColdCommittee a' = - a PlutusTx.== a' - _ == _ = Haskell.False +PlutusTx.deriveEq ''TxCert data Voter = CommitteeVoter HotCommitteeCredential @@ -247,15 +216,7 @@ data Voter deriving anyclass (HasBlueprintDefinition) deriving (Pretty) via (PrettyShow Voter) -instance PlutusTx.Eq Voter where - {-# INLINEABLE (==) #-} - CommitteeVoter a == CommitteeVoter a' = - a PlutusTx.== a' - DRepVoter a == DRepVoter a' = - a PlutusTx.== a' - StakePoolVoter a == StakePoolVoter a' = - a PlutusTx.== a' - _ == _ = Haskell.False +PlutusTx.deriveEq ''Voter -- | A vote. The optional anchor is omitted. data Vote @@ -266,12 +227,7 @@ data Vote deriving anyclass (HasBlueprintDefinition) deriving (Pretty) via (PrettyShow Vote) -instance PlutusTx.Eq Vote where - {-# INLINEABLE (==) #-} - VoteNo == VoteNo = Haskell.True - VoteYes == VoteYes = Haskell.True - Abstain == Abstain = Haskell.True - _ == _ = Haskell.False +PlutusTx.deriveEq ''Vote -- | Similar to TxOutRef, but for GovActions data GovernanceActionId = GovernanceActionId @@ -281,6 +237,8 @@ data GovernanceActionId = GovernanceActionId deriving stock (Generic, Haskell.Show, Haskell.Eq, Haskell.Ord) deriving anyclass (HasBlueprintDefinition) +PlutusTx.deriveEq ''GovernanceActionId + instance Pretty GovernanceActionId where pretty GovernanceActionId {..} = vsep @@ -288,11 +246,6 @@ instance Pretty GovernanceActionId where , "gaidGovActionIx:" <+> pretty gaidGovActionIx ] -instance PlutusTx.Eq GovernanceActionId where - {-# INLINEABLE (==) #-} - GovernanceActionId a b == GovernanceActionId a' b' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' - data Committee = Committee { committeeMembers :: Map ColdCommitteeCredential Haskell.Integer -- ^ Committee members with epoch number when each of them expires @@ -317,13 +270,11 @@ newtype Constitution = Constitution deriving newtype (Haskell.Show, Haskell.Eq, Haskell.Ord) deriving anyclass (HasBlueprintDefinition) +PlutusTx.deriveEq ''Constitution + instance Pretty Constitution where pretty (Constitution script) = "constitutionScript:" <+> pretty script -instance PlutusTx.Eq Constitution where - {-# INLINEABLE (==) #-} - Constitution a == Constitution a' = a PlutusTx.== a' - data ProtocolVersion = ProtocolVersion { pvMajor :: Haskell.Integer , pvMinor :: Haskell.Integer @@ -331,6 +282,9 @@ data ProtocolVersion = ProtocolVersion deriving stock (Generic, Haskell.Show, Haskell.Eq, Haskell.Ord) deriving anyclass (HasBlueprintDefinition) +PlutusTx.deriveEq ''ProtocolVersion +PlutusTx.deriveOrd ''ProtocolVersion + instance Pretty ProtocolVersion where pretty ProtocolVersion {..} = vsep @@ -338,11 +292,6 @@ instance Pretty ProtocolVersion where , "pvMinor:" <+> pretty pvMinor ] -instance PlutusTx.Eq ProtocolVersion where - {-# INLINEABLE (==) #-} - ProtocolVersion a b == ProtocolVersion a' b' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' - {-| A Plutus Data object containing proposed parameter changes. The Data object contains a @Map@ with one entry per changed parameter, from the parameter ID to the new value. Unchanged parameters are not included. @@ -412,6 +361,10 @@ data GovernanceAction deriving anyclass (HasBlueprintDefinition) deriving (Pretty) via (PrettyShow GovernanceAction) +-- TODO: to support this we need to have Eq AssocMap or +-- move to another Map implementation. +-- PlutusTx.deriveEq ''GovernanceAction + -- | A proposal procedure. The optional anchor is omitted. data ProposalProcedure = ProposalProcedure { ppDeposit :: V2.Lovelace @@ -421,6 +374,10 @@ data ProposalProcedure = ProposalProcedure deriving stock (Generic, Haskell.Show, Haskell.Eq, Haskell.Ord) deriving anyclass (HasBlueprintDefinition) +-- TODO: to support this we need to have Eq AssocMap or +-- move to another Map implementation. +-- PlutusTx.deriveEq ''ProposalProcedure + instance Pretty ProposalProcedure where pretty ProposalProcedure {..} = vsep @@ -473,9 +430,7 @@ data TxInInfo = TxInInfo deriving stock (Generic, Haskell.Show, Haskell.Eq) deriving anyclass (HasBlueprintDefinition) -instance PlutusTx.Eq TxInInfo where - TxInInfo ref res == TxInInfo ref' res' = - ref PlutusTx.== ref' PlutusTx.&& res PlutusTx.== res' +PlutusTx.deriveEq ''TxInInfo instance Pretty TxInInfo where pretty TxInInfo {txInInfoOutRef, txInInfoResolved} = @@ -507,6 +462,10 @@ data TxInfo = TxInfo deriving stock (Generic, Haskell.Show, Haskell.Eq) deriving anyclass (HasBlueprintDefinition) +-- TODO: to support this we need to have Eq AssocMap or +-- move to another Map implementation. +-- PlutusTx.deriveEq ''TxInfo + instance Pretty TxInfo where pretty TxInfo {..} = vsep @@ -541,6 +500,10 @@ data ScriptContext = ScriptContext deriving stock (Generic, Haskell.Eq, Haskell.Show) deriving anyclass (HasBlueprintDefinition) +-- TODO: to support this we need to have Eq AssocMap or +-- move to another Map implementation. +-- PlutusTx.deriveEq ''ScriptContext + instance Pretty ScriptContext where pretty ScriptContext {..} = vsep diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Contexts.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Contexts.hs index abc02489319..c91edf4d29d 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Contexts.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Contexts.hs @@ -203,15 +203,9 @@ PlutusTx.asData deriving (Pretty) via (PrettyShow DRep) |] +PlutusTx.deriveEq ''DRep PlutusTx.makeLift ''DRep -instance PlutusTx.Eq DRep where - {-# INLINEABLE (==) #-} - DRep a == DRep a' = a PlutusTx.== a' - DRepAlwaysAbstain == DRepAlwaysAbstain = Haskell.True - DRepAlwaysNoConfidence == DRepAlwaysNoConfidence = Haskell.True - _ == _ = Haskell.False - PlutusTx.asData [d| data Delegatee @@ -223,16 +217,9 @@ PlutusTx.asData deriving (Pretty) via (PrettyShow Delegatee) |] +PlutusTx.deriveEq ''Delegatee PlutusTx.makeLift ''Delegatee -instance PlutusTx.Eq Delegatee where - {-# INLINEABLE (==) #-} - DelegStake a == DelegStake a' = a PlutusTx.== a' - DelegVote a == DelegVote a' = a PlutusTx.== a' - DelegStakeVote a b == DelegStakeVote a' b' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' - _ == _ = Haskell.False - PlutusTx.asData [d| data TxCert @@ -267,30 +254,9 @@ PlutusTx.asData deriving (Pretty) via (PrettyShow TxCert) |] +PlutusTx.deriveEq ''TxCert PlutusTx.makeLift ''TxCert -instance PlutusTx.Eq TxCert where - {-# INLINEABLE (==) #-} - TxCertRegStaking a b == TxCertRegStaking a' b' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' - TxCertUnRegStaking a b == TxCertUnRegStaking a' b' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' - TxCertDelegStaking a b == TxCertDelegStaking a' b' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' - TxCertRegDeleg a b c == TxCertRegDeleg a' b' c' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' PlutusTx.&& c PlutusTx.== c' - TxCertRegDRep a b == TxCertRegDRep a' b' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' - TxCertUpdateDRep a == TxCertUpdateDRep a' = - a PlutusTx.== a' - TxCertUnRegDRep a b == TxCertUnRegDRep a' b' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' - TxCertAuthHotCommittee a b == TxCertAuthHotCommittee a' b' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' - TxCertResignColdCommittee a == TxCertResignColdCommittee a' = - a PlutusTx.== a' - _ == _ = Haskell.False - PlutusTx.asData [d| data Voter @@ -302,18 +268,9 @@ PlutusTx.asData deriving (Pretty) via (PrettyShow Voter) |] +PlutusTx.deriveEq ''Voter PlutusTx.makeLift ''Voter -instance PlutusTx.Eq Voter where - {-# INLINEABLE (==) #-} - CommitteeVoter a == CommitteeVoter a' = - a PlutusTx.== a' - DRepVoter a == DRepVoter a' = - a PlutusTx.== a' - StakePoolVoter a == StakePoolVoter a' = - a PlutusTx.== a' - _ == _ = Haskell.False - -- | A vote. The optional anchor is omitted. PlutusTx.asData [d| @@ -326,15 +283,9 @@ PlutusTx.asData deriving (Pretty) via (PrettyShow Vote) |] +PlutusTx.deriveEq ''Vote PlutusTx.makeLift ''Vote -instance PlutusTx.Eq Vote where - {-# INLINEABLE (==) #-} - VoteNo == VoteNo = Haskell.True - VoteYes == VoteYes = Haskell.True - Abstain == Abstain = Haskell.True - _ == _ = Haskell.False - -- | Similar to TxOutRef, but for GovActions PlutusTx.asData [d| @@ -346,6 +297,7 @@ PlutusTx.asData deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) |] +PlutusTx.deriveEq ''GovernanceActionId PlutusTx.makeLift ''GovernanceActionId instance Pretty GovernanceActionId where @@ -355,11 +307,6 @@ instance Pretty GovernanceActionId where , "gaidGovActionIx:" <+> pretty gaidGovActionIx ] -instance PlutusTx.Eq GovernanceActionId where - {-# INLINEABLE (==) #-} - GovernanceActionId a b == GovernanceActionId a' b' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' - PlutusTx.asData [d| data Committee = Committee @@ -389,16 +336,13 @@ newtype Constitution = Constitution deriving stock (Generic) deriving newtype (Haskell.Show, Haskell.Eq) +PlutusTx.deriveEq ''Constitution PlutusTx.makeLift ''Constitution PlutusTx.makeIsDataIndexed ''Constitution [('Constitution, 0)] instance Pretty Constitution where pretty (Constitution script) = "constitutionScript:" <+> pretty script -instance PlutusTx.Eq Constitution where - {-# INLINEABLE (==) #-} - Constitution a == Constitution a' = a PlutusTx.== a' - PlutusTx.asData [d| data ProtocolVersion = ProtocolVersion @@ -409,6 +353,7 @@ PlutusTx.asData deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) |] +PlutusTx.deriveEq ''ProtocolVersion PlutusTx.makeLift ''ProtocolVersion instance Pretty ProtocolVersion where @@ -418,11 +363,6 @@ instance Pretty ProtocolVersion where , "pvMinor:" <+> pretty pvMinor ] -instance PlutusTx.Eq ProtocolVersion where - {-# INLINEABLE (==) #-} - ProtocolVersion a b == ProtocolVersion a' b' = - a PlutusTx.== a' PlutusTx.&& b PlutusTx.== b' - {-| A Plutus Data object containing proposed parameter changes. The Data object contains a @Map@ with one entry per changed parameter, from the parameter ID to the new value. Unchanged parameters are not included. @@ -556,12 +496,9 @@ PlutusTx.asData deriving newtype (PlutusTx.FromData, PlutusTx.UnsafeFromData, PlutusTx.ToData) |] +PlutusTx.deriveEq ''TxInInfo PlutusTx.makeLift ''TxInInfo -instance PlutusTx.Eq TxInInfo where - TxInInfo ref res == TxInInfo ref' res' = - ref PlutusTx.== ref' PlutusTx.&& res PlutusTx.== res' - instance Pretty TxInInfo where pretty TxInInfo {txInInfoOutRef, txInInfoResolved} = pretty txInInfoOutRef <+> "->" <+> pretty txInInfoResolved diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/MintValue.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/MintValue.hs index ba47f421907..b603bfaea62 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/MintValue.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/MintValue.hs @@ -25,7 +25,7 @@ module PlutusLedgerApi.V3.Data.MintValue ) where -import PlutusTx.Prelude +import PlutusTx.Prelude as PlutusTx import GHC.Generics (Generic) import PlutusLedgerApi.V1.Data.Value (CurrencySymbol, TokenName, Value (..)) @@ -62,9 +62,13 @@ newtype MintValue = UnsafeMintValue (Map CurrencySymbol (Map TokenName Integer)) deriving newtype (ToData, FromData, UnsafeFromData) deriving (Pretty) via (PrettyShow MintValue) -instance Haskell.Eq MintValue where +instance PlutusTx.Eq MintValue where + {-# INLINEABLE (==) #-} l == r = mintValueMinted l == mintValueMinted r && mintValueBurned l == mintValueBurned r +instance Haskell.Eq MintValue where + (==) = (PlutusTx.==) + instance HasBlueprintDefinition MintValue where type Unroll MintValue = '[MintValue, CurrencySymbol, TokenName, Integer] definitionId = definitionIdFromType @MintValue diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Tx.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Tx.hs index ceee0dd96ee..3df44a42947 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Tx.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/Data/Tx.hs @@ -32,7 +32,6 @@ import PlutusTx.Blueprint.Class (HasBlueprintSchema (..)) import PlutusTx.Blueprint.Definition (HasBlueprintDefinition) import PlutusTx.Blueprint.Schema (withSchemaInfo) import PlutusTx.Blueprint.Schema.Annotation (SchemaInfo (..)) -import PlutusTx.Bool qualified as PlutusTx import PlutusTx.Builtins.Internal qualified as PlutusTx import PlutusTx.Eq qualified as PlutusTx import PlutusTx.IsData.Class (FromData, ToData, UnsafeFromData) @@ -81,15 +80,11 @@ PlutusTx.asData deriving anyclass (NFData, HasBlueprintDefinition) |] +PlutusTx.deriveEq ''TxOutRef + instance Pretty TxOutRef where pretty TxOutRef {txOutRefId = id', txOutRefIdx = idx} = pretty id' <> "!" <> pretty idx -instance PlutusTx.Eq TxOutRef where - {-# INLINEABLE (==) #-} - l == r = - (txOutRefId l PlutusTx.== txOutRefId r) - PlutusTx.&& (txOutRefIdx l PlutusTx.== txOutRefIdx r) - ---------------------------------------------------------------------------------------------------- -- TH Splices -------------------------------------------------------------------------------------- diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/MintValue.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/MintValue.hs index 9fddf56e598..0059511312a 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/MintValue.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/MintValue.hs @@ -25,7 +25,7 @@ module PlutusLedgerApi.V3.MintValue ) where -import PlutusTx.Prelude +import PlutusTx.Prelude as PlutusTx import Control.DeepSeq (NFData) import Data.Data (Data) @@ -61,15 +61,19 @@ Users should project 'MintValue' into 'Value' using 'mintValueMinted' or 'mintVa -} -- | A 'MintValue' represents assets that are minted and burned in a transaction. -newtype MintValue = UnsafeMintValue {unMintValue :: (Map CurrencySymbol (Map TokenName Integer))} +newtype MintValue = UnsafeMintValue {unMintValue :: Map CurrencySymbol (Map TokenName Integer)} deriving stock (Generic, Data, Haskell.Show) deriving anyclass (NFData) deriving newtype (ToData, FromData, UnsafeFromData) deriving (Pretty) via (PrettyShow MintValue) -instance Haskell.Eq MintValue where +instance PlutusTx.Eq MintValue where + {-# INLINEABLE (==) #-} l == r = mintValueMinted l == mintValueMinted r && mintValueBurned l == mintValueBurned r +instance Haskell.Eq MintValue where + (==) = (PlutusTx.==) + instance HasBlueprintDefinition MintValue where type Unroll MintValue = '[MintValue, CurrencySymbol, TokenName, Integer] definitionId = definitionIdFromType @MintValue diff --git a/plutus-ledger-api/src/PlutusLedgerApi/V3/Tx.hs b/plutus-ledger-api/src/PlutusLedgerApi/V3/Tx.hs index 97cabb26203..b162f7d2ca1 100644 --- a/plutus-ledger-api/src/PlutusLedgerApi/V3/Tx.hs +++ b/plutus-ledger-api/src/PlutusLedgerApi/V3/Tx.hs @@ -26,7 +26,6 @@ import PlutusTx.Blueprint.Definition (HasBlueprintDefinition, definitionRef) import PlutusTx.Blueprint.Schema (withSchemaInfo) import PlutusTx.Blueprint.Schema.Annotation (SchemaInfo (..)) import PlutusTx.Blueprint.TH (makeIsDataSchemaIndexed) -import PlutusTx.Bool qualified as PlutusTx import PlutusTx.Builtins.Internal qualified as PlutusTx import PlutusTx.Eq qualified as PlutusTx import PlutusTx.IsData.Class (FromData, ToData, UnsafeFromData) @@ -70,15 +69,11 @@ data TxOutRef = TxOutRef deriving stock (Show, Eq, Ord, Generic) deriving anyclass (NFData, HasBlueprintDefinition) +PlutusTx.deriveEq ''TxOutRef + instance Pretty TxOutRef where pretty TxOutRef {txOutRefId, txOutRefIdx} = pretty txOutRefId <> "!" <> pretty txOutRefIdx -instance PlutusTx.Eq TxOutRef where - {-# INLINEABLE (==) #-} - l == r = - (txOutRefId l PlutusTx.== txOutRefId r) - PlutusTx.&& (txOutRefIdx l PlutusTx.== txOutRefIdx r) - ---------------------------------------------------------------------------------------------------- -- TH Splices -------------------------------------------------------------------------------------- diff --git a/plutus-tx-plugin/test/IsData/9.6/MyMonoData.golden.th b/plutus-tx-plugin/test/IsData/9.6/MyMonoData.golden.th index 375f9f8de46..93577cad6f3 100644 --- a/plutus-tx-plugin/test/IsData/9.6/MyMonoData.golden.th +++ b/plutus-tx-plugin/test/IsData/9.6/MyMonoData.golden.th @@ -8,12 +8,12 @@ instance PlutusTx.IsData.Class.FromData Plugin.Data.Spec.MyMonoData where {{-# INLINABLE PlutusTx.IsData.Class.fromBuiltinData #-}; PlutusTx.IsData.Class.fromBuiltinData d_4 = let constrFun_5 (!index_6) (!args_7) = case (index_6, args_7) of - {(((PlutusTx.Eq.==) (0 :: GHC.Num.Integer.Integer) -> GHC.Types.True), + {(((PlutusTx.Eq.Class.==) (0 :: GHC.Num.Integer.Integer) -> GHC.Types.True), (PlutusTx.Builtins.uncons -> GHC.Maybe.Just ((PlutusTx.IsData.Class.fromBuiltinData -> GHC.Maybe.Just arg_8), (PlutusTx.Builtins.headMaybe -> GHC.Maybe.Just (PlutusTx.IsData.Class.fromBuiltinData -> GHC.Maybe.Just arg_9))))) -> GHC.Maybe.Just (Plugin.Data.Spec.Mono1 arg_8 arg_9); - (((PlutusTx.Eq.==) (1 :: GHC.Num.Integer.Integer) -> GHC.Types.True), + (((PlutusTx.Eq.Class.==) (1 :: GHC.Num.Integer.Integer) -> GHC.Types.True), (PlutusTx.Builtins.headMaybe -> GHC.Maybe.Just (PlutusTx.IsData.Class.fromBuiltinData -> GHC.Maybe.Just arg_10))) -> GHC.Maybe.Just (Plugin.Data.Spec.Mono2 arg_10); - (((PlutusTx.Eq.==) (2 :: GHC.Num.Integer.Integer) -> GHC.Types.True), + (((PlutusTx.Eq.Class.==) (2 :: GHC.Num.Integer.Integer) -> GHC.Types.True), (PlutusTx.Builtins.headMaybe -> GHC.Maybe.Just (PlutusTx.IsData.Class.fromBuiltinData -> GHC.Maybe.Just arg_11))) -> GHC.Maybe.Just (Plugin.Data.Spec.Mono3 arg_11); _ -> GHC.Maybe.Nothing} in PlutusTx.Builtins.matchData' d_4 constrFun_5 (GHC.Base.const GHC.Maybe.Nothing) (GHC.Base.const GHC.Maybe.Nothing) (GHC.Base.const GHC.Maybe.Nothing) (GHC.Base.const GHC.Maybe.Nothing)} diff --git a/plutus-tx-plugin/test/IsData/9.6/MyMonoRecord.golden.th b/plutus-tx-plugin/test/IsData/9.6/MyMonoRecord.golden.th index 9f4cb9c1b95..bd60c058ad3 100644 --- a/plutus-tx-plugin/test/IsData/9.6/MyMonoRecord.golden.th +++ b/plutus-tx-plugin/test/IsData/9.6/MyMonoRecord.golden.th @@ -6,7 +6,7 @@ instance PlutusTx.IsData.Class.FromData Plugin.Data.Spec.MyMonoRecord where {{-# INLINABLE PlutusTx.IsData.Class.fromBuiltinData #-}; PlutusTx.IsData.Class.fromBuiltinData d_2 = let constrFun_3 (!index_4) (!args_5) = case (index_4, args_5) of - {(((PlutusTx.Eq.==) (0 :: GHC.Num.Integer.Integer) -> GHC.Types.True), + {(((PlutusTx.Eq.Class.==) (0 :: GHC.Num.Integer.Integer) -> GHC.Types.True), (PlutusTx.Builtins.uncons -> GHC.Maybe.Just ((PlutusTx.IsData.Class.fromBuiltinData -> GHC.Maybe.Just arg_6), (PlutusTx.Builtins.headMaybe -> GHC.Maybe.Just (PlutusTx.IsData.Class.fromBuiltinData -> GHC.Maybe.Just arg_7))))) -> GHC.Maybe.Just (Plugin.Data.Spec.MyMonoRecord arg_6 arg_7); _ -> GHC.Maybe.Nothing} diff --git a/plutus-tx-plugin/test/IsData/9.6/MyPolyData.golden.th b/plutus-tx-plugin/test/IsData/9.6/MyPolyData.golden.th index fbee3a576d8..1011711ec8e 100644 --- a/plutus-tx-plugin/test/IsData/9.6/MyPolyData.golden.th +++ b/plutus-tx-plugin/test/IsData/9.6/MyPolyData.golden.th @@ -11,10 +11,10 @@ instance (PlutusTx.IsData.Class.FromData a_0, where {{-# INLINABLE PlutusTx.IsData.Class.fromBuiltinData #-}; PlutusTx.IsData.Class.fromBuiltinData d_5 = let constrFun_6 (!index_7) (!args_8) = case (index_7, args_8) of - {(((PlutusTx.Eq.==) (0 :: GHC.Num.Integer.Integer) -> GHC.Types.True), + {(((PlutusTx.Eq.Class.==) (0 :: GHC.Num.Integer.Integer) -> GHC.Types.True), (PlutusTx.Builtins.uncons -> GHC.Maybe.Just ((PlutusTx.IsData.Class.fromBuiltinData -> GHC.Maybe.Just arg_9), (PlutusTx.Builtins.headMaybe -> GHC.Maybe.Just (PlutusTx.IsData.Class.fromBuiltinData -> GHC.Maybe.Just arg_10))))) -> GHC.Maybe.Just (Plugin.Data.Spec.Poly1 arg_9 arg_10); - (((PlutusTx.Eq.==) (1 :: GHC.Num.Integer.Integer) -> GHC.Types.True), + (((PlutusTx.Eq.Class.==) (1 :: GHC.Num.Integer.Integer) -> GHC.Types.True), (PlutusTx.Builtins.headMaybe -> GHC.Maybe.Just (PlutusTx.IsData.Class.fromBuiltinData -> GHC.Maybe.Just arg_11))) -> GHC.Maybe.Just (Plugin.Data.Spec.Poly2 arg_11); _ -> GHC.Maybe.Nothing} in PlutusTx.Builtins.matchData' d_5 constrFun_6 (GHC.Base.const GHC.Maybe.Nothing) (GHC.Base.const GHC.Maybe.Nothing) (GHC.Base.const GHC.Maybe.Nothing) (GHC.Base.const GHC.Maybe.Nothing)} diff --git a/plutus-tx/changelog.d/20251125_110335_bezirg_derive_eq.md b/plutus-tx/changelog.d/20251125_110335_bezirg_derive_eq.md new file mode 100644 index 00000000000..d8676e38057 --- /dev/null +++ b/plutus-tx/changelog.d/20251125_110335_bezirg_derive_eq.md @@ -0,0 +1,4 @@ +### Added + +- A `deriveEq` command to derive PlutusTx.Eq instances for datatypes/newtypes, similar to Haskell's + `deriving stock Eq` diff --git a/plutus-tx/changelog.d/20251203_141812_bezirg_derive_ord.md b/plutus-tx/changelog.d/20251203_141812_bezirg_derive_ord.md new file mode 100644 index 00000000000..7973a9b8cd8 --- /dev/null +++ b/plutus-tx/changelog.d/20251203_141812_bezirg_derive_ord.md @@ -0,0 +1,4 @@ +### Added + +- A `deriveOrd` command to derive PlutusTx.Ord instances for datatypes/newtypes, similar to Haskell's + `deriving stock Ord` diff --git a/plutus-tx/plutus-tx.cabal b/plutus-tx/plutus-tx.cabal index e03751dc9ea..15214a486da 100644 --- a/plutus-tx/plutus-tx.cabal +++ b/plutus-tx/plutus-tx.cabal @@ -86,6 +86,7 @@ library PlutusTx.Enum PlutusTx.Enum.Class PlutusTx.Eq + PlutusTx.Eq.Class PlutusTx.ErrorCodes PlutusTx.Eval PlutusTx.Foldable @@ -104,6 +105,7 @@ library PlutusTx.Optimize.Inline PlutusTx.Optimize.SpaceTime PlutusTx.Ord + PlutusTx.Ord.Class PlutusTx.Plugin.Utils PlutusTx.Prelude PlutusTx.Ratio @@ -119,12 +121,14 @@ library other-modules: PlutusTx.Enum.TH + PlutusTx.Eq.TH PlutusTx.IsData.Instances PlutusTx.IsData.TH PlutusTx.Lift.Instances PlutusTx.Lift.TestInstances PlutusTx.Lift.TH PlutusTx.Lift.THUtils + PlutusTx.Ord.TH build-depends: , aeson >=2.2 @@ -211,7 +215,9 @@ test-suite plutus-tx-test Blueprint.Spec Bool.Spec Enum.Spec + Eq.Spec List.Spec + Ord.Spec Rational.Laws Rational.Laws.Additive Rational.Laws.Construction diff --git a/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs b/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs index 99a314846af..a1939deabd3 100644 --- a/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs +++ b/plutus-tx/src/PlutusTx/Builtins/HasOpaque.hs @@ -8,7 +8,6 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} module PlutusTx.Builtins.HasOpaque where diff --git a/plutus-tx/src/PlutusTx/Either.hs b/plutus-tx/src/PlutusTx/Either.hs index 46a67ab74ff..168a2e7a441 100644 --- a/plutus-tx/src/PlutusTx/Either.hs +++ b/plutus-tx/src/PlutusTx/Either.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} - module PlutusTx.Either (Either (..), isLeft, isRight, either) where {- diff --git a/plutus-tx/src/PlutusTx/Eq.hs b/plutus-tx/src/PlutusTx/Eq.hs index 39e8fac0962..a2a603b85bd 100644 --- a/plutus-tx/src/PlutusTx/Eq.hs +++ b/plutus-tx/src/PlutusTx/Eq.hs @@ -1,81 +1,43 @@ -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-orphans #-} -module PlutusTx.Eq (Eq (..), (/=)) where +module PlutusTx.Eq (Eq (..), (/=), deriveEq) where import PlutusTx.Bool -import PlutusTx.Builtins qualified as Builtins import PlutusTx.Either (Either (..)) -import Prelude (Maybe (..)) - -{- HLINT ignore -} - -infix 4 ==, /= - --- Copied from the GHC definition - --- | The 'Eq' class defines equality ('=='). -class Eq a where - (==) :: a -> a -> Bool - --- (/=) deliberately omitted, to make this a one-method class which has a --- simpler representation - -(/=) :: Eq a => a -> a -> Bool -x /= y = not (x == y) -{-# INLINEABLE (/=) #-} - -instance Eq Builtins.Integer where - {-# INLINEABLE (==) #-} - (==) = Builtins.equalsInteger - -instance Eq Builtins.BuiltinByteString where - {-# INLINEABLE (==) #-} - (==) = Builtins.equalsByteString - -instance Eq Builtins.BuiltinData where - {-# INLINEABLE (==) #-} - (==) = Builtins.equalsData - -instance Eq Builtins.BuiltinString where - {-# INLINEABLE (==) #-} - (==) = Builtins.equalsString - -instance Eq Builtins.BuiltinBLS12_381_G1_Element where - {-# INLINEABLE (==) #-} - (==) = Builtins.bls12_381_G1_equals - -instance Eq Builtins.BuiltinBLS12_381_G2_Element where - {-# INLINEABLE (==) #-} - (==) = Builtins.bls12_381_G2_equals - -instance Eq a => Eq [a] where - {-# INLINEABLE (==) #-} - [] == [] = True - (x : xs) == (y : ys) = x == y && xs == ys - _ == _ = False - -instance Eq Bool where - {-# INLINEABLE (==) #-} - True == True = True - False == False = True - _ == _ = False - -instance Eq a => Eq (Maybe a) where - {-# INLINEABLE (==) #-} - (Just a1) == (Just a2) = a1 == a2 - Nothing == Nothing = True - _ == _ = False - -instance (Eq a, Eq b) => Eq (Either a b) where - {-# INLINEABLE (==) #-} - (Left a1) == (Left a2) = a1 == a2 - (Right b1) == (Right b2) = b1 == b2 - _ == _ = False - -instance Eq () where - {-# INLINEABLE (==) #-} - _ == _ = True - -instance (Eq a, Eq b) => Eq (a, b) where - {-# INLINEABLE (==) #-} - (a, b) == (a', b') = a == a' && b == b' +import PlutusTx.Eq.Class +import PlutusTx.Eq.TH +import Prelude (Maybe (..), Ordering (..)) + +deriveEq ''[] +deriveEq ''Bool +deriveEq ''Maybe +deriveEq ''Either +deriveEq ''Ordering +deriveEq ''() +deriveEq ''(,) +deriveEq ''(,,) +deriveEq ''(,,,) +deriveEq ''(,,,,) +deriveEq ''(,,,,,) +deriveEq ''(,,,,,,) +deriveEq ''(,,,,,,,) +deriveEq ''(,,,,,,,,) +deriveEq ''(,,,,,,,,,) +deriveEq ''(,,,,,,,,,,) +deriveEq ''(,,,,,,,,,,,) +deriveEq ''(,,,,,,,,,,,,) +deriveEq ''(,,,,,,,,,,,,,) +deriveEq ''(,,,,,,,,,,,,,,) +deriveEq ''(,,,,,,,,,,,,,,,) +deriveEq ''(,,,,,,,,,,,,,,,,) +deriveEq ''(,,,,,,,,,,,,,,,,,) +deriveEq ''(,,,,,,,,,,,,,,,,,,) +deriveEq ''(,,,,,,,,,,,,,,,,,,,) +deriveEq ''(,,,,,,,,,,,,,,,,,,,,) +deriveEq ''(,,,,,,,,,,,,,,,,,,,,,) +deriveEq ''(,,,,,,,,,,,,,,,,,,,,,,) +deriveEq ''(,,,,,,,,,,,,,,,,,,,,,,,) +deriveEq ''(,,,,,,,,,,,,,,,,,,,,,,,,) +deriveEq ''(,,,,,,,,,,,,,,,,,,,,,,,,,) +deriveEq ''(,,,,,,,,,,,,,,,,,,,,,,,,,,) diff --git a/plutus-tx/src/PlutusTx/Eq/Class.hs b/plutus-tx/src/PlutusTx/Eq/Class.hs new file mode 100644 index 00000000000..ab8e834d830 --- /dev/null +++ b/plutus-tx/src/PlutusTx/Eq/Class.hs @@ -0,0 +1,45 @@ +module PlutusTx.Eq.Class + ( Eq (..) + , (/=) + ) where + +import PlutusTx.Bool +import PlutusTx.Builtins qualified as Builtins + +infix 4 == + +{-| The 'Eq' class defines equality ('=='). + +(/=) deliberately omitted, to make this a one-method class which has a +simpler representation -} +class Eq a where + (==) :: a -> a -> Bool + +infix 4 /= +(/=) :: Eq a => a -> a -> Bool +x /= y = not (x == y) +{-# INLINEABLE (/=) #-} + +instance Eq Builtins.Integer where + {-# INLINEABLE (==) #-} + (==) = Builtins.equalsInteger + +instance Eq Builtins.BuiltinByteString where + {-# INLINEABLE (==) #-} + (==) = Builtins.equalsByteString + +instance Eq Builtins.BuiltinData where + {-# INLINEABLE (==) #-} + (==) = Builtins.equalsData + +instance Eq Builtins.BuiltinString where + {-# INLINEABLE (==) #-} + (==) = Builtins.equalsString + +instance Eq Builtins.BuiltinBLS12_381_G1_Element where + {-# INLINEABLE (==) #-} + (==) = Builtins.bls12_381_G1_equals + +instance Eq Builtins.BuiltinBLS12_381_G2_Element where + {-# INLINEABLE (==) #-} + (==) = Builtins.bls12_381_G2_equals diff --git a/plutus-tx/src/PlutusTx/Eq/TH.hs b/plutus-tx/src/PlutusTx/Eq/TH.hs new file mode 100644 index 00000000000..ab879463386 --- /dev/null +++ b/plutus-tx/src/PlutusTx/Eq/TH.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module PlutusTx.Eq.TH (Eq (..), deriveEq) where + +import Data.Deriving.Internal (varTToName) +import Data.Foldable +import Data.Traversable +import Language.Haskell.TH +import Language.Haskell.TH.Datatype +import PlutusTx.Bool (Bool (True), (&&)) +import PlutusTx.Eq.Class hiding ((/=)) +import Prelude hiding (Bool (True), Eq, (&&), (==)) + +{-| derive a PlutusTx.Eq instance for a datatype/newtype, similar to Haskell's `deriving stock Eq`. + +One shortcoming compared to Haskell's deriving is that you cannot `PlutusTx.deriveEq` for polymorphic phantom types. -} +deriveEq :: Name -> Q [Dec] +deriveEq name = do + DatatypeInfo + { datatypeName = tyConName + , datatypeInstTypes = tyVars0 + , datatypeCons = cons + } <- + reifyDatatype name + + roles <- reifyRoles name + + let + -- The purpose of the `VarT . varTToName` roundtrip is to remove the kind + -- signatures attached to the type variables in `tyVars0`. Otherwise, the + -- `KindSignatures` extension would be needed whenever `length tyVars0 > 0`. + tyVars = VarT . varTToName <$> tyVars0 + + nonPhantomTyVars = VarT . varTToName . snd <$> filter ((/= PhantomR) . fst) (zip roles tyVars0) + + instanceCxt :: Cxt + instanceCxt = AppT (ConT ''Eq) <$> nonPhantomTyVars + + instanceType :: Type + instanceType = AppT (ConT ''Eq) $ foldl' AppT (ConT tyConName) tyVars + + pure + <$> instanceD + (pure instanceCxt) + (pure instanceType) + [ funD '(==) (fmap deriveEqCons cons <> maybeDefaultClause cons) + , pragInlD '(==) Inlinable FunLike AllPhases + ] + +-- Clause: Cons1 l1 l2 l3 .. ln == Cons1 r1 r2 r3 .. rn +deriveEqCons :: ConstructorInfo -> Q Clause +deriveEqCons (ConstructorInfo {constructorName = name, constructorFields = fields}) = + do + argsL <- for [1 .. length fields] $ \i -> newName ("l" <> show i <> "l") + argsR <- for [1 .. length fields] $ \i -> newName ("r" <> show i <> "r") + ( clause + [conP name (fmap varP argsL), conP name (fmap varP argsR)] + ( normalB $ + case fields of + [] -> conE 'True + _ -> + foldr1 (\e acc -> infixE (pure e) (varE '(&&)) (pure acc)) $ + zipWith + ( \argL argR -> + infixE (pure $ varE argL) (varE '(==)) (pure $ varE argR) + ) + argsL + argsR + ) + [] + ) + +maybeDefaultClause :: [ConstructorInfo] -> [Q Clause] +maybeDefaultClause = \case + [_] -> [] -- if one constructor no need to generate default clause + [] -> [clause [wildP, wildP] (normalB $ conE 'True) []] -- if void datatype aka 0 constructors, generate a True clause + _ -> [clause [wildP, wildP] (normalB $ conE 'False) []] -- if >1 constructors, generate a False clause diff --git a/plutus-tx/src/PlutusTx/ErrorCodes.hs b/plutus-tx/src/PlutusTx/ErrorCodes.hs index 7a5dbc829a4..dc591741f23 100644 --- a/plutus-tx/src/PlutusTx/ErrorCodes.hs +++ b/plutus-tx/src/PlutusTx/ErrorCodes.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} module PlutusTx.ErrorCodes where diff --git a/plutus-tx/src/PlutusTx/Foldable.hs b/plutus-tx/src/PlutusTx/Foldable.hs index 3f9730ce54d..d3feeaf2a5d 100644 --- a/plutus-tx/src/PlutusTx/Foldable.hs +++ b/plutus-tx/src/PlutusTx/Foldable.hs @@ -1,5 +1,4 @@ {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} module PlutusTx.Foldable diff --git a/plutus-tx/src/PlutusTx/Functor.hs b/plutus-tx/src/PlutusTx/Functor.hs index 3f5ff655a8b..58f01beb820 100644 --- a/plutus-tx/src/PlutusTx/Functor.hs +++ b/plutus-tx/src/PlutusTx/Functor.hs @@ -1,6 +1,5 @@ {-# LANGUAGE InstanceSigs #-} {-# LANGUAGE LambdaCase #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} module PlutusTx.Functor (Functor (..), (<$>), (<&>), (<$)) where diff --git a/plutus-tx/src/PlutusTx/IsData/Class.hs b/plutus-tx/src/PlutusTx/IsData/Class.hs index aaa53f694f1..c957d264577 100644 --- a/plutus-tx/src/PlutusTx/IsData/Class.hs +++ b/plutus-tx/src/PlutusTx/IsData/Class.hs @@ -7,7 +7,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} module PlutusTx.IsData.Class diff --git a/plutus-tx/src/PlutusTx/List.hs b/plutus-tx/src/PlutusTx/List.hs index b7687aa6ae8..ba0c40be1c6 100644 --- a/plutus-tx/src/PlutusTx/List.hs +++ b/plutus-tx/src/PlutusTx/List.hs @@ -1,7 +1,6 @@ -- editorconfig-checker-disable-file {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} module PlutusTx.List ( uncons diff --git a/plutus-tx/src/PlutusTx/Maybe.hs b/plutus-tx/src/PlutusTx/Maybe.hs index a55068ea1e5..707c540bfc9 100644 --- a/plutus-tx/src/PlutusTx/Maybe.hs +++ b/plutus-tx/src/PlutusTx/Maybe.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} - module PlutusTx.Maybe (Maybe (..), isJust, isNothing, maybe, fromMaybe, mapMaybe) where {- diff --git a/plutus-tx/src/PlutusTx/Monoid.hs b/plutus-tx/src/PlutusTx/Monoid.hs index f2c62a6efbd..2278fd2367e 100644 --- a/plutus-tx/src/PlutusTx/Monoid.hs +++ b/plutus-tx/src/PlutusTx/Monoid.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fno-specialise #-} module PlutusTx.Monoid (Monoid (..), mappend, mconcat, Group (..), gsub) where @@ -10,6 +8,7 @@ import PlutusTx.Base (id) import PlutusTx.Builtins qualified as Builtins import PlutusTx.List import PlutusTx.Maybe +import PlutusTx.Ord import PlutusTx.Semigroup {- HLINT ignore -} @@ -68,6 +67,10 @@ instance Monoid (First a) where {-# INLINEABLE mempty #-} mempty = First Nothing +instance Monoid Ordering where + {-# INLINEABLE mempty #-} + mempty = EQ + class Monoid a => Group a where inv :: a -> a diff --git a/plutus-tx/src/PlutusTx/Numeric.hs b/plutus-tx/src/PlutusTx/Numeric.hs index 93dc19a7314..931ba85c2d5 100644 --- a/plutus-tx/src/PlutusTx/Numeric.hs +++ b/plutus-tx/src/PlutusTx/Numeric.hs @@ -2,7 +2,6 @@ {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE FunctionalDependencies #-} {-# OPTIONS_GHC -Wno-orphans #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} module PlutusTx.Numeric ( -- * Type classes diff --git a/plutus-tx/src/PlutusTx/Ord.hs b/plutus-tx/src/PlutusTx/Ord.hs index 990b0769808..61694e3912c 100644 --- a/plutus-tx/src/PlutusTx/Ord.hs +++ b/plutus-tx/src/PlutusTx/Ord.hs @@ -1,131 +1,43 @@ -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} --- editorconfig-checker-disable-file -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module PlutusTx.Ord (Ord (..), Ordering (..)) where - -{- -We export off-chain Haskell's Ordering type as on-chain Plutus's Ordering type since they are the same. --} - -import PlutusTx.Bool (Bool (..)) -import PlutusTx.Builtins qualified as Builtins -import PlutusTx.Either (Either (..)) -import PlutusTx.Eq -import Prelude (Maybe (..), Ordering (..)) - -{- HLINT ignore -} - -infix 4 <, <=, >, >= - --- Copied from the GHC definition - -{-| The 'Ord' class is used for totally ordered datatypes. - -Minimal complete definition: either 'compare' or '<='. -Using 'compare' can be more efficient for complex types. -} -class Eq a => Ord a where - compare :: a -> a -> Ordering - (<), (<=), (>), (>=) :: a -> a -> Bool - max, min :: a -> a -> a - - {-# INLINEABLE compare #-} - compare x y = - if x == y - then EQ - -- NB: must be '<=' not '<' to validate the - -- above claim about the minimal things that - -- can be defined for an instance of Ord: - else - if x <= y - then LT - else GT - - {-# INLINEABLE (<) #-} - x < y = case compare x y of LT -> True; _ -> False - {-# INLINEABLE (<=) #-} - x <= y = case compare x y of GT -> False; _ -> True - {-# INLINEABLE (>) #-} - x > y = case compare x y of GT -> True; _ -> False - {-# INLINEABLE (>=) #-} - x >= y = case compare x y of LT -> False; _ -> True - - -- These two default methods use '<=' rather than 'compare' - -- because the latter is often more expensive - {-# INLINEABLE max #-} - max x y = if x <= y then y else x - {-# INLINEABLE min #-} - min x y = if x <= y then x else y - {-# MINIMAL compare | (<=) #-} - -instance Eq Ordering where - {-# INLINEABLE (==) #-} - EQ == EQ = True - GT == GT = True - LT == LT = True - _ == _ = False - -instance Ord Builtins.Integer where - {-# INLINEABLE (<) #-} - (<) = Builtins.lessThanInteger - {-# INLINEABLE (<=) #-} - (<=) = Builtins.lessThanEqualsInteger - {-# INLINEABLE (>) #-} - (>) = Builtins.greaterThanInteger - {-# INLINEABLE (>=) #-} - (>=) = Builtins.greaterThanEqualsInteger - -instance Ord Builtins.BuiltinByteString where - {-# INLINEABLE (<) #-} - (<) = Builtins.lessThanByteString - {-# INLINEABLE (<=) #-} - (<=) = Builtins.lessThanEqualsByteString - {-# INLINEABLE (>) #-} - (>) = Builtins.greaterThanByteString - {-# INLINEABLE (>=) #-} - (>=) = Builtins.greaterThanEqualsByteString - -instance Ord a => Ord [a] where - {-# INLINEABLE compare #-} - compare [] [] = EQ - compare [] (_ : _) = LT - compare (_ : _) [] = GT - compare (x : xs) (y : ys) = - case compare x y of - EQ -> compare xs ys - c -> c - -instance Ord Bool where - {-# INLINEABLE compare #-} - compare b1 b2 = case b1 of - False -> case b2 of - False -> EQ - True -> LT - True -> case b2 of - False -> GT - True -> EQ - -instance Ord a => Ord (Maybe a) where - {-# INLINEABLE compare #-} - compare (Just a1) (Just a2) = compare a1 a2 - compare Nothing (Just _) = LT - compare (Just _) Nothing = GT - compare Nothing Nothing = EQ - -instance (Ord a, Ord b) => Ord (Either a b) where - {-# INLINEABLE compare #-} - compare (Left a1) (Left a2) = compare a1 a2 - compare (Left _) (Right _) = LT - compare (Right _) (Left _) = GT - compare (Right b1) (Right b2) = compare b1 b2 - -instance Ord () where - {-# INLINEABLE compare #-} - compare _ _ = EQ - -instance (Ord a, Ord b) => Ord (a, b) where - {-# INLINEABLE compare #-} - compare (a, b) (a', b') = - case compare a a' of - EQ -> compare b b' - c -> c +{-# LANGUAGE TemplateHaskell #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module PlutusTx.Ord (Ord (..), Ordering (..), deriveOrd) where + +import PlutusTx.Bool +import PlutusTx.Either +import PlutusTx.Ord.Class +import PlutusTx.Ord.TH +import Prelude (Maybe (..)) + +deriveOrd ''[] +deriveOrd ''Bool +deriveOrd ''Maybe +deriveOrd ''Either +deriveOrd ''Ordering +deriveOrd ''() +deriveOrd ''(,) +deriveOrd ''(,,) +deriveOrd ''(,,,) +deriveOrd ''(,,,,) +deriveOrd ''(,,,,,) +deriveOrd ''(,,,,,,) +deriveOrd ''(,,,,,,,) +deriveOrd ''(,,,,,,,,) +deriveOrd ''(,,,,,,,,,) +deriveOrd ''(,,,,,,,,,,) +deriveOrd ''(,,,,,,,,,,,) +deriveOrd ''(,,,,,,,,,,,,) +deriveOrd ''(,,,,,,,,,,,,,) +deriveOrd ''(,,,,,,,,,,,,,,) +deriveOrd ''(,,,,,,,,,,,,,,,) +deriveOrd ''(,,,,,,,,,,,,,,,,) +deriveOrd ''(,,,,,,,,,,,,,,,,,) +deriveOrd ''(,,,,,,,,,,,,,,,,,,) +deriveOrd ''(,,,,,,,,,,,,,,,,,,,) +deriveOrd ''(,,,,,,,,,,,,,,,,,,,,) +deriveOrd ''(,,,,,,,,,,,,,,,,,,,,,) +deriveOrd ''(,,,,,,,,,,,,,,,,,,,,,,) +deriveOrd ''(,,,,,,,,,,,,,,,,,,,,,,,) +deriveOrd ''(,,,,,,,,,,,,,,,,,,,,,,,,) +deriveOrd ''(,,,,,,,,,,,,,,,,,,,,,,,,,) +deriveOrd ''(,,,,,,,,,,,,,,,,,,,,,,,,,,) diff --git a/plutus-tx/src/PlutusTx/Ord/Class.hs b/plutus-tx/src/PlutusTx/Ord/Class.hs new file mode 100644 index 00000000000..606580115d8 --- /dev/null +++ b/plutus-tx/src/PlutusTx/Ord/Class.hs @@ -0,0 +1,79 @@ +-- editorconfig-checker-disable-file +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module PlutusTx.Ord.Class (Ord (..), Ordering (..)) where + +{- +We export off-chain Haskell's Ordering type as on-chain Plutus's Ordering type since they are the same. +-} + +import PlutusTx.Bool (Bool (..)) +import PlutusTx.Builtins qualified as Builtins +import PlutusTx.Either (Either (..)) +import PlutusTx.Eq +import Prelude (Ordering (..)) + +{- HLINT ignore -} + +infix 4 <, <=, >, >= + +-- Copied from the GHC definition + +{- | The 'Ord' class is used for totally ordered datatypes. + +Minimal complete definition: either 'compare' or '<='. +Using 'compare' can be more efficient for complex types. +-} +class Eq a => Ord a where + compare :: a -> a -> Ordering + (<), (<=), (>), (>=) :: a -> a -> Bool + max, min :: a -> a -> a + + {-# INLINEABLE compare #-} + compare x y = + if x == y + then EQ + -- NB: must be '<=' not '<' to validate the + -- above claim about the minimal things that + -- can be defined for an instance of Ord: + else + if x <= y + then LT + else GT + + {-# INLINEABLE (<) #-} + x < y = case compare x y of LT -> True; _ -> False + {-# INLINEABLE (<=) #-} + x <= y = case compare x y of GT -> False; _ -> True + {-# INLINEABLE (>) #-} + x > y = case compare x y of GT -> True; _ -> False + {-# INLINEABLE (>=) #-} + x >= y = case compare x y of LT -> False; _ -> True + + -- These two default methods use '<=' rather than 'compare' + -- because the latter is often more expensive + {-# INLINEABLE max #-} + max x y = if x <= y then y else x + {-# INLINEABLE min #-} + min x y = if x <= y then x else y + {-# MINIMAL compare | (<=) #-} + +instance Ord Builtins.Integer where + {-# INLINEABLE (<) #-} + (<) = Builtins.lessThanInteger + {-# INLINEABLE (<=) #-} + (<=) = Builtins.lessThanEqualsInteger + {-# INLINEABLE (>) #-} + (>) = Builtins.greaterThanInteger + {-# INLINEABLE (>=) #-} + (>=) = Builtins.greaterThanEqualsInteger + +instance Ord Builtins.BuiltinByteString where + {-# INLINEABLE (<) #-} + (<) = Builtins.lessThanByteString + {-# INLINEABLE (<=) #-} + (<=) = Builtins.lessThanEqualsByteString + {-# INLINEABLE (>) #-} + (>) = Builtins.greaterThanByteString + {-# INLINEABLE (>=) #-} + (>=) = Builtins.greaterThanEqualsByteString diff --git a/plutus-tx/src/PlutusTx/Ord/TH.hs b/plutus-tx/src/PlutusTx/Ord/TH.hs new file mode 100644 index 00000000000..8b94a3bbba5 --- /dev/null +++ b/plutus-tx/src/PlutusTx/Ord/TH.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TemplateHaskellQuotes #-} + +module PlutusTx.Ord.TH (deriveOrd) where + +import Data.Deriving.Internal (varTToName) +import Data.Foldable +import Data.Traversable +import Language.Haskell.TH as TH +import Language.Haskell.TH.Datatype as TH +import PlutusTx.Ord.Class +import Prelude hiding (Bool (True), Eq ((==)), Ord (..), Ordering (..), (&&)) + +{- | derive a PlutusTx.Ord instance for a datatype/newtype, similar to Haskell's `deriving stock Ord`. + +One shortcoming compared to Haskell's deriving is that you cannot `PlutusTx.deriveOrd` for polymorphic phantom types. +-} +deriveOrd :: TH.Name -> TH.Q [TH.Dec] +deriveOrd name = do + TH.DatatypeInfo + { TH.datatypeName = tyConName + , TH.datatypeInstTypes = tyVars0 + , TH.datatypeCons = cons + } <- + TH.reifyDatatype name + + roles <- reifyRoles name + + let + -- The purpose of the `TH.VarT . varTToName` roundtrip is to remove the kind + -- signatures attached to the type variables in `tyVars0`. Otherwise, the + -- `KindSignatures` extension would be needed whenever `length tyVars0 > 0`. + tyVars = TH.VarT . varTToName <$> tyVars0 + + nonPhantomTyVars = VarT . varTToName . snd <$> filter ((/= PhantomR) . fst) (zip roles tyVars0) + + instanceCxt :: TH.Cxt + instanceCxt = TH.AppT (TH.ConT ''Ord) <$> nonPhantomTyVars + + instanceType :: TH.Type + instanceType = TH.AppT (TH.ConT ''Ord) $ foldl' TH.AppT (TH.ConT tyConName) tyVars + + pure + <$> instanceD + (pure instanceCxt) + (pure instanceType) + [ funD 'compare (fmap deriveOrdSame cons ++ maybeDeriveOrdDifferent cons) + , TH.pragInlD 'compare TH.Inlinable TH.FunLike TH.AllPhases + ] + +deriveOrdSame :: ConstructorInfo -> Q Clause +deriveOrdSame (ConstructorInfo {constructorName = name, constructorFields = fields}) = do + argsL <- for [1 .. length fields] $ \i -> TH.newName ("l" <> show i <> "l") + argsR <- for [1 .. length fields] $ \i -> TH.newName ("r" <> show i <> "r") + pure + ( TH.Clause + [ConP name [] (fmap VarP argsL), ConP name [] (fmap VarP argsR)] + ( NormalB $ + case fields of + [] -> TH.ConE 'EQ + _ -> + foldr1 (\e acc -> TH.InfixE (pure e) (TH.VarE '(<>)) (pure acc)) $ + zipWith + ( \argL argR -> + TH.InfixE (pure $ TH.VarE argL) (TH.VarE 'compare) (pure $ TH.VarE argR) + ) + argsL + argsR + ) + [] + ) + +maybeDeriveOrdDifferent :: [ConstructorInfo] -> [Q Clause] +maybeDeriveOrdDifferent = \case + [] -> [clause [wildP, wildP] (normalB $ conE 'EQ) []] -- if void datatype aka 0 constructors, generate an EQ clause + (x : xs) -> mkLTGT [] x xs -- if >1 constructors, generate LT,GT sequences + +-- OPTIMIZE: can be a small optimization here so that if lt==[] or gt==[], then use wildcard instead of generating multiple clauses +mkLTGT :: [ConstructorInfo] -> ConstructorInfo -> [ConstructorInfo] -> [Q Clause] +mkLTGT gt needle@(ConstructorInfo {constructorName = name}) lt = + case lt of + [] -> mkClause 'GT <$> gt -- this covers also the case of a single constructor + (hlt : tlt) -> + (mkClause 'LT <$> lt) + ++ (mkClause 'GT <$> gt) + ++ mkLTGT (needle : gt) hlt tlt + where + mkClause val r = clause [recP name [], recP (constructorName r) []] (normalB $ conE val) [] diff --git a/plutus-tx/src/PlutusTx/Prelude.hs b/plutus-tx/src/PlutusTx/Prelude.hs index 977a4b03ae4..6e06534da93 100644 --- a/plutus-tx/src/PlutusTx/Prelude.hs +++ b/plutus-tx/src/PlutusTx/Prelude.hs @@ -5,7 +5,6 @@ {-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_GHC -Wno-unused-imports #-} {-# OPTIONS_GHC -fmax-simplifier-iterations=0 #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-| The PlutusTx Prelude is a replacement for the Haskell Prelude that works better with Plutus Tx. You should use it if you're writing code that diff --git a/plutus-tx/src/PlutusTx/Ratio.hs b/plutus-tx/src/PlutusTx/Ratio.hs index da50e82c730..555713614c4 100644 --- a/plutus-tx/src/PlutusTx/Ratio.hs +++ b/plutus-tx/src/PlutusTx/Ratio.hs @@ -75,17 +75,12 @@ data Rational = Rational Integer Integer deriving stock (Haskell.Eq, Haskell.Show, Generic) makeLift ''Rational +P.deriveEq ''Rational instance Pretty Rational where pretty (Rational a b) = "Rational:" <+> pretty a <+> pretty b -instance P.Eq Rational where - {-# INLINEABLE (==) #-} - Rational n d == Rational n' d' = n P.== n' P.&& d P.== d' - instance P.Ord Rational where - {-# INLINEABLE compare #-} - compare (Rational n d) (Rational n' d') = P.compare (n P.* d') (n' P.* d) {-# INLINEABLE (<=) #-} Rational n d <= Rational n' d' = (n P.* d') P.<= (n' P.* d) {-# INLINEABLE (>=) #-} diff --git a/plutus-tx/src/PlutusTx/Semigroup.hs b/plutus-tx/src/PlutusTx/Semigroup.hs index 95131ec9614..1acbc34aaa6 100644 --- a/plutus-tx/src/PlutusTx/Semigroup.hs +++ b/plutus-tx/src/PlutusTx/Semigroup.hs @@ -1,5 +1,4 @@ {-# LANGUAGE InstanceSigs #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} module PlutusTx.Semigroup (Semigroup (..), Max (..), Min (..)) where diff --git a/plutus-tx/src/PlutusTx/Sqrt.hs b/plutus-tx/src/PlutusTx/Sqrt.hs index 08f6160e68e..b8e40f5649c 100644 --- a/plutus-tx/src/PlutusTx/Sqrt.hs +++ b/plutus-tx/src/PlutusTx/Sqrt.hs @@ -6,8 +6,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ViewPatterns #-} -{-# OPTIONS_GHC -fno-ignore-interface-pragmas #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} {-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:context-level=3 #-} module PlutusTx.Sqrt diff --git a/plutus-tx/src/PlutusTx/These.hs b/plutus-tx/src/PlutusTx/These.hs index cfedd17b8e3..47c7f502d7c 100644 --- a/plutus-tx/src/PlutusTx/These.hs +++ b/plutus-tx/src/PlutusTx/These.hs @@ -10,7 +10,6 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-name-shadowing #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} module PlutusTx.These ( These (..) @@ -21,19 +20,21 @@ module PlutusTx.These import GHC.Generics (Generic) import PlutusTx.Blueprint.Definition (HasBlueprintDefinition, definitionRef) import PlutusTx.Blueprint.TH (makeIsDataSchemaIndexed) -import PlutusTx.Bool import PlutusTx.Eq import PlutusTx.Lift import PlutusTx.Ord import PlutusTx.Show import Prelude qualified as Haskell -{-| A 'These' @a@ @b@ is either an @a@, or a @b@ or an @a@ and a @b@. -Plutus version of 'Data.These'. -} +{- | A 'These' @a@ @b@ is either an @a@, or a @b@ or an @a@ and a @b@. +Plutus version of 'Data.These'. +-} data These a b = This a | That b | These a b deriving stock (Generic, Haskell.Eq, Haskell.Show) deriving anyclass (HasBlueprintDefinition) +deriveEq ''These +deriveOrd ''These deriveShow ''These makeLift ''These makeIsDataSchemaIndexed ''These [('This, 0), ('That, 1), ('These, 2)] @@ -53,24 +54,3 @@ these f g h = \case That b -> g b These a b -> h a b {-# INLINEABLE these #-} - -instance (Ord a, Ord b) => Ord (These a b) where - {-# INLINEABLE compare #-} - compare (This a) (This a') = compare a a' - compare (That b) (That b') = compare b b' - compare (These a b) (These a' b') = - case compare a a' of - EQ -> compare b b' - c -> c - compare (This _) _ = LT - compare (That _) (This _) = GT - compare (That _) (These _ _) = LT - compare (These _ _) (This _) = GT - compare (These _ _) (That _) = GT - -instance (Eq a, Eq b) => Eq (These a b) where - {-# INLINEABLE (==) #-} - (This a) == (This a') = a == a' - (That b) == (That b') = b == b' - (These a b) == (These a' b') = a == a' && b == b' - _ == _ = False diff --git a/plutus-tx/src/PlutusTx/Trace.hs b/plutus-tx/src/PlutusTx/Trace.hs index db0bdf217cc..87cf551ef86 100644 --- a/plutus-tx/src/PlutusTx/Trace.hs +++ b/plutus-tx/src/PlutusTx/Trace.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} - module PlutusTx.Trace ( trace , traceError diff --git a/plutus-tx/src/PlutusTx/Traversable.hs b/plutus-tx/src/PlutusTx/Traversable.hs index 0586c7f3a01..ee8bafc6d42 100644 --- a/plutus-tx/src/PlutusTx/Traversable.hs +++ b/plutus-tx/src/PlutusTx/Traversable.hs @@ -1,6 +1,5 @@ -- editorconfig-checker-disable-file {-# LANGUAGE TupleSections #-} -{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} module PlutusTx.Traversable (Traversable (..), sequenceA, mapM, sequence, for, fmapDefault, foldMapDefault) where diff --git a/plutus-tx/test/Eq/Golden/PhantomADT.golden.th b/plutus-tx/test/Eq/Golden/PhantomADT.golden.th new file mode 100644 index 00000000000..3d9651941c2 --- /dev/null +++ b/plutus-tx/test/Eq/Golden/PhantomADT.golden.th @@ -0,0 +1,3 @@ +instance PlutusTx.Eq.Class.Eq (Eq.Spec.PhantomADT e_0) + where {(PlutusTx.Eq.Class.==) (Eq.Spec.PhantomADT l1l_1) (Eq.Spec.PhantomADT r1r_2) = l1l_1 PlutusTx.Eq.Class.== r1r_2; + {-# INLINABLE (PlutusTx.Eq.Class.==) #-}} \ No newline at end of file diff --git a/plutus-tx/test/Eq/Golden/SomeLargeADT.golden.th b/plutus-tx/test/Eq/Golden/SomeLargeADT.golden.th new file mode 100644 index 00000000000..f06cdd9768d --- /dev/null +++ b/plutus-tx/test/Eq/Golden/SomeLargeADT.golden.th @@ -0,0 +1,32 @@ +instance (PlutusTx.Eq.Class.Eq a_0, + PlutusTx.Eq.Class.Eq b_1, + PlutusTx.Eq.Class.Eq c_2, + PlutusTx.Eq.Class.Eq d_3, + PlutusTx.Eq.Class.Eq e_4) => PlutusTx.Eq.Class.Eq (Eq.Spec.SomeLargeADT a_0 + b_1 + c_2 + d_3 + e_4) + where {(PlutusTx.Eq.Class.==) (Eq.Spec.SomeLargeADT1 l1l_5 + l2l_6 + l3l_7 + l4l_8 + l5l_9 + l6l_10) (Eq.Spec.SomeLargeADT1 r1r_11 + r2r_12 + r3r_13 + r4r_14 + r5r_15 + r6r_16) = (l1l_5 PlutusTx.Eq.Class.== r1r_11) PlutusTx.Bool.&& ((l2l_6 PlutusTx.Eq.Class.== r2r_12) PlutusTx.Bool.&& ((l3l_7 PlutusTx.Eq.Class.== r3r_13) PlutusTx.Bool.&& ((l4l_8 PlutusTx.Eq.Class.== r4r_14) PlutusTx.Bool.&& ((l5l_9 PlutusTx.Eq.Class.== r5r_15) PlutusTx.Bool.&& (l6l_10 PlutusTx.Eq.Class.== r6r_16))))) + (PlutusTx.Eq.Class.==) (Eq.Spec.SomeLargeADT2) (Eq.Spec.SomeLargeADT2) = GHC.Types.True + (PlutusTx.Eq.Class.==) (Eq.Spec.SomeLargeADT3 l1l_17 + l2l_18 + l3l_19 + l4l_20 + l5l_21) (Eq.Spec.SomeLargeADT3 r1r_22 + r2r_23 + r3r_24 + r4r_25 + r5r_26) = (l1l_17 PlutusTx.Eq.Class.== r1r_22) PlutusTx.Bool.&& ((l2l_18 PlutusTx.Eq.Class.== r2r_23) PlutusTx.Bool.&& ((l3l_19 PlutusTx.Eq.Class.== r3r_24) PlutusTx.Bool.&& ((l4l_20 PlutusTx.Eq.Class.== r4r_25) PlutusTx.Bool.&& (l5l_21 PlutusTx.Eq.Class.== r5r_26)))) + (PlutusTx.Eq.Class.==) _ _ = GHC.Types.False; + {-# INLINABLE (PlutusTx.Eq.Class.==) #-}} \ No newline at end of file diff --git a/plutus-tx/test/Eq/Spec.hs b/plutus-tx/test/Eq/Spec.hs new file mode 100644 index 00000000000..64643f27690 --- /dev/null +++ b/plutus-tx/test/Eq/Spec.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE EmptyDataDeriving #-} + +module Eq.Spec (eqTests) where + +import Control.Exception +import PlutusTx.Bool qualified as Tx +import PlutusTx.Builtins as Tx +import PlutusTx.Eq as Tx +import PlutusTx.Test.Golden +import Test.Tasty.Extras + +import Data.Either + +import Test.Tasty +import Test.Tasty.HUnit +import Prelude hiding (Eq (..), error) +import Prelude qualified as HS (Eq (..)) + +data SomeVoid + deriving stock (HS.Eq) +deriveEq ''SomeVoid + +data SomeLargeADT a b c d e + = SomeLargeADT1 Integer a Tx.Bool b c d + | SomeLargeADT2 + | SomeLargeADT3 {f1 :: e, f2 :: e, _f3 :: e, _f4 :: e, _f5 :: e} + deriving stock (HS.Eq) +deriveEq ''SomeLargeADT + +newtype PhantomADT e = PhantomADT () + deriving stock (HS.Eq) +deriveEq ''PhantomADT + +unitTests :: TestTree +unitTests = + let v1 :: SomeLargeADT () BuiltinString () () () = SomeLargeADT1 1 () Tx.True "foobar" () () + v2 :: SomeLargeADT () () () () () = SomeLargeADT2 + v3 :: SomeLargeADT () () () () Integer = SomeLargeADT3 1 2 3 4 5 + v3Error1 = v3 {f1 = 0, f2 = error ()} -- mismatch comes first, error comes later + v3Error2 = v3 {f1 = error (), f2 = 0} -- error comes first, mismatch later + v4 :: SomeVoid = undefined + in testGroup + "PlutusTx.Eq unit tests" + [ testCase "reflexive1" $ (v1 Tx.== v1) @?= (v1 HS.== v1) + , testCase "reflexive2" $ (v2 Tx.== v2) @?= (v2 HS.== v2) + , testCase "reflexive3" $ (v3 Tx.== v3) @?= (v3 HS.== v3) + , -- polymorphic phantom types, no type annotation is needed + testCase "phantom" $ (PhantomADT () Tx.== PhantomADT ()) @?= (PhantomADT () HS.== PhantomADT ()) + , testCase "shortcircuit" $ (v3 Tx.== v3Error1) @?= (v3 Tx.== v3Error1) -- should not throw an error + , testCase "throws" $ try @SomeException (evaluate $ v3 Tx.== v3Error2) >>= assertBool "did not throw error" . isLeft -- should throw erro + , testCase "void" $ (v4 Tx.== v4) @?= (v4 HS.== v4) + ] + +goldenTests :: TestTree +goldenTests = + runTestNested + ["test", "Eq", "Golden"] + [ $(goldenCodeGen "SomeLargeADT" (deriveEq ''SomeLargeADT)) + , $(goldenCodeGen "PhantomADT" (deriveEq ''PhantomADT)) + ] + +eqTests :: TestTree +eqTests = + testGroup + "PlutusTx.Eq tests" + [unitTests, goldenTests] diff --git a/plutus-tx/test/Ord/Golden/PhantomADT.golden.th b/plutus-tx/test/Ord/Golden/PhantomADT.golden.th new file mode 100644 index 00000000000..2e392c1e376 --- /dev/null +++ b/plutus-tx/test/Ord/Golden/PhantomADT.golden.th @@ -0,0 +1,3 @@ +instance PlutusTx.Ord.Class.Ord (Ord.Spec.PhantomADT e_0) + where {PlutusTx.Ord.Class.compare (Ord.Spec.PhantomADT l1l_1) (Ord.Spec.PhantomADT r1r_2) = l1l_1 `PlutusTx.Ord.Class.compare` r1r_2; + {-# INLINABLE PlutusTx.Ord.Class.compare #-}} \ No newline at end of file diff --git a/plutus-tx/test/Ord/Golden/SomeProduct.golden.th b/plutus-tx/test/Ord/Golden/SomeProduct.golden.th new file mode 100644 index 00000000000..868b92732eb --- /dev/null +++ b/plutus-tx/test/Ord/Golden/SomeProduct.golden.th @@ -0,0 +1,9 @@ +instance PlutusTx.Ord.Class.Ord Ord.Spec.SomeProduct + where {PlutusTx.Ord.Class.compare (Ord.Spec.SomeProduct l1l_0 + l2l_1 + l3l_2 + l4l_3) (Ord.Spec.SomeProduct r1r_4 + r2r_5 + r3r_6 + r4r_7) = (l1l_0 `PlutusTx.Ord.Class.compare` r1r_4) GHC.Base.<> ((l2l_1 `PlutusTx.Ord.Class.compare` r2r_5) GHC.Base.<> ((l3l_2 `PlutusTx.Ord.Class.compare` r3r_6) GHC.Base.<> (l4l_3 `PlutusTx.Ord.Class.compare` r4r_7))); + {-# INLINABLE PlutusTx.Ord.Class.compare #-}} \ No newline at end of file diff --git a/plutus-tx/test/Ord/Golden/SomeVeryLargeEnum.golden.th b/plutus-tx/test/Ord/Golden/SomeVeryLargeEnum.golden.th new file mode 100644 index 00000000000..d48e92f8b26 --- /dev/null +++ b/plutus-tx/test/Ord/Golden/SomeVeryLargeEnum.golden.th @@ -0,0 +1,102 @@ +instance PlutusTx.Ord.Class.Ord Ord.Spec.SomeVeryLargeEnum + where {PlutusTx.Ord.Class.compare (Ord.Spec.E1) (Ord.Spec.E1) = GHC.Types.EQ + PlutusTx.Ord.Class.compare (Ord.Spec.E2) (Ord.Spec.E2) = GHC.Types.EQ + PlutusTx.Ord.Class.compare (Ord.Spec.E3) (Ord.Spec.E3) = GHC.Types.EQ + PlutusTx.Ord.Class.compare (Ord.Spec.E4) (Ord.Spec.E4) = GHC.Types.EQ + PlutusTx.Ord.Class.compare (Ord.Spec.E5) (Ord.Spec.E5) = GHC.Types.EQ + PlutusTx.Ord.Class.compare (Ord.Spec.E6) (Ord.Spec.E6) = GHC.Types.EQ + PlutusTx.Ord.Class.compare (Ord.Spec.E7) (Ord.Spec.E7) = GHC.Types.EQ + PlutusTx.Ord.Class.compare (Ord.Spec.E8) (Ord.Spec.E8) = GHC.Types.EQ + PlutusTx.Ord.Class.compare (Ord.Spec.E9) (Ord.Spec.E9) = GHC.Types.EQ + PlutusTx.Ord.Class.compare (Ord.Spec.E10) (Ord.Spec.E10) = GHC.Types.EQ + PlutusTx.Ord.Class.compare (Ord.Spec.E1 {}) (Ord.Spec.E2 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E1 {}) (Ord.Spec.E3 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E1 {}) (Ord.Spec.E4 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E1 {}) (Ord.Spec.E5 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E1 {}) (Ord.Spec.E6 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E1 {}) (Ord.Spec.E7 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E1 {}) (Ord.Spec.E8 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E1 {}) (Ord.Spec.E9 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E1 {}) (Ord.Spec.E10 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E2 {}) (Ord.Spec.E3 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E2 {}) (Ord.Spec.E4 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E2 {}) (Ord.Spec.E5 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E2 {}) (Ord.Spec.E6 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E2 {}) (Ord.Spec.E7 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E2 {}) (Ord.Spec.E8 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E2 {}) (Ord.Spec.E9 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E2 {}) (Ord.Spec.E10 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E2 {}) (Ord.Spec.E1 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E3 {}) (Ord.Spec.E4 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E3 {}) (Ord.Spec.E5 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E3 {}) (Ord.Spec.E6 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E3 {}) (Ord.Spec.E7 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E3 {}) (Ord.Spec.E8 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E3 {}) (Ord.Spec.E9 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E3 {}) (Ord.Spec.E10 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E3 {}) (Ord.Spec.E2 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E3 {}) (Ord.Spec.E1 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E4 {}) (Ord.Spec.E5 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E4 {}) (Ord.Spec.E6 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E4 {}) (Ord.Spec.E7 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E4 {}) (Ord.Spec.E8 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E4 {}) (Ord.Spec.E9 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E4 {}) (Ord.Spec.E10 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E4 {}) (Ord.Spec.E3 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E4 {}) (Ord.Spec.E2 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E4 {}) (Ord.Spec.E1 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E5 {}) (Ord.Spec.E6 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E5 {}) (Ord.Spec.E7 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E5 {}) (Ord.Spec.E8 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E5 {}) (Ord.Spec.E9 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E5 {}) (Ord.Spec.E10 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E5 {}) (Ord.Spec.E4 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E5 {}) (Ord.Spec.E3 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E5 {}) (Ord.Spec.E2 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E5 {}) (Ord.Spec.E1 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E6 {}) (Ord.Spec.E7 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E6 {}) (Ord.Spec.E8 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E6 {}) (Ord.Spec.E9 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E6 {}) (Ord.Spec.E10 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E6 {}) (Ord.Spec.E5 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E6 {}) (Ord.Spec.E4 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E6 {}) (Ord.Spec.E3 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E6 {}) (Ord.Spec.E2 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E6 {}) (Ord.Spec.E1 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E7 {}) (Ord.Spec.E8 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E7 {}) (Ord.Spec.E9 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E7 {}) (Ord.Spec.E10 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E7 {}) (Ord.Spec.E6 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E7 {}) (Ord.Spec.E5 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E7 {}) (Ord.Spec.E4 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E7 {}) (Ord.Spec.E3 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E7 {}) (Ord.Spec.E2 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E7 {}) (Ord.Spec.E1 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E8 {}) (Ord.Spec.E9 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E8 {}) (Ord.Spec.E10 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E8 {}) (Ord.Spec.E7 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E8 {}) (Ord.Spec.E6 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E8 {}) (Ord.Spec.E5 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E8 {}) (Ord.Spec.E4 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E8 {}) (Ord.Spec.E3 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E8 {}) (Ord.Spec.E2 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E8 {}) (Ord.Spec.E1 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E9 {}) (Ord.Spec.E10 {}) = GHC.Types.LT + PlutusTx.Ord.Class.compare (Ord.Spec.E9 {}) (Ord.Spec.E8 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E9 {}) (Ord.Spec.E7 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E9 {}) (Ord.Spec.E6 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E9 {}) (Ord.Spec.E5 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E9 {}) (Ord.Spec.E4 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E9 {}) (Ord.Spec.E3 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E9 {}) (Ord.Spec.E2 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E9 {}) (Ord.Spec.E1 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E10 {}) (Ord.Spec.E9 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E10 {}) (Ord.Spec.E8 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E10 {}) (Ord.Spec.E7 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E10 {}) (Ord.Spec.E6 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E10 {}) (Ord.Spec.E5 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E10 {}) (Ord.Spec.E4 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E10 {}) (Ord.Spec.E3 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E10 {}) (Ord.Spec.E2 {}) = GHC.Types.GT + PlutusTx.Ord.Class.compare (Ord.Spec.E10 {}) (Ord.Spec.E1 {}) = GHC.Types.GT; + {-# INLINABLE PlutusTx.Ord.Class.compare #-}} \ No newline at end of file diff --git a/plutus-tx/test/Ord/Spec.hs b/plutus-tx/test/Ord/Spec.hs new file mode 100644 index 00000000000..85e2cbd0461 --- /dev/null +++ b/plutus-tx/test/Ord/Spec.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE EmptyDataDeriving #-} + +module Ord.Spec (ordTests) where + +import PlutusTx.Builtins +import PlutusTx.Enum as Tx +import PlutusTx.Eq +import PlutusTx.Ord as Tx +import PlutusTx.Test.Golden +import Test.Tasty +import Test.Tasty.Extras +import Test.Tasty.HUnit +import Prelude as HS + +data SomeVeryLargeEnum + = E1 + | E2 + | E3 + | E4 + | E5 + | E6 + | E7 + | E8 + | E9 + | E10 + deriving stock (HS.Eq, HS.Show, HS.Bounded) +deriveEnum ''SomeVeryLargeEnum +deriveEq ''SomeVeryLargeEnum +deriveOrd ''SomeVeryLargeEnum + +data SomeProduct = SomeProduct Integer BuiltinByteString Bool (Either () ()) +deriveEq ''SomeProduct +deriveOrd ''SomeProduct + +newtype PhantomADT e = PhantomADT () + deriving stock (HS.Eq, HS.Show) +deriveEq ''PhantomADT +deriveOrd ''PhantomADT + +data SomeVoid + deriving stock (HS.Eq, HS.Ord) +deriveEq ''SomeVoid +deriveOrd ''SomeVoid + +unitTests :: TestTree +unitTests = + testGroup "PlutusTx.Ord unit tests" $ + let l = Tx.enumFromTo @SomeVeryLargeEnum HS.minBound HS.maxBound + l' = HS.tail l + in [ testCase "enum series is lt" $ zipWith Tx.compare l l' @?= (take (length l') [LT, LT ..]) + , testCase "product1" $ SomeProduct 1 (encodeUtf8 "a") True (Right ()) Tx.> SomeProduct 0 (encodeUtf8 "a") True (Right ()) @? "product1 failed" + , testCase "product2" $ SomeProduct 1 (encodeUtf8 "a") True (Right ()) Tx.< SomeProduct 1 (encodeUtf8 "b") True (Left ()) @? "product2 failed" + , testCase "product3" $ SomeProduct 1 (encodeUtf8 "a") True (Right ()) Tx.> SomeProduct 1 (encodeUtf8 "a") False (Left ()) @? "product3 failed" + , testCase "product3" $ SomeProduct 1 (encodeUtf8 "a") True (Left ()) Tx.< SomeProduct 1 (encodeUtf8 "a") True (Right ()) @? "product4 failed" + , testCase "void" $ (undefined :: SomeVoid) `Tx.compare` undefined @=? (undefined :: SomeVoid) `HS.compare` undefined + ] + +goldenTests :: TestTree +goldenTests = + runTestNested + ["test", "Ord", "Golden"] + [ $(goldenCodeGen "SomeVeryLargeEnum" (deriveOrd ''SomeVeryLargeEnum)) + , $(goldenCodeGen "SomeProduct" (deriveOrd ''SomeProduct)) + , $(goldenCodeGen "PhantomADT" (deriveOrd ''PhantomADT)) + ] + +ordTests :: TestTree +ordTests = + testGroup + "PlutusTx.Ord tests" + [unitTests, goldenTests] diff --git a/plutus-tx/test/Spec.hs b/plutus-tx/test/Spec.hs index 7b7571fcda8..7cc03b6f3cc 100644 --- a/plutus-tx/test/Spec.hs +++ b/plutus-tx/test/Spec.hs @@ -15,10 +15,12 @@ import Data.ByteString qualified as BS import Data.Either (isLeft) import Data.Word (Word64) import Enum.Spec (enumTests) +import Eq.Spec (eqTests) import Hedgehog (MonadGen, Property, PropertyT, annotateShow, assert, forAll, property, tripping) import Hedgehog.Gen qualified as Gen import Hedgehog.Range qualified as Range import List.Spec (listTests) +import Ord.Spec (ordTests) import PlutusCore.Data (Data (B, Constr, I, List, Map)) import PlutusTx.Numeric (negate) import PlutusTx.Prelude (dropByteString, one, takeByteString) @@ -45,7 +47,9 @@ tests = , enumTests , listTests , boolTests + , eqTests , lawsTests + , ordTests , Show.Spec.propertyTests , Show.Spec.goldenTests , Blueprint.Definition.Spec.tests