GHC 9.2.1 support

Plutarch.hs

@@ -172,7 +172,7 @@ instance {-# OVERLAPPABLE #-} PlutusType a => PMatch a where
   pmatch x f = pmatch' (punsafeCoerce x) f
 
 instance PlutusType a => PCon a where
-  pcon = punsafeCoerce . pcon'
+  pcon x = punsafeCoerce (pcon' x)
 
 class PCon a where
   -- | Construct a Plutarch Term via a Haskell datatype
@@ -187,13 +187,13 @@ class PMatch a where
   assuming that the value is a safe construction of the Term.
 -}
 punsafeFrom :: (forall b. Term s (PInner a b)) -> Term s a
-punsafeFrom = punsafeCoerce
+punsafeFrom x = punsafeCoerce x
 
 {- |
   Safely coerce from a Term to it's 'PInner' representation.
 -}
 pto :: Term s a -> (forall b. Term s (PInner a b))
-pto = punsafeCoerce
+pto x = punsafeCoerce x
 
 -- | An Arbitrary Term with an unknown type
 data POpaque s = POpaque (Term s POpaque)

Plutarch/Api/V1.hs

@@ -77,6 +77,7 @@ import Plutarch.DataRepr (
  )
 import Plutarch.Integer (PInteger, PIntegral)
 import Plutarch.Lift (AsDefaultUni, PBuiltinType, PHaskellType, PLift (..), pconstant)
+
 -- ctor in-scope for deriving
 import Plutarch.Prelude
 import Plutarch.Tuple (PTuple)

Plutarch/DataRepr.hs

@@ -128,12 +128,10 @@ pmatchDataRepr d handlers =
               handler
               $ go common (idx + 1) rest constr
 
-newtype PIsDataReprInstances a h s = PIsDataReprInstances (a s)
+newtype PIsDataReprInstances (a :: k -> Type) (h :: Type) (s :: k) = PIsDataReprInstances (a s)
 
 instance AsDefaultUni (PIsDataReprInstances a h) where
-  type
-    DefaultUniType (PIsDataReprInstances a h) =
-      (DefaultUniType (PBuiltinPair PInteger PData))
+  type DefaultUniType (PIsDataReprInstances a h) = ()
 
 class (PMatch a, PIsData a) => PIsDataRepr (a :: k -> Type) where
   type PIsDataReprRepr a :: [[k -> Type]]

Plutarch/Internal.hs

@@ -26,25 +26,21 @@ module Plutarch.Internal (
   TermResult (TermResult, getDeps, getTerm),
 ) where
 
-import Control.Monad (guard)
 import Crypto.Hash (Context, Digest, hashFinalize, hashInit, hashUpdate)
 import Crypto.Hash.Algorithms (Blake2b_160)
 import Crypto.Hash.IO (HashAlgorithm)
 import qualified Data.ByteString as BS
-import Data.Function ((&))
 import Data.Kind (Type)
 import Data.List (foldl', groupBy, sortOn)
 import qualified Data.Map.Lazy as M
 import qualified Data.Set as S
 import qualified Flat.Run as F
-import GHC.Natural (intToNatural)
 import GHC.Stack (HasCallStack)
 import Numeric.Natural (Natural)
 import Plutarch.Evaluate (evaluateScript)
 import Plutus.V1.Ledger.Scripts (Script (Script))
 import PlutusCore (Some, ValueOf)
 import qualified PlutusCore as PLC
-import qualified PlutusCore.Constant as PLC
 import PlutusCore.DeBruijn (DeBruijn (DeBruijn), Index (Index))
 import qualified UntypedPlutusCore as UPLC
 
@@ -161,27 +157,59 @@ plam' f = Term $ \i ->
     getArity t = getArityBuiltin t
 
     getArityBuiltin :: RawTerm -> Maybe Natural
-    getArityBuiltin (RBuiltin builtin) =
-      guard (getPolyVarCount builtin == 0) >> pure (getArityBuiltin' builtin)
-    getArityBuiltin (RForce (RBuiltin builtin)) =
-      guard (getPolyVarCount builtin == 1) >> pure (getArityBuiltin' builtin)
-    getArityBuiltin (RForce (RForce (RBuiltin builtin))) =
-      guard (getPolyVarCount builtin == 2) >> pure (getArityBuiltin' builtin)
+    getArityBuiltin (RBuiltin PLC.AddInteger) = Just 1
+    getArityBuiltin (RBuiltin PLC.SubtractInteger) = Just 1
+    getArityBuiltin (RBuiltin PLC.MultiplyInteger) = Just 1
+    getArityBuiltin (RBuiltin PLC.DivideInteger) = Just 1
+    getArityBuiltin (RBuiltin PLC.QuotientInteger) = Just 1
+    getArityBuiltin (RBuiltin PLC.RemainderInteger) = Just 1
+    getArityBuiltin (RBuiltin PLC.ModInteger) = Just 1
+    getArityBuiltin (RBuiltin PLC.EqualsInteger) = Just 1
+    getArityBuiltin (RBuiltin PLC.LessThanInteger) = Just 1
+    getArityBuiltin (RBuiltin PLC.LessThanEqualsInteger) = Just 1
+    getArityBuiltin (RBuiltin PLC.AppendByteString) = Just 1
+    getArityBuiltin (RBuiltin PLC.ConsByteString) = Just 1
+    getArityBuiltin (RBuiltin PLC.SliceByteString) = Just 2
+    getArityBuiltin (RBuiltin PLC.LengthOfByteString) = Just 0
+    getArityBuiltin (RBuiltin PLC.IndexByteString) = Just 1
+    getArityBuiltin (RBuiltin PLC.EqualsByteString) = Just 1
+    getArityBuiltin (RBuiltin PLC.LessThanByteString) = Just 1
+    getArityBuiltin (RBuiltin PLC.LessThanEqualsByteString) = Just 1
+    getArityBuiltin (RBuiltin PLC.Sha2_256) = Just 0
+    getArityBuiltin (RBuiltin PLC.Sha3_256) = Just 0
+    getArityBuiltin (RBuiltin PLC.Blake2b_256) = Just 0
+    getArityBuiltin (RBuiltin PLC.VerifySignature) = Just 2
+    getArityBuiltin (RBuiltin PLC.AppendString) = Just 1
+    getArityBuiltin (RBuiltin PLC.EqualsString) = Just 1
+    getArityBuiltin (RBuiltin PLC.EncodeUtf8) = Just 0
+    getArityBuiltin (RBuiltin PLC.DecodeUtf8) = Just 0
+    getArityBuiltin (RForce (RBuiltin PLC.IfThenElse)) = Just 2
+    getArityBuiltin (RForce (RBuiltin PLC.ChooseUnit)) = Just 1
+    getArityBuiltin (RForce (RBuiltin PLC.Trace)) = Just 1
+    getArityBuiltin (RForce (RForce (RBuiltin PLC.FstPair))) = Just 0
+    getArityBuiltin (RForce (RForce (RBuiltin PLC.SndPair))) = Just 0
+    getArityBuiltin (RForce (RForce (RBuiltin PLC.ChooseList))) = Just 2
+    getArityBuiltin (RForce (RBuiltin PLC.MkCons)) = Just 1
+    getArityBuiltin (RForce (RBuiltin PLC.HeadList)) = Just 0
+    getArityBuiltin (RForce (RBuiltin PLC.TailList)) = Just 0
+    getArityBuiltin (RForce (RBuiltin PLC.NullList)) = Just 0
+    getArityBuiltin (RForce (RBuiltin PLC.ChooseData)) = Just 5
+    getArityBuiltin (RBuiltin PLC.ConstrData) = Just 1
+    getArityBuiltin (RBuiltin PLC.MapData) = Just 0
+    getArityBuiltin (RBuiltin PLC.ListData) = Just 0
+    getArityBuiltin (RBuiltin PLC.IData) = Just 0
+    getArityBuiltin (RBuiltin PLC.BData) = Just 0
+    getArityBuiltin (RBuiltin PLC.UnConstrData) = Just 0
+    getArityBuiltin (RBuiltin PLC.UnMapData) = Just 0
+    getArityBuiltin (RBuiltin PLC.UnListData) = Just 0
+    getArityBuiltin (RBuiltin PLC.UnIData) = Just 0
+    getArityBuiltin (RBuiltin PLC.UnBData) = Just 0
+    getArityBuiltin (RBuiltin PLC.EqualsData) = Just 1
+    getArityBuiltin (RBuiltin PLC.MkPairData) = Just 1
+    getArityBuiltin (RBuiltin PLC.MkNilData) = Just 0
+    getArityBuiltin (RBuiltin PLC.MkNilPairData) = Just 0
     getArityBuiltin _ = Nothing
 
-    getArityBuiltin' :: PLC.DefaultFun -> Natural
-    getArityBuiltin' builtin =
-      case PLC.toBuiltinMeaning @_ @_ @(PLC.Term PLC.TyName PLC.Name _ _ ()) builtin of
-        PLC.BuiltinMeaning sch _ _ ->
-          intToNatural $ PLC.countTermArgs sch - 1
-    getPolyVarCount :: PLC.DefaultFun -> Int
-    getPolyVarCount builtin =
-      case PLC.toBuiltinMeaning @_ @_ @(PLC.Term PLC.TyName PLC.Name _ _ ()) builtin of
-        PLC.BuiltinMeaning sch _ _ ->
-          PLC.getArity sch
-            & filter (== PLC.TypeArg)
-            & length
-
 {- |
   Let bindings.
 
@@ -259,7 +287,7 @@ punsafeConstantInternal :: Some (ValueOf PLC.DefaultUni) -> Term s a
 punsafeConstantInternal c = Term $ \_ -> mkTermRes $ RConstant c
 
 asClosedRawTerm :: ClosedTerm a -> TermResult
-asClosedRawTerm = flip asRawTerm 0
+asClosedRawTerm t = asRawTerm t 0
 
 -- FIXME: Give proper error message when mutually recursive.
 phoistAcyclic :: HasCallStack => ClosedTerm a -> Term s a

Plutarch/Lift.hs

@@ -94,6 +94,10 @@ plift prog = either (error . show) id $ plift' prog
 -}
 newtype PBuiltinType (p :: k -> Type) (h :: Type) s = PBuiltinType (p s)
 
+instance {-# OVERLAPPABLE #-} PLift (PBuiltinType p h) where
+  type PHaskellType (PBuiltinType p h) = h
+
+{-
 instance
   {-# OVERLAPS #-}
   ( PLC.KnownTypeIn PLC.DefaultUni (UPLC.Term PLC.DeBruijn PLC.DefaultUni PLC.DefaultFun ()) h
@@ -110,6 +114,7 @@ instance
       Right (_, _, Scripts.unScript -> UPLC.Program _ _ term) ->
         first (LiftError_EvalException . showEvalException) $
           readKnownSelf term
+-}
 
 showEvalException :: EvaluationException CekUserError (MachineError PLC.DefaultFun) (UPLC.Term UPLC.DeBruijn PLC.DefaultUni PLC.DefaultFun ()) -> Text
 showEvalException = T.pack . show

cabal.project

@@ -1,8 +1,9 @@
-index-state: 2022-01-03T00:00:00Z
-
-allow-newer: size-based:template-haskell
+allow-newer: *:*
 
 package plutus-tx-plugin
   flags: +use-ghc-stub
 
 packages: ./.
+
+constraints:
+  aeson > 2