diff --git a/plutus-tx-plugin/plutus-tx-plugin.cabal b/plutus-tx-plugin/plutus-tx-plugin.cabal index 65888661efe..f3ffc4c6430 100644 --- a/plutus-tx-plugin/plutus-tx-plugin.cabal +++ b/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 diff --git a/plutus-tx-plugin/test/Bounded/Spec.hs b/plutus-tx-plugin/test/Bounded/Spec.hs new file mode 100644 index 00000000000..6f94ab18a76 --- /dev/null +++ b/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 + ] + ] diff --git a/plutus-tx-plugin/test/Spec.hs b/plutus-tx-plugin/test/Spec.hs index 059283d075a..7c5915abc03 100644 --- a/plutus-tx-plugin/test/Spec.hs +++ b/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 ] diff --git a/plutus-tx/changelog.d/20251209_143407_bezirg_derive_bounded.md b/plutus-tx/changelog.d/20251209_143407_bezirg_derive_bounded.md new file mode 100644 index 00000000000..5288848c107 --- /dev/null +++ b/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` diff --git a/plutus-tx/plutus-tx.cabal b/plutus-tx/plutus-tx.cabal index e03751dc9ea..23c5caa1cce 100644 --- a/plutus-tx/plutus-tx.cabal +++ b/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 diff --git a/plutus-tx/src/PlutusTx/Bounded.hs b/plutus-tx/src/PlutusTx/Bounded.hs new file mode 100644 index 00000000000..acb1131955f --- /dev/null +++ b/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 ''(,,,,,,,,,,,,,,,,,,,,,,,,,,) diff --git a/plutus-tx/src/PlutusTx/Bounded/Class.hs b/plutus-tx/src/PlutusTx/Bounded/Class.hs new file mode 100644 index 00000000000..f6a1e167057 --- /dev/null +++ b/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 diff --git a/plutus-tx/src/PlutusTx/Bounded/TH.hs b/plutus-tx/src/PlutusTx/Bounded/TH.hs new file mode 100644 index 00000000000..d599949940c --- /dev/null +++ b/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 diff --git a/plutus-tx/src/PlutusTx/Enum/TH.hs b/plutus-tx/src/PlutusTx/Enum/TH.hs index c13ed418740..9dfa34b2ed2 100644 --- a/plutus-tx/src/PlutusTx/Enum/TH.hs +++ b/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 diff --git a/plutus-tx/src/PlutusTx/Prelude.hs b/plutus-tx/src/PlutusTx/Prelude.hs index 195409be63f..005c9c96fdb 100644 --- a/plutus-tx/src/PlutusTx/Prelude.hs +++ b/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 diff --git a/plutus-tx/test/Bounded/Golden/Ordering.golden.th b/plutus-tx/test/Bounded/Golden/Ordering.golden.th new file mode 100644 index 00000000000..2cc8ad66c19 --- /dev/null +++ b/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 #-}} \ No newline at end of file diff --git a/plutus-tx/test/Bounded/Golden/PhantomADT.golden.th b/plutus-tx/test/Bounded/Golden/PhantomADT.golden.th new file mode 100644 index 00000000000..3e9f12f4f8b --- /dev/null +++ b/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 #-}} \ No newline at end of file diff --git a/plutus-tx/test/Bounded/Golden/SingleConstructor.golden.th b/plutus-tx/test/Bounded/Golden/SingleConstructor.golden.th new file mode 100644 index 00000000000..57fa275cdd0 --- /dev/null +++ b/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 #-}} \ No newline at end of file diff --git a/plutus-tx/test/Bounded/Golden/SomeVeryLargeEnum.golden.th b/plutus-tx/test/Bounded/Golden/SomeVeryLargeEnum.golden.th new file mode 100644 index 00000000000..7162f90be61 --- /dev/null +++ b/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 #-}} \ No newline at end of file diff --git a/plutus-tx/test/Bounded/Golden/Unit.golden.th b/plutus-tx/test/Bounded/Golden/Unit.golden.th new file mode 100644 index 00000000000..607c53d6bdd --- /dev/null +++ b/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 #-}} \ No newline at end of file diff --git a/plutus-tx/test/Bounded/Spec.hs b/plutus-tx/test/Bounded/Spec.hs new file mode 100644 index 00000000000..73322fa857c --- /dev/null +++ b/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)) + ] + ] diff --git a/plutus-tx/test/Enum/Spec.hs b/plutus-tx/test/Enum/Spec.hs index 9b4eacd31a2..1f7b1e51fa0 100644 --- a/plutus-tx/test/Enum/Spec.hs +++ b/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 diff --git a/plutus-tx/test/Spec.hs b/plutus-tx/test/Spec.hs index 7b7571fcda8..3391943dcc0 100644 --- a/plutus-tx/test/Spec.hs +++ b/plutus-tx/test/Spec.hs @@ -7,6 +7,7 @@ module Main (main) where import Blueprint.Definition.Spec qualified import Bool.Spec (boolTests) +import Bounded.Spec (boundedTests) import Codec.CBOR.FlatTerm qualified as FlatTerm import Codec.Serialise (deserialiseOrFail, serialise) import Codec.Serialise qualified as Serialise @@ -43,6 +44,7 @@ tests = , ratioTests , bytestringTests , enumTests + , boundedTests , listTests , boolTests , lawsTests