Make deriving Bounded phantom types work

Author: bezirg

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

@@ -21,13 +21,20 @@ deriveBounded name = do
     , 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) <$> tyVars
+    instanceCxt = TH.AppT (TH.ConT ''Bounded) <$> nonPhantomTyVars
+
     instanceType :: TH.Type
     instanceType = TH.AppT (TH.ConT ''Bounded) $ foldl' TH.AppT (TH.ConT tyConName) tyVars
 

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

@@ -42,13 +42,13 @@ boundedTests =
    in testGroup
         "PlutusTx.Enum tests"
         [ testCase "conforms to haskell" $ (Tx.minBound @SomeVeryLargeEnum, Tx.maxBound @SomeVeryLargeEnum) @?= (HS.minBound, HS.maxBound)
-        , -- currently does not work with polymorphic phantom types, remove the type annotation when support is added
-          testCase "phantom" $ Tx.minBound @(PhantomADT ()) @?= HS.minBound
+        , 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))
             ]
         ]