Skip to content

Commit fddec85

Browse files
bezirgbezirg
committed
Implements PlutusTx.deriveOrd
Add deriveOrd tests Make deriving Ord phantom types work Fixes
1 parent f6a08c0 commit fddec85

File tree

12 files changed

+392
-136
lines changed

12 files changed

+392
-136
lines changed

‎plutus-tx/changelog.d/20251203_141812_bezirg_derive_ord.md‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
### Added
2+
3+
- A `deriveOrd` command to derive PlutusTx.Ord instances for datatypes/newtypes, similar to Haskell's
4+
`deriving stock Ord`

‎plutus-tx/plutus-tx.cabal‎

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -105,6 +105,7 @@ library
105105
PlutusTx.Optimize.Inline
106106
PlutusTx.Optimize.SpaceTime
107107
PlutusTx.Ord
108+
PlutusTx.Ord.Class
108109
PlutusTx.Plugin.Utils
109110
PlutusTx.Prelude
110111
PlutusTx.Ratio
@@ -127,6 +128,7 @@ library
127128
PlutusTx.Lift.TestInstances
128129
PlutusTx.Lift.TH
129130
PlutusTx.Lift.THUtils
131+
PlutusTx.Ord.TH
130132

131133
build-depends:
132134
, aeson >=2.2
@@ -214,6 +216,7 @@ test-suite plutus-tx-test
214216
Bool.Spec
215217
Enum.Spec
216218
Eq.Spec
219+
Ord.Spec
217220
List.Spec
218221
Rational.Laws
219222
Rational.Laws.Additive

‎plutus-tx/src/PlutusTx/Monoid.hs‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ import PlutusTx.Builtins qualified as Builtins
99
import PlutusTx.List
1010
import PlutusTx.Maybe
1111
import PlutusTx.Semigroup
12+
import PlutusTx.Ord
1213

1314
{- HLINT ignore -}
1415

@@ -66,6 +67,10 @@ instance Monoid (First a) where
6667
{-# INLINEABLE mempty #-}
6768
mempty = First Nothing
6869

70+
instance Monoid Ordering where
71+
{-# INLINEABLE mempty #-}
72+
mempty = EQ
73+
6974
class Monoid a => Group a where
7075
inv :: a -> a
7176

‎plutus-tx/src/PlutusTx/Ord.hs‎

Lines changed: 42 additions & 122 deletions
Original file line numberDiff line numberDiff line change
@@ -1,122 +1,42 @@
1-
-- editorconfig-checker-disable-file
2-
3-
module PlutusTx.Ord (Ord (..), Ordering (..)) where
4-
5-
{-
6-
We export off-chain Haskell's Ordering type as on-chain Plutus's Ordering type since they are the same.
7-
-}
8-
9-
import PlutusTx.Bool (Bool (..))
10-
import PlutusTx.Builtins qualified as Builtins
11-
import PlutusTx.Either (Either (..))
12-
import PlutusTx.Eq
13-
import Prelude (Maybe (..), Ordering (..))
14-
15-
{- HLINT ignore -}
16-
17-
infix 4 <, <=, >, >=
18-
19-
-- Copied from the GHC definition
20-
21-
{-| The 'Ord' class is used for totally ordered datatypes.
22-
23-
Minimal complete definition: either 'compare' or '<='.
24-
Using 'compare' can be more efficient for complex types. -}
25-
class Eq a => Ord a where
26-
compare :: a -> a -> Ordering
27-
(<), (<=), (>), (>=) :: a -> a -> Bool
28-
max, min :: a -> a -> a
29-
30-
{-# INLINEABLE compare #-}
31-
compare x y =
32-
if x == y
33-
then EQ
34-
-- NB: must be '<=' not '<' to validate the
35-
-- above claim about the minimal things that
36-
-- can be defined for an instance of Ord:
37-
else
38-
if x <= y
39-
then LT
40-
else GT
41-
42-
{-# INLINEABLE (<) #-}
43-
x < y = case compare x y of LT -> True; _ -> False
44-
{-# INLINEABLE (<=) #-}
45-
x <= y = case compare x y of GT -> False; _ -> True
46-
{-# INLINEABLE (>) #-}
47-
x > y = case compare x y of GT -> True; _ -> False
48-
{-# INLINEABLE (>=) #-}
49-
x >= y = case compare x y of LT -> False; _ -> True
50-
51-
-- These two default methods use '<=' rather than 'compare'
52-
-- because the latter is often more expensive
53-
{-# INLINEABLE max #-}
54-
max x y = if x <= y then y else x
55-
{-# INLINEABLE min #-}
56-
min x y = if x <= y then x else y
57-
{-# MINIMAL compare | (<=) #-}
58-
59-
instance Ord Builtins.Integer where
60-
{-# INLINEABLE (<) #-}
61-
(<) = Builtins.lessThanInteger
62-
{-# INLINEABLE (<=) #-}
63-
(<=) = Builtins.lessThanEqualsInteger
64-
{-# INLINEABLE (>) #-}
65-
(>) = Builtins.greaterThanInteger
66-
{-# INLINEABLE (>=) #-}
67-
(>=) = Builtins.greaterThanEqualsInteger
68-
69-
instance Ord Builtins.BuiltinByteString where
70-
{-# INLINEABLE (<) #-}
71-
(<) = Builtins.lessThanByteString
72-
{-# INLINEABLE (<=) #-}
73-
(<=) = Builtins.lessThanEqualsByteString
74-
{-# INLINEABLE (>) #-}
75-
(>) = Builtins.greaterThanByteString
76-
{-# INLINEABLE (>=) #-}
77-
(>=) = Builtins.greaterThanEqualsByteString
78-
79-
instance Ord a => Ord [a] where
80-
{-# INLINEABLE compare #-}
81-
compare [] [] = EQ
82-
compare [] (_ : _) = LT
83-
compare (_ : _) [] = GT
84-
compare (x : xs) (y : ys) =
85-
case compare x y of
86-
EQ -> compare xs ys
87-
c -> c
88-
89-
instance Ord Bool where
90-
{-# INLINEABLE compare #-}
91-
compare b1 b2 = case b1 of
92-
False -> case b2 of
93-
False -> EQ
94-
True -> LT
95-
True -> case b2 of
96-
False -> GT
97-
True -> EQ
98-
99-
instance Ord a => Ord (Maybe a) where
100-
{-# INLINEABLE compare #-}
101-
compare (Just a1) (Just a2) = compare a1 a2
102-
compare Nothing (Just _) = LT
103-
compare (Just _) Nothing = GT
104-
compare Nothing Nothing = EQ
105-
106-
instance (Ord a, Ord b) => Ord (Either a b) where
107-
{-# INLINEABLE compare #-}
108-
compare (Left a1) (Left a2) = compare a1 a2
109-
compare (Left _) (Right _) = LT
110-
compare (Right _) (Left _) = GT
111-
compare (Right b1) (Right b2) = compare b1 b2
112-
113-
instance Ord () where
114-
{-# INLINEABLE compare #-}
115-
compare _ _ = EQ
116-
117-
instance (Ord a, Ord b) => Ord (a, b) where
118-
{-# INLINEABLE compare #-}
119-
compare (a, b) (a', b') =
120-
case compare a a' of
121-
EQ -> compare b b'
122-
c -> c
1+
{-# LANGUAGE TemplateHaskell #-}
2+
{-# OPTIONS_GHC -Wno-orphans #-}
3+
module PlutusTx.Ord (Ord (..), Ordering (..), deriveOrd) where
4+
5+
import PlutusTx.Bool
6+
import PlutusTx.Either
7+
import PlutusTx.Ord.Class
8+
import PlutusTx.Ord.TH
9+
import Prelude (Maybe (..))
10+
11+
deriveOrd ''[]
12+
deriveOrd ''Bool
13+
deriveOrd ''Maybe
14+
deriveOrd ''Either
15+
deriveOrd ''Ordering
16+
deriveOrd ''()
17+
deriveOrd ''(,)
18+
deriveOrd ''(,,)
19+
deriveOrd ''(,,,)
20+
deriveOrd ''(,,,,)
21+
deriveOrd ''(,,,,,)
22+
deriveOrd ''(,,,,,,)
23+
deriveOrd ''(,,,,,,,)
24+
deriveOrd ''(,,,,,,,,)
25+
deriveOrd ''(,,,,,,,,,)
26+
deriveOrd ''(,,,,,,,,,,)
27+
deriveOrd ''(,,,,,,,,,,,)
28+
deriveOrd ''(,,,,,,,,,,,,)
29+
deriveOrd ''(,,,,,,,,,,,,,)
30+
deriveOrd ''(,,,,,,,,,,,,,,)
31+
deriveOrd ''(,,,,,,,,,,,,,,,)
32+
deriveOrd ''(,,,,,,,,,,,,,,,,)
33+
deriveOrd ''(,,,,,,,,,,,,,,,,,)
34+
deriveOrd ''(,,,,,,,,,,,,,,,,,,)
35+
deriveOrd ''(,,,,,,,,,,,,,,,,,,,)
36+
deriveOrd ''(,,,,,,,,,,,,,,,,,,,,)
37+
deriveOrd ''(,,,,,,,,,,,,,,,,,,,,,)
38+
deriveOrd ''(,,,,,,,,,,,,,,,,,,,,,,)
39+
deriveOrd ''(,,,,,,,,,,,,,,,,,,,,,,,)
40+
deriveOrd ''(,,,,,,,,,,,,,,,,,,,,,,,,)
41+
deriveOrd ''(,,,,,,,,,,,,,,,,,,,,,,,,,)
42+
deriveOrd ''(,,,,,,,,,,,,,,,,,,,,,,,,,,)

‎plutus-tx/src/PlutusTx/Ord/Class.hs‎

Lines changed: 78 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,78 @@
1+
-- editorconfig-checker-disable-file
2+
{-# OPTIONS_GHC -fno-warn-orphans #-}
3+
4+
module PlutusTx.Ord.Class (Ord (..), Ordering (..)) where
5+
6+
{-
7+
We export off-chain Haskell's Ordering type as on-chain Plutus's Ordering type since they are the same.
8+
-}
9+
10+
import PlutusTx.Bool (Bool (..))
11+
import PlutusTx.Builtins qualified as Builtins
12+
import PlutusTx.Either (Either (..))
13+
import PlutusTx.Eq
14+
import Prelude (Ordering (..))
15+
16+
{- HLINT ignore -}
17+
18+
infix 4 <, <=, >, >=
19+
20+
-- Copied from the GHC definition
21+
22+
{-| The 'Ord' class is used for totally ordered datatypes.
23+
24+
Minimal complete definition: either 'compare' or '<='.
25+
Using 'compare' can be more efficient for complex types. -}
26+
class Eq a => Ord a where
27+
compare :: a -> a -> Ordering
28+
(<), (<=), (>), (>=) :: a -> a -> Bool
29+
max, min :: a -> a -> a
30+
31+
{-# INLINEABLE compare #-}
32+
compare x y =
33+
if x == y
34+
then EQ
35+
-- NB: must be '<=' not '<' to validate the
36+
-- above claim about the minimal things that
37+
-- can be defined for an instance of Ord:
38+
else
39+
if x <= y
40+
then LT
41+
else GT
42+
43+
{-# INLINEABLE (<) #-}
44+
x < y = case compare x y of LT -> True; _ -> False
45+
{-# INLINEABLE (<=) #-}
46+
x <= y = case compare x y of GT -> False; _ -> True
47+
{-# INLINEABLE (>) #-}
48+
x > y = case compare x y of GT -> True; _ -> False
49+
{-# INLINEABLE (>=) #-}
50+
x >= y = case compare x y of LT -> False; _ -> True
51+
52+
-- These two default methods use '<=' rather than 'compare'
53+
-- because the latter is often more expensive
54+
{-# INLINEABLE max #-}
55+
max x y = if x <= y then y else x
56+
{-# INLINEABLE min #-}
57+
min x y = if x <= y then x else y
58+
{-# MINIMAL compare | (<=) #-}
59+
60+
instance Ord Builtins.Integer where
61+
{-# INLINEABLE (<) #-}
62+
(<) = Builtins.lessThanInteger
63+
{-# INLINEABLE (<=) #-}
64+
(<=) = Builtins.lessThanEqualsInteger
65+
{-# INLINEABLE (>) #-}
66+
(>) = Builtins.greaterThanInteger
67+
{-# INLINEABLE (>=) #-}
68+
(>=) = Builtins.greaterThanEqualsInteger
69+
70+
instance Ord Builtins.BuiltinByteString where
71+
{-# INLINEABLE (<) #-}
72+
(<) = Builtins.lessThanByteString
73+
{-# INLINEABLE (<=) #-}
74+
(<=) = Builtins.lessThanEqualsByteString
75+
{-# INLINEABLE (>) #-}
76+
(>) = Builtins.greaterThanByteString
77+
{-# INLINEABLE (>=) #-}
78+
(>=) = Builtins.greaterThanEqualsByteString

‎plutus-tx/src/PlutusTx/Ord/TH.hs‎

Lines changed: 77 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,77 @@
1+
{-# LANGUAGE TemplateHaskellQuotes #-}
2+
{-# LANGUAGE LambdaCase #-}
3+
4+
module PlutusTx.Ord.TH (deriveOrd) where
5+
6+
import PlutusTx.Ord.Class
7+
import Prelude hiding (Ord(..), Ordering(..), Eq((==)), (&&), Bool (True))
8+
import Data.Foldable
9+
import Data.Traversable
10+
import Language.Haskell.TH as TH
11+
import Language.Haskell.TH.Datatype as TH
12+
import Data.Deriving.Internal (varTToName)
13+
14+
{-| derive a PlutusTx.Ord instance for a datatype/newtype, similar to Haskell's `deriving stock Ord`.
15+
16+
One shortcoming compared to Haskell's deriving is that you cannot `PlutusTx.deriveOrd` for polymorphic phantom types. -}
17+
deriveOrd :: TH.Name -> TH.Q [TH.Dec]
18+
deriveOrd name = do
19+
TH.DatatypeInfo
20+
{ TH.datatypeName = tyConName
21+
, TH.datatypeInstTypes = tyVars0
22+
, TH.datatypeCons = cons
23+
} <-
24+
TH.reifyDatatype name
25+
26+
roles <- reifyRoles name
27+
28+
let
29+
-- The purpose of the `TH.VarT . varTToName` roundtrip is to remove the kind
30+
-- signatures attached to the type variables in `tyVars0`. Otherwise, the
31+
-- `KindSignatures` extension would be needed whenever `length tyVars0 > 0`.
32+
tyVars = TH.VarT . varTToName <$> tyVars0
33+
34+
nonPhantomTyVars = VarT . varTToName . snd <$> filter ((/= PhantomR) . fst) (zip roles tyVars0)
35+
36+
instanceCxt :: TH.Cxt
37+
instanceCxt = TH.AppT (TH.ConT ''Ord) <$> nonPhantomTyVars
38+
39+
instanceType :: TH.Type
40+
instanceType = TH.AppT (TH.ConT ''Ord) $ foldl' TH.AppT (TH.ConT tyConName) tyVars
41+
42+
pure <$> instanceD (pure instanceCxt) (pure instanceType)
43+
[funD 'compare (fmap deriveOrdSame cons ++ maybeDeriveOrdDifferent cons)
44+
, TH.pragInlD 'compare TH.Inlinable TH.FunLike TH.AllPhases
45+
]
46+
47+
deriveOrdSame :: ConstructorInfo -> Q Clause
48+
deriveOrdSame (ConstructorInfo {constructorName = name, constructorFields = fields }) = do
49+
argsL <- for [1 .. length fields] $ \i -> TH.newName ("l" <> show i <> "l")
50+
argsR <- for [1 .. length fields] $ \i -> TH.newName ("r" <> show i <> "r")
51+
pure (TH.Clause [ConP name [] (fmap VarP argsL), ConP name [] (fmap VarP argsR)]
52+
(NormalB $
53+
case fields of
54+
[] -> TH.ConE 'EQ
55+
_ -> foldr1 (\ e acc -> TH.InfixE (pure e) (TH.VarE '(<>)) (pure acc))
56+
$ zipWith (\ argL argR ->
57+
TH.InfixE (pure $ TH.VarE argL) (TH.VarE 'compare) (pure $ TH.VarE argR)
58+
) argsL argsR
59+
)
60+
[]
61+
)
62+
63+
maybeDeriveOrdDifferent :: [ConstructorInfo] -> [Q Clause]
64+
maybeDeriveOrdDifferent = \case
65+
[] -> [clause [wildP, wildP] (normalB $ conE 'EQ) []] -- if void datatype aka 0 constructors, generate an EQ clause
66+
(x:xs) -> mkLTGT [] x xs -- if >1 constructors, generate LT,GT sequences
67+
68+
-- OPTIMIZE: can be a small optimization here so that if lt==[] or gt==[], then use wildcard instead of generating multiple clauses
69+
mkLTGT :: [ConstructorInfo] -> ConstructorInfo -> [ConstructorInfo] -> [Q Clause]
70+
mkLTGT gt needle@(ConstructorInfo {constructorName = name}) lt =
71+
case lt of
72+
[] -> mkClause 'GT <$> gt -- this covers also the case of a single constructor
73+
(hlt:tlt) -> (mkClause 'LT <$> lt)
74+
++ (mkClause 'GT <$> gt)
75+
++ mkLTGT (needle:gt) hlt tlt
76+
where
77+
mkClause val r = clause [recP name [], recP (constructorName r) []] (normalB $ conE val) []

‎plutus-tx/src/PlutusTx/These.hs‎

Lines changed: 1 addition & 14 deletions
Original file line numberDiff line numberDiff line change
@@ -33,6 +33,7 @@ data These a b = This a | That b | These a b
3333
deriving anyclass (HasBlueprintDefinition)
3434

3535
deriveEq ''These
36+
deriveOrd ''These
3637
deriveShow ''These
3738
makeLift ''These
3839
makeIsDataSchemaIndexed ''These [('This, 0), ('That, 1), ('These, 2)]
@@ -52,17 +53,3 @@ these f g h = \case
5253
That b -> g b
5354
These a b -> h a b
5455
{-# INLINEABLE these #-}
55-
56-
instance (Ord a, Ord b) => Ord (These a b) where
57-
{-# INLINEABLE compare #-}
58-
compare (This a) (This a') = compare a a'
59-
compare (That b) (That b') = compare b b'
60-
compare (These a b) (These a' b') =
61-
case compare a a' of
62-
EQ -> compare b b'
63-
c -> c
64-
compare (This _) _ = LT
65-
compare (That _) (This _) = GT
66-
compare (That _) (These _ _) = LT
67-
compare (These _ _) (This _) = GT
68-
compare (These _ _) (That _) = GT

0 commit comments

Comments
 (0)