Add 'TestInstances'

IntersectMBO · ana-pantilie · May 21, 2024 · Apr 29, 2024 · Apr 29, 2024 · Apr 29, 2024
commit 669e25fcf4fc9d4c964a50cd43b57cbfef5c4cb3
diff --git a/plutus-core/plutus-core/src/PlutusCore/Builtin/Polymorphism.hs b/plutus-core/plutus-core/src/PlutusCore/Builtin/Polymorphism.hs
@@ -8,6 +8,7 @@
 {-# LANGUAGE TypeFamilies             #-}
 {-# LANGUAGE TypeOperators            #-}
 {-# LANGUAGE UndecidableInstances     #-}
+{-# LANGUAGE UndecidableSuperClasses  #-}
 
 module PlutusCore.Builtin.Polymorphism
     ( Opaque (..)
@@ -214,7 +215,8 @@ type family AllElaboratedArgs constr x where
 -- built-in type.
 type AllBuiltinArgs
         :: forall a. (GHC.Type -> GHC.Type) -> (GHC.Type -> GHC.Constraint) -> a -> GHC.Constraint
-type AllBuiltinArgs uni constr x = AllElaboratedArgs constr (ElaborateBuiltin uni x)
+class    AllElaboratedArgs constr (ElaborateBuiltin uni x) => AllBuiltinArgs uni constr x
+instance AllElaboratedArgs constr (ElaborateBuiltin uni x) => AllBuiltinArgs uni constr x
 
 -- Custom type errors to guide the programmer adding a new built-in function.
 

diff --git a/plutus-tx/plutus-tx.cabal b/plutus-tx/plutus-tx.cabal
@@ -109,6 +109,7 @@ library
     PlutusTx.IsData.Instances
     PlutusTx.IsData.TH
     PlutusTx.Lift.Instances
+    PlutusTx.Lift.TestInstances
     PlutusTx.Lift.TH
     PlutusTx.Lift.THUtils
 

diff --git a/plutus-tx/src/PlutusTx/Lift/Class.hs b/plutus-tx/src/PlutusTx/Lift/Class.hs
@@ -30,7 +30,8 @@ import PlutusCore.Data
 import PlutusCore.Quote
 import PlutusIR.MkPir
 import PlutusTx.Builtins
-import PlutusTx.Builtins.Internal (BuiltinBool, BuiltinList, BuiltinPair, BuiltinUnit)
+import PlutusTx.Builtins.Internal (BuiltinBool, BuiltinInteger, BuiltinList, BuiltinPair,
+                                   BuiltinUnit)
 import PlutusTx.Builtins.IsBuiltin (FromBuiltin, HasFromBuiltin)
 
 import Language.Haskell.TH qualified as TH hiding (newName)
@@ -132,75 +133,71 @@ instance (TypeError ('Text "Int is not supported, use Integer instead"))
     => Lift uni Int where
     lift = Haskell.error "unsupported"
 
-instance uni `PLC.HasTypeLevel` Integer => Typeable uni Integer where
+instance uni `PLC.HasTypeLevel` Integer => Typeable uni BuiltinInteger where
     typeRep = typeRepBuiltin
 
 -- See Note [Lift and Typeable instances for builtins]
-instance uni `PLC.HasTermLevel` Integer => Lift uni Integer where
+instance uni `PLC.HasTermLevel` Integer => Lift uni BuiltinInteger where
     lift = liftBuiltin
 
--- See Note [Lift and Typeable instances for builtins]
-instance uni `PLC.HasTypeLevel` BS.ByteString => Typeable uni BS.ByteString where
-    typeRep = typeRepBuiltin
-
--- See Note [Lift and Typeable instances for builtins]
-instance uni `PLC.HasTypeLevel` Data => Typeable uni BuiltinData where
-    typeRep _ = typeRepBuiltin (Proxy @Data)
-
--- See Note [Lift and Typeable instances for builtins]
-instance uni `PLC.HasTermLevel` Data => Lift uni BuiltinData where
-    lift = liftBuiltin . builtinDataToData
-
 -- See Note [Lift and Typeable instances for builtins]
 instance uni `PLC.HasTypeLevel` BS.ByteString => Typeable uni BuiltinByteString where
-    typeRep _proxyByteString = typeRepBuiltin (Proxy @BS.ByteString)
+    typeRep _ = typeRepBuiltin (Proxy @BS.ByteString)
 
 -- See Note [Lift and Typeable instances for builtins]
 instance uni `PLC.HasTermLevel` BS.ByteString => Lift uni BuiltinByteString where
     lift = liftBuiltin . fromBuiltin
 
 -- See Note [Lift and Typeable instances for builtins]
 instance uni `PLC.HasTypeLevel` T.Text => Typeable uni BuiltinString where
-    typeRep _proxyByteString = typeRepBuiltin (Proxy @T.Text)
+    typeRep _ = typeRepBuiltin (Proxy @T.Text)
 
 -- See Note [Lift and Typeable instances for builtins]
 instance uni `PLC.HasTermLevel` T.Text => Lift uni BuiltinString where
     lift = liftBuiltin . fromBuiltin
 
 -- See Note [Lift and Typeable instances for builtins]
 instance uni `PLC.HasTypeLevel` () => Typeable uni BuiltinUnit where
-    typeRep _proxyUnit = typeRepBuiltin (Proxy @())
+    typeRep _ = typeRepBuiltin (Proxy @())
 
 -- See Note [Lift and Typeable instances for builtins]
 instance uni `PLC.HasTermLevel` () => Lift uni BuiltinUnit where
     lift = liftBuiltin . fromBuiltin
 
 -- See Note [Lift and Typeable instances for builtins]
 instance uni `PLC.HasTypeLevel` Bool => Typeable uni BuiltinBool where
-    typeRep _proxyBool = typeRepBuiltin (Proxy @Bool)
+    typeRep _ = typeRepBuiltin (Proxy @Bool)
 
 -- See Note [Lift and Typeable instances for builtins]
 instance uni `PLC.HasTermLevel` Bool => Lift uni BuiltinBool where
     lift = liftBuiltin . fromBuiltin
 
 -- See Note [Lift and Typeable instances for builtins]
 instance uni `PLC.HasTypeLevel` [] => Typeable uni BuiltinList where
-    typeRep _proxyBuiltinList = typeRepBuiltin (Proxy @[])
+    typeRep _ = typeRepBuiltin (Proxy @[])
 
 -- See Note [Lift and Typeable instances for builtins]
-instance (HasFromBuiltin a, uni `PLC.HasTermLevel` [FromBuiltin a]) =>
-        Lift uni (BuiltinList a) where
+instance (HasFromBuiltin arep, uni `PLC.HasTermLevel` [FromBuiltin arep]) =>
+        Lift uni (BuiltinList arep) where
     lift = liftBuiltin . fromBuiltin
 
 instance uni `PLC.HasTypeLevel` (,) => Typeable uni BuiltinPair where
-    typeRep _proxyBuiltinPair = typeRepBuiltin (Proxy @(,))
+    typeRep _ = typeRepBuiltin (Proxy @(,))
 
 instance
-        ( HasFromBuiltin a, HasFromBuiltin b
-        , uni `PLC.HasTermLevel` (FromBuiltin a, FromBuiltin b)
-        ) => Lift uni (BuiltinPair a b) where
+        ( HasFromBuiltin arep, HasFromBuiltin brep
+        , uni `PLC.HasTermLevel` (FromBuiltin arep, FromBuiltin brep)
+        ) => Lift uni (BuiltinPair arep brep) where
     lift = liftBuiltin . fromBuiltin
 
+-- See Note [Lift and Typeable instances for builtins]
+instance uni `PLC.HasTypeLevel` Data => Typeable uni BuiltinData where
+    typeRep _ = typeRepBuiltin (Proxy @Data)
+
+-- See Note [Lift and Typeable instances for builtins]
+instance uni `PLC.HasTermLevel` Data => Lift uni BuiltinData where
+    lift = liftBuiltin . builtinDataToData
+
 -- See Note [Lift and Typeable instances for builtins]
 instance uni `PLC.HasTypeLevel` PlutusCore.Crypto.BLS12_381.G1.Element =>
         Typeable uni BuiltinBLS12_381_G1_Element where

diff --git a/plutus-tx/src/PlutusTx/Lift/TestInstances.hs b/plutus-tx/src/PlutusTx/Lift/TestInstances.hs
@@ -0,0 +1,39 @@
+{-# LANGUAGE AllowAmbiguousTypes      #-}
+{-# LANGUAGE ConstraintKinds          #-}
+{-# LANGUAGE FlexibleInstances        #-}
+{-# LANGUAGE MultiParamTypeClasses    #-}
+{-# LANGUAGE QuantifiedConstraints    #-}
+{-# LANGUAGE StandaloneKindSignatures #-}
+{-# LANGUAGE TypeOperators            #-}
+{-# LANGUAGE UndecidableInstances     #-}
+{-# LANGUAGE UndecidableSuperClasses  #-}
+
+module PlutusTx.Lift.TestInstances () where
+
+import PlutusCore qualified as PLC
+import PlutusCore.Builtin qualified as PLC
+import PlutusTx.Builtins.IsBuiltin
+import PlutusTx.Lift.Class
+
+import Data.Kind qualified as GHC
+
+type BuiltinSatisfies
+    :: (GHC.Type -> GHC.Constraint)
+    -> (GHC.Type -> GHC.Constraint)
+    -> GHC.Type
+    -> GHC.Constraint
+class    (pre (ToBuiltin a) => post (ToBuiltin a)) => BuiltinSatisfies pre post a
+instance (pre (ToBuiltin a) => post (ToBuiltin a)) => BuiltinSatisfies pre post a
+
+type AllBuiltinsSatisfy
+    :: (GHC.Type -> GHC.Constraint)
+    -> (GHC.Type -> GHC.Constraint)
+    -> GHC.Constraint
+class PLC.DefaultUni `PLC.Everywhere` BuiltinSatisfies pre post => AllBuiltinsSatisfy pre post
+
+instance AllBuiltinsSatisfy
+    (PLC.AllBuiltinArgs PLC.DefaultUni (Typeable PLC.DefaultUni))
+    (Typeable PLC.DefaultUni)
+instance AllBuiltinsSatisfy
+    (PLC.AllBuiltinArgs PLC.DefaultUni HasFromBuiltin)
+    (Lift PLC.DefaultUni)