Skip to content

Commit 92c4a26

Browse files
bezirgbezirg
committed
Plinth: Add Bounded typeclass and deriveBounded
1 parent de34c07 commit 92c4a26

File tree

13 files changed

+210
-3
lines changed

13 files changed

+210
-3
lines changed

‎plutus-tx/changelog.d/20251209_143407_bezirg_derive_bounded.md‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
### Added
2+
3+
- Bounded typeclass for Plinth same as Haskell's Bounded
4+
- A deriveBounded mechanism to derive Bounded for certain Plinth datatypes,
5+
similar to Haskell's `deriving stock Bounded`

‎plutus-tx/plutus-tx.cabal‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -72,6 +72,8 @@ library
7272
PlutusTx.Blueprint.Validator
7373
PlutusTx.Blueprint.Write
7474
PlutusTx.Bool
75+
PlutusTx.Bounded
76+
PlutusTx.Bounded.Class
7577
PlutusTx.BuiltinList
7678
PlutusTx.Builtins
7779
PlutusTx.Builtins.HasBuiltin
@@ -118,6 +120,7 @@ library
118120
PlutusTx.Utils
119121

120122
other-modules:
123+
PlutusTx.Bounded.TH
121124
PlutusTx.Enum.TH
122125
PlutusTx.IsData.Instances
123126
PlutusTx.IsData.TH
@@ -210,6 +213,7 @@ test-suite plutus-tx-test
210213
Blueprint.Definition.Spec
211214
Blueprint.Spec
212215
Bool.Spec
216+
Bounded.Spec
213217
Enum.Spec
214218
List.Spec
215219
Rational.Laws

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

Lines changed: 39 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,39 @@
1+
{-# LANGUAGE TemplateHaskell #-}
2+
{-# OPTIONS_GHC -Wno-orphans #-}
3+
4+
module PlutusTx.Bounded (Bounded (..), deriveBounded) where
5+
6+
import PlutusTx.Bool
7+
import PlutusTx.Bounded.Class
8+
import PlutusTx.Bounded.TH
9+
import PlutusTx.Ord
10+
11+
deriveBounded ''Bool
12+
deriveBounded ''Ordering
13+
deriveBounded ''()
14+
deriveBounded ''(,)
15+
deriveBounded ''(,,)
16+
deriveBounded ''(,,,)
17+
deriveBounded ''(,,,,)
18+
deriveBounded ''(,,,,,)
19+
deriveBounded ''(,,,,,,)
20+
deriveBounded ''(,,,,,,,)
21+
deriveBounded ''(,,,,,,,,)
22+
deriveBounded ''(,,,,,,,,,)
23+
deriveBounded ''(,,,,,,,,,,)
24+
deriveBounded ''(,,,,,,,,,,,)
25+
deriveBounded ''(,,,,,,,,,,,,)
26+
deriveBounded ''(,,,,,,,,,,,,,)
27+
deriveBounded ''(,,,,,,,,,,,,,,)
28+
deriveBounded ''(,,,,,,,,,,,,,,,)
29+
deriveBounded ''(,,,,,,,,,,,,,,,,)
30+
deriveBounded ''(,,,,,,,,,,,,,,,,,)
31+
deriveBounded ''(,,,,,,,,,,,,,,,,,,)
32+
deriveBounded ''(,,,,,,,,,,,,,,,,,,,)
33+
deriveBounded ''(,,,,,,,,,,,,,,,,,,,,)
34+
deriveBounded ''(,,,,,,,,,,,,,,,,,,,,,)
35+
deriveBounded ''(,,,,,,,,,,,,,,,,,,,,,,)
36+
deriveBounded ''(,,,,,,,,,,,,,,,,,,,,,,,)
37+
deriveBounded ''(,,,,,,,,,,,,,,,,,,,,,,,,)
38+
deriveBounded ''(,,,,,,,,,,,,,,,,,,,,,,,,,)
39+
deriveBounded ''(,,,,,,,,,,,,,,,,,,,,,,,,,,)

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

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
module PlutusTx.Bounded.Class (Bounded (..)) where
2+
3+
class Bounded a where
4+
minBound :: a
5+
maxBound :: a

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

Lines changed: 81 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,81 @@
1+
{-# LANGUAGE TemplateHaskellQuotes #-}
2+
3+
module PlutusTx.Bounded.TH (Bounded (..), deriveBounded) where
4+
5+
import Control.Monad
6+
import Data.Deriving.Internal (varTToName)
7+
import Data.Foldable
8+
import Language.Haskell.TH as TH
9+
import Language.Haskell.TH.Datatype as TH
10+
import PlutusTx.Bounded.Class
11+
import Prelude hiding (Bounded (..))
12+
13+
data MinMax = Min | Max
14+
15+
-- | Derive PlutusTx.Bounded typeclass for datatypes, much like `deriving stock Bounded` does for Haskell
16+
deriveBounded :: TH.Name -> TH.Q [TH.Dec]
17+
deriveBounded name = do
18+
TH.DatatypeInfo
19+
{ TH.datatypeName = tyConName
20+
, TH.datatypeInstTypes = tyVars0
21+
, TH.datatypeCons = cons
22+
} <-
23+
TH.reifyDatatype name
24+
let
25+
-- The purpose of the `TH.VarT . varTToName` roundtrip is to remove the kind
26+
-- signatures attached to the type variables in `tyVars0`. Otherwise, the
27+
-- `KindSignatures` extension would be needed whenever `length tyVars0 > 0`.
28+
tyVars = TH.VarT . varTToName <$> tyVars0
29+
instanceCxt :: TH.Cxt
30+
instanceCxt = TH.AppT (TH.ConT ''Bounded) <$> tyVars
31+
instanceType :: TH.Type
32+
instanceType = TH.AppT (TH.ConT ''Bounded) $ foldl' TH.AppT (TH.ConT tyConName) tyVars
33+
34+
when (null cons) $
35+
fail $
36+
"Can't make a derived instance of `Bounded "
37+
++ show tyConName
38+
++ "`: "
39+
++ show tyConName
40+
++ "must be an enumeration type (an enumeration consists of one or more nullary, non-GADT constructors) or "
41+
++ show tyConName
42+
++ " must have precisely one constructor"
43+
44+
pure
45+
<$> instanceD
46+
( pure $ case cons of
47+
[_] -> instanceCxt -- if single constructor, add instance context
48+
_ -> []
49+
)
50+
(pure instanceType)
51+
[ funD 'minBound (pure $ deriveXBound Min cons)
52+
, TH.pragInlD 'minBound TH.Inlinable TH.FunLike TH.AllPhases
53+
, funD 'maxBound (pure $ deriveXBound Max cons)
54+
, TH.pragInlD 'maxBound TH.Inlinable TH.FunLike TH.AllPhases
55+
]
56+
57+
deriveXBound :: MinMax -> [ConstructorInfo] -> Q Clause
58+
deriveXBound minMax [ConstructorInfo {constructorName = nameL, constructorFields = fields}] =
59+
pure
60+
( TH.Clause
61+
[]
62+
(NormalB $ foldr (const (`AppE` (VarE $ fromMinMax minMax))) (ConE nameL) fields)
63+
[]
64+
)
65+
where
66+
fromMinMax :: MinMax -> Name
67+
fromMinMax Min = 'minBound
68+
fromMinMax Max = 'maxBound
69+
deriveXBound minMax cons = do
70+
unless allConsNoFields $ fail "Can't make a derived instance of Bounded when constructor has fields"
71+
pure
72+
( TH.Clause
73+
[]
74+
(NormalB $ ConE $ constructorName $ fromMinMax minMax cons)
75+
[]
76+
)
77+
where
78+
fromMinMax :: MinMax -> ([a] -> a)
79+
fromMinMax Min = head
80+
fromMinMax Max = last
81+
allConsNoFields = foldl (\acc c -> acc && null (constructorFields c)) True cons

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

Lines changed: 0 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,3 @@
1-
{-# LANGUAGE DerivingStrategies #-}
21
{-# LANGUAGE TemplateHaskellQuotes #-}
32

43
module PlutusTx.Enum.TH (Enum (..), deriveEnum) where
@@ -15,7 +14,6 @@ import PlutusTx.Trace
1514
import Prelude hiding (Bool (True), Enum (..), Eq, (&&), (==))
1615

1716
data SuccPred = Succ | Pred
18-
deriving stock (Show)
1917

2018
{-| Derive PlutusTx.Enum typeclass for datatypes, much like `deriving stock Enum` does for Haskell
2119

‎plutus-tx/test/Bounded/Golden/Ordering.golden.th‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
instance PlutusTx.Bounded.Class.Bounded GHC.Types.Ordering
2+
where {PlutusTx.Bounded.Class.minBound = GHC.Types.LT;
3+
{-# INLINABLE PlutusTx.Bounded.Class.minBound #-};
4+
PlutusTx.Bounded.Class.maxBound = GHC.Types.GT;
5+
{-# INLINABLE PlutusTx.Bounded.Class.maxBound #-}}

‎plutus-tx/test/Bounded/Golden/SingleConstructor.golden.th‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
instance PlutusTx.Bounded.Class.Bounded a_0 => PlutusTx.Bounded.Class.Bounded (Bounded.Spec.SingleConstructor a_0)
2+
where {PlutusTx.Bounded.Class.minBound = Bounded.Spec.SingleConstructor PlutusTx.Bounded.Class.minBound PlutusTx.Bounded.Class.minBound PlutusTx.Bounded.Class.minBound;
3+
{-# INLINABLE PlutusTx.Bounded.Class.minBound #-};
4+
PlutusTx.Bounded.Class.maxBound = Bounded.Spec.SingleConstructor PlutusTx.Bounded.Class.maxBound PlutusTx.Bounded.Class.maxBound PlutusTx.Bounded.Class.maxBound;
5+
{-# INLINABLE PlutusTx.Bounded.Class.maxBound #-}}

‎plutus-tx/test/Bounded/Golden/SomeVeryLargeEnum.golden.th‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
instance PlutusTx.Bounded.Class.Bounded Bounded.Spec.SomeVeryLargeEnum
2+
where {PlutusTx.Bounded.Class.minBound = Bounded.Spec.E1;
3+
{-# INLINABLE PlutusTx.Bounded.Class.minBound #-};
4+
PlutusTx.Bounded.Class.maxBound = Bounded.Spec.E10;
5+
{-# INLINABLE PlutusTx.Bounded.Class.maxBound #-}}

‎plutus-tx/test/Bounded/Golden/Unit.golden.th‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
instance PlutusTx.Bounded.Class.Bounded GHC.Tuple.Prim.()
2+
where {PlutusTx.Bounded.Class.minBound = GHC.Tuple.Prim.();
3+
{-# INLINABLE PlutusTx.Bounded.Class.minBound #-};
4+
PlutusTx.Bounded.Class.maxBound = GHC.Tuple.Prim.();
5+
{-# INLINABLE PlutusTx.Bounded.Class.maxBound #-}}

0 commit comments

Comments
 (0)