diff --git a/Plutarch/Pair.hs b/Plutarch/Pair.hs index c66c27f20..6505d0a97 100644 --- a/Plutarch/Pair.hs +++ b/Plutarch/Pair.hs @@ -1,15 +1,15 @@ module Plutarch.Pair (PPair (..)) where import GHC.Generics (Generic) -import Plutarch.Bool (PEq) +import Plutarch.Bool (PEq ((#==)), POrd, PPartialOrd ((#<), (#<=)), pif) import Plutarch.Internal (PType, S, Term) -import Plutarch.Internal.PlutusType (DPTStrat, DerivePlutusType, PlutusType) +import Plutarch.Internal.PlutusType (DPTStrat, DerivePlutusType, PlutusType, pmatch) import Plutarch.Internal.ScottEncoding (PlutusTypeScott) import Plutarch.Show (PShow) +import Plutarch.TermCont (tcont, unTermCont) {- | Plutus encoding of Pairs. - Note: This is represented differently than 'BuiltinPair'. It is scott-encoded. -} data PPair (a :: PType) (b :: PType) (s :: S) @@ -18,3 +18,24 @@ data PPair (a :: PType) (b :: PType) (s :: S) deriving anyclass (PlutusType, PEq, PShow) instance DerivePlutusType (PPair a b) where type DPTStrat _ = PlutusTypeScott + +instance (PPartialOrd a, PPartialOrd b) => PPartialOrd (PPair a b) where + a #<= b = unTermCont $ do + PPair a1 a2 <- tcont $ pmatch a + PPair b1 b2 <- tcont $ pmatch b + pure $ + pif + (a1 #== b1) + (a2 #<= b2) + (a1 #<= b1) + + a #< b = unTermCont $ do + PPair a1 a2 <- tcont $ pmatch a + PPair b1 b2 <- tcont $ pmatch b + pure $ + pif + (a1 #== b1) + (a2 #< b2) + (a1 #< b1) + +instance (POrd a, POrd b) => POrd (PPair a b)