Skip to content

Commit 0b3bd07

Browse files
bezirgbezirg
committed
Plinth: Add Bounded typeclass and deriveBounded
1 parent dd37ea8 commit 0b3bd07

File tree

8 files changed

+187
-3
lines changed

8 files changed

+187
-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/Spec.hs‎

Lines changed: 53 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,53 @@
1+
{-# LANGUAGE DerivingStrategies #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE TemplateHaskell #-}
4+
{-# LANGUAGE TypeApplications #-}
5+
-- needed since we don't support polymorphic phantom types
6+
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
7+
8+
module Bounded.Spec (boundedTests) where
9+
10+
import PlutusTx.Bounded as Tx
11+
import PlutusTx.Test.Golden
12+
import Test.Tasty
13+
import Test.Tasty.Extras
14+
import Test.Tasty.HUnit
15+
import Prelude hiding (Eq (..), error)
16+
import Prelude qualified as HS (Bounded (..), Eq (..), Show (..))
17+
18+
data SomeVeryLargeEnum
19+
= E1
20+
| E2
21+
| E3
22+
| E4
23+
| E5
24+
| E6
25+
| E7
26+
| E8
27+
| E9
28+
| E10
29+
deriving stock (HS.Eq, HS.Bounded, HS.Show)
30+
deriveBounded ''SomeVeryLargeEnum
31+
32+
data SingleConstructor = SingleConstructor Bool Ordering ()
33+
deriveBounded ''SingleConstructor
34+
35+
newtype PhantomADT e = PhantomADT ()
36+
deriving stock (HS.Eq, HS.Bounded, HS.Show)
37+
deriveBounded ''PhantomADT
38+
39+
boundedTests :: TestTree
40+
boundedTests =
41+
let
42+
in testGroup
43+
"PlutusTx.Enum tests"
44+
[ testCase "conforms to haskell" $ (Tx.minBound @SomeVeryLargeEnum, Tx.maxBound @SomeVeryLargeEnum) @?= (HS.minBound, HS.maxBound)
45+
, -- currently does not work with polymorphic phantom types, remove the type annotation when support is added
46+
testCase "phantom" $ Tx.minBound @(PhantomADT ()) @?= HS.minBound
47+
, runTestNested
48+
["test", "Bounded", "Golden"]
49+
[ $(goldenCodeGen "SomeVeryLargeEnum" (deriveBounded ''SomeVeryLargeEnum))
50+
, $(goldenCodeGen "Ordering" (deriveBounded ''()))
51+
, $(goldenCodeGen "SingleConstructor" (deriveBounded ''SingleConstructor))
52+
]
53+
]

‎plutus-tx/test/Enum/Spec.hs‎

Lines changed: 0 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -34,7 +34,6 @@ data SomeVeryLargeEnum
3434
deriving stock (HS.Eq, HS.Enum, HS.Bounded, HS.Show)
3535
deriveEnum ''SomeVeryLargeEnum
3636

37-
-- we lack Tx.Bounded so we use Haskell's for the tests
3837
enumTests :: TestTree
3938
enumTests =
4039
let

0 commit comments

Comments
 (0)