Plinth: Add Bounded typeclass and deriveBounded

plutus-tx-plugin/plutus-tx-plugin.cabal

@@ -116,6 +116,7 @@ test-suite plutus-tx-plugin-tests
   main-is:            Spec.hs
   other-modules:
     Array.Spec
+    Bounded.Spec
     AsData.Budget.Spec
     AsData.Budget.Types
     AssocMap.Golden

plutus-tx-plugin/test/Bounded/Spec.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE TypeApplications #-}
+{-# OPTIONS_GHC -fplugin PlutusTx.Plugin #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-cse-iterations=0 #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-pir=0 #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:max-simplifier-iterations-uplc=0 #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-optimize #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-simplifier-beta #-}
+{-# OPTIONS_GHC -fplugin-opt PlutusTx.Plugin:no-simplifier-evaluate-builtins #-}
+
+module Bounded.Spec where
+
+import PlutusTx
+import PlutusTx.Test (goldenPirReadable)
+import Test.Tasty.Extras
+import PlutusTx.Bounded
+import PlutusTx.Prelude
+import PlutusTx.Plugin (plc)
+import Data.Proxy (Proxy (..))
+
+data SomeVeryLargeEnum
+  = E1
+  | E2
+  | E3
+  | E4
+  | E5
+  | E6
+  | E7
+  | E8
+  | E9
+  | E10
+deriveBounded ''SomeVeryLargeEnum
+
+data SingleConstructor a = SingleConstructor Bool a ()
+deriveBounded ''SingleConstructor
+
+newtype PhantomADT e = PhantomADT ()
+deriveBounded ''PhantomADT
+
+minAndMax :: Bounded a => (a, a)
+minAndMax = (minBound,maxBound)
+
+compiledSomeVeryLargeEnum :: CompiledCode (SomeVeryLargeEnum, SomeVeryLargeEnum)
+compiledSomeVeryLargeEnum = plc (Proxy @"compiledSomeVeryLargeEnum") minAndMax
+
+compiledSingleConstructor :: CompiledCode (SingleConstructor Ordering, SingleConstructor Ordering)
+compiledSingleConstructor = plc (Proxy @"compiledSingleConstructor") minAndMax
+
+{- here cannot use Ordering or Either as the phantom type because of
+pir compile error (unrelated to Bounded):
+GHC Core to PLC plugin: Error: Error from the PIR compiler:
+Error during compilation: Type bindings cannot appear in recursive let, use datatypebind instead
+See https://github.com/IntersectMBO/plutus/issues/7498
+-}
+compiledPhantomADT :: CompiledCode (PhantomADT Bool, PhantomADT Bool)
+compiledPhantomADT = plc (Proxy @"compiledPhantomADT") minAndMax
+
+tests :: TestNested
+tests =
+  testNested
+    "Bounded"
+    [ testNestedGhc
+        [ goldenPirReadable "SomeVeryLargeEnum" compiledSomeVeryLargeEnum
+        , goldenPirReadable "SingleConstructor" compiledSingleConstructor
+        , goldenPirReadable "PhantomADT" compiledPhantomADT
+        ]
+    ]

plutus-tx-plugin/test/Spec.hs

@@ -1,5 +1,6 @@
 module Main (main) where
 
+import Bounded.Spec qualified as Bounded
 import Array.Spec qualified as Array
 import AsData.Budget.Spec qualified as AsData.Budget
 import AssocMap.Spec qualified as AssocMap
@@ -61,5 +62,6 @@ tests =
     , embed AssocMap.propertyTests
     , embed List.propertyTests
     , Array.smokeTests
+    , Bounded.tests
     , CallTrace.tests
     ]

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

@@ -0,0 +1,5 @@
+### Added
+
+- Bounded typeclass for Plinth same as Haskell's Bounded
+- A deriveBounded mechanism to derive Bounded for certain Plinth datatypes,
+  similar to Haskell's `deriving stock Bounded`

plutus-tx/plutus-tx.cabal

@@ -72,6 +72,8 @@ library
     PlutusTx.Blueprint.Validator
     PlutusTx.Blueprint.Write
     PlutusTx.Bool
+    PlutusTx.Bounded
+    PlutusTx.Bounded.Class
     PlutusTx.BuiltinList
     PlutusTx.Builtins
     PlutusTx.Builtins.HasBuiltin
@@ -118,6 +120,7 @@ library
     PlutusTx.Utils
 
   other-modules:
+    PlutusTx.Bounded.TH
     PlutusTx.Enum.TH
     PlutusTx.IsData.Instances
     PlutusTx.IsData.TH
@@ -210,6 +213,7 @@ test-suite plutus-tx-test
     Blueprint.Definition.Spec
     Blueprint.Spec
     Bool.Spec
+    Bounded.Spec
     Enum.Spec
     List.Spec
     Rational.Laws

plutus-tx/src/PlutusTx/Bounded.hs

@@ -0,0 +1,39 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module PlutusTx.Bounded (Bounded (..), deriveBounded) where
+
+import PlutusTx.Bool
+import PlutusTx.Bounded.Class
+import PlutusTx.Bounded.TH
+import PlutusTx.Ord
+
+deriveBounded ''Bool
+deriveBounded ''Ordering
+deriveBounded ''()
+deriveBounded ''(,)
+deriveBounded ''(,,)
+deriveBounded ''(,,,)
+deriveBounded ''(,,,,)
+deriveBounded ''(,,,,,)
+deriveBounded ''(,,,,,,)
+deriveBounded ''(,,,,,,,)
+deriveBounded ''(,,,,,,,,)
+deriveBounded ''(,,,,,,,,,)
+deriveBounded ''(,,,,,,,,,,)
+deriveBounded ''(,,,,,,,,,,,)
+deriveBounded ''(,,,,,,,,,,,,)
+deriveBounded ''(,,,,,,,,,,,,,)
+deriveBounded ''(,,,,,,,,,,,,,,)
+deriveBounded ''(,,,,,,,,,,,,,,,)
+deriveBounded ''(,,,,,,,,,,,,,,,,)
+deriveBounded ''(,,,,,,,,,,,,,,,,,)
+deriveBounded ''(,,,,,,,,,,,,,,,,,,)
+deriveBounded ''(,,,,,,,,,,,,,,,,,,,)
+deriveBounded ''(,,,,,,,,,,,,,,,,,,,,)
+deriveBounded ''(,,,,,,,,,,,,,,,,,,,,,)
+deriveBounded ''(,,,,,,,,,,,,,,,,,,,,,,)
+deriveBounded ''(,,,,,,,,,,,,,,,,,,,,,,,)
+deriveBounded ''(,,,,,,,,,,,,,,,,,,,,,,,,)
+deriveBounded ''(,,,,,,,,,,,,,,,,,,,,,,,,,)
+deriveBounded ''(,,,,,,,,,,,,,,,,,,,,,,,,,,)

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

@@ -0,0 +1,5 @@
+module PlutusTx.Bounded.Class (Bounded (..)) where
+
+class Bounded a where
+  minBound :: a
+  maxBound :: a

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

@@ -0,0 +1,88 @@
+{-# LANGUAGE TemplateHaskellQuotes #-}
+
+module PlutusTx.Bounded.TH (Bounded (..), deriveBounded) where
+
+import Control.Monad
+import Data.Deriving.Internal (varTToName)
+import Data.Foldable
+import Language.Haskell.TH as TH
+import Language.Haskell.TH.Datatype as TH
+import PlutusTx.Bounded.Class
+import Prelude hiding (Bounded (..))
+
+data MinMax = Min | Max
+
+-- | Derive PlutusTx.Bounded typeclass for datatypes, much like `deriving stock Bounded` does for Haskell
+deriveBounded :: TH.Name -> TH.Q [TH.Dec]
+deriveBounded 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 ''Bounded) <$> nonPhantomTyVars
+
+    instanceType :: TH.Type
+    instanceType = TH.AppT (TH.ConT ''Bounded) $ foldl' TH.AppT (TH.ConT tyConName) tyVars
+
+  when (null cons) $
+    fail $
+      "Can't make a derived instance of `Bounded "
+        ++ show tyConName
+        ++ "`: "
+        ++ show tyConName
+        ++ "must be an enumeration type (an enumeration consists of one or more nullary, non-GADT constructors) or "
+        ++ show tyConName
+        ++ " must have precisely one constructor"
+
+  pure
+    <$> instanceD
+      ( pure $ case cons of
+          [_] -> instanceCxt -- if single constructor, add instance context
+          _ -> []
+      )
+      (pure instanceType)
+      [ funD 'minBound (pure $ deriveXBound Min cons)
+      , TH.pragInlD 'minBound TH.Inlinable TH.FunLike TH.AllPhases
+      , funD 'maxBound (pure $ deriveXBound Max cons)
+      , TH.pragInlD 'maxBound TH.Inlinable TH.FunLike TH.AllPhases
+      ]
+
+deriveXBound :: MinMax -> [ConstructorInfo] -> Q Clause
+deriveXBound minMax [ConstructorInfo {constructorName = nameL, constructorFields = fields}] =
+  pure
+    ( TH.Clause
+        []
+        (NormalB $ foldr (const (`AppE` (VarE $ fromMinMax minMax))) (ConE nameL) fields)
+        []
+    )
+  where
+    fromMinMax :: MinMax -> Name
+    fromMinMax Min = 'minBound
+    fromMinMax Max = 'maxBound
+deriveXBound minMax cons = do
+  unless allConsNoFields $ fail "Can't make a derived instance of Bounded when constructor has fields"
+  pure
+    ( TH.Clause
+        []
+        (NormalB $ ConE $ constructorName $ fromMinMax minMax cons)
+        []
+    )
+  where
+    fromMinMax :: MinMax -> ([a] -> a)
+    fromMinMax Min = head
+    fromMinMax Max = last
+    allConsNoFields = foldl (\acc c -> acc && null (constructorFields c)) True cons

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

@@ -1,4 +1,3 @@
-{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE TemplateHaskellQuotes #-}
 
 module PlutusTx.Enum.TH (Enum (..), deriveEnum) where
@@ -15,7 +14,6 @@ import PlutusTx.Trace
 import Prelude hiding (Bool (True), Enum (..), Eq, (&&), (==))
 
 data SuccPred = Succ | Pred
-  deriving stock (Show)
 
 {-| Derive PlutusTx.Enum typeclass for datatypes, much like `deriving stock Enum` does for Haskell
 

plutus-tx/src/PlutusTx/Prelude.hs

@@ -20,6 +20,7 @@ module PlutusTx.Prelude
     module Eq
   , module Enum
   , module Ord
+  , module Bounded
   , module Semigroup
   , module Monoid
   , module Numeric
@@ -230,6 +231,7 @@ import PlutusTx.Builtins
   , verifySchnorrSecp256k1Signature
   )
 
+import PlutusTx.Bounded as Bounded
 import PlutusTx.Builtins qualified as Builtins
 import PlutusTx.Builtins.Internal qualified as BI
 import PlutusTx.Either as Either

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

@@ -0,0 +1,5 @@
+instance PlutusTx.Bounded.Class.Bounded GHC.Types.Ordering
+    where {PlutusTx.Bounded.Class.minBound = GHC.Types.LT;
+           {-# INLINABLE PlutusTx.Bounded.Class.minBound #-};
+           PlutusTx.Bounded.Class.maxBound = GHC.Types.GT;
+           {-# INLINABLE PlutusTx.Bounded.Class.maxBound #-}}

plutus-tx/test/Bounded/Golden/PhantomADT.golden.th

@@ -0,0 +1,5 @@
+instance PlutusTx.Bounded.Class.Bounded (Bounded.Spec.PhantomADT e_0)
+    where {PlutusTx.Bounded.Class.minBound = Bounded.Spec.PhantomADT PlutusTx.Bounded.Class.minBound;
+           {-# INLINABLE PlutusTx.Bounded.Class.minBound #-};
+           PlutusTx.Bounded.Class.maxBound = Bounded.Spec.PhantomADT PlutusTx.Bounded.Class.maxBound;
+           {-# INLINABLE PlutusTx.Bounded.Class.maxBound #-}}

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

@@ -0,0 +1,5 @@
+instance PlutusTx.Bounded.Class.Bounded a_0 => PlutusTx.Bounded.Class.Bounded (Bounded.Spec.SingleConstructor a_0)
+    where {PlutusTx.Bounded.Class.minBound = Bounded.Spec.SingleConstructor PlutusTx.Bounded.Class.minBound PlutusTx.Bounded.Class.minBound PlutusTx.Bounded.Class.minBound;
+           {-# INLINABLE PlutusTx.Bounded.Class.minBound #-};
+           PlutusTx.Bounded.Class.maxBound = Bounded.Spec.SingleConstructor PlutusTx.Bounded.Class.maxBound PlutusTx.Bounded.Class.maxBound PlutusTx.Bounded.Class.maxBound;
+           {-# INLINABLE PlutusTx.Bounded.Class.maxBound #-}}

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

@@ -0,0 +1,5 @@
+instance PlutusTx.Bounded.Class.Bounded Bounded.Spec.SomeVeryLargeEnum
+    where {PlutusTx.Bounded.Class.minBound = Bounded.Spec.E1;
+           {-# INLINABLE PlutusTx.Bounded.Class.minBound #-};
+           PlutusTx.Bounded.Class.maxBound = Bounded.Spec.E10;
+           {-# INLINABLE PlutusTx.Bounded.Class.maxBound #-}}

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

@@ -0,0 +1,5 @@
+instance PlutusTx.Bounded.Class.Bounded GHC.Tuple.Prim.()
+    where {PlutusTx.Bounded.Class.minBound = GHC.Tuple.Prim.();
+           {-# INLINABLE PlutusTx.Bounded.Class.minBound #-};
+           PlutusTx.Bounded.Class.maxBound = GHC.Tuple.Prim.();
+           {-# INLINABLE PlutusTx.Bounded.Class.maxBound #-}}

plutus-tx/test/Bounded/Spec.hs

@@ -0,0 +1,52 @@
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Bounded.Spec (boundedTests) where
+
+import PlutusTx.Bounded as Tx
+import PlutusTx.Test.Golden
+import Test.Tasty
+import Test.Tasty.Extras
+import Test.Tasty.HUnit
+import Prelude hiding (Eq (..), error)
+import Prelude qualified as HS (Bounded (..), Eq (..), Show (..))
+
+data SomeVeryLargeEnum
+  = E1
+  | E2
+  | E3
+  | E4
+  | E5
+  | E6
+  | E7
+  | E8
+  | E9
+  | E10
+  deriving stock (HS.Eq, HS.Bounded, HS.Show)
+deriveBounded ''SomeVeryLargeEnum
+
+data SingleConstructor a = SingleConstructor Bool a ()
+deriveBounded ''SingleConstructor
+
+newtype PhantomADT e = PhantomADT ()
+  deriving stock (HS.Eq, HS.Bounded, HS.Show)
+deriveBounded ''PhantomADT
+
+boundedTests :: TestTree
+boundedTests =
+  let
+   in testGroup
+        "PlutusTx.Enum tests"
+        [ testCase "conforms to haskell" $ (Tx.minBound @SomeVeryLargeEnum, Tx.maxBound @SomeVeryLargeEnum) @?= (HS.minBound, HS.maxBound)
+        , testCase "phantom" $ Tx.minBound @(PhantomADT _) @?= HS.minBound
+        , runTestNested
+            ["test", "Bounded", "Golden"]
+            [ $(goldenCodeGen "SomeVeryLargeEnum" (deriveBounded ''SomeVeryLargeEnum))
+            , $(goldenCodeGen "Unit" (deriveBounded ''()))
+            , $(goldenCodeGen "Ordering" (deriveBounded ''Ordering))
+            , $(goldenCodeGen "SingleConstructor" (deriveBounded ''SingleConstructor))
+            , $(goldenCodeGen "PhantomADT" (deriveBounded ''PhantomADT))
+            ]
+        ]

plutus-tx/test/Enum/Spec.hs

@@ -34,7 +34,6 @@ data SomeVeryLargeEnum
   deriving stock (HS.Eq, HS.Enum, HS.Bounded, HS.Show)
 deriveEnum ''SomeVeryLargeEnum
 
--- we lack Tx.Bounded so we use Haskell's for the tests
 enumTests :: TestTree
 enumTests =
   let