ghc-tcplugin-api 0.5.1.0 → 0.6.0.0

raw patch · 7 files changed

+171/−58 lines, 7 filesdep ~basedep ~ghcPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, ghc

API changes (from Hackage documentation)

Files

• changelog.md +6/−0
• ghc-tcplugin-api.cabal +12/−3
• src/GHC/TcPlugin/API.hs +63/−8
• src/GHC/TcPlugin/API/Internal.hs +3/−7
• src/GHC/TcPlugin/API/Internal/Shim.hs +28/−12
• src/GHC/TcPlugin/API/Internal/Shim/Reduction.hs +24/−2
• src/GHC/TcPlugin/API/Names.hs +35/−26

@@ -1,4 +1,10 @@ 
+# Version 0.6.0.0 (2021-12-13)
+
+- Add support for GHC 8.8.
+
+- Re-export `evDataConApp`, which is useful for constructing typeclass dictionaries.
+
 # Version 0.5.1.0 (2021-08-31)
 
 - Fix a bug in the type-family rewriting compatibility layer (GHC 8.10, 9.0, 9.2)

@@ -1,6 +1,6 @@ cabal-version:  3.0
 name:           ghc-tcplugin-api
-version:        0.5.1.0
+version:        0.6.0.0
 synopsis:       An API for type-checker plugins.
 license:        BSD-3-Clause
 build-type:     Simple
@@ -33,9 +33,9 @@ 
   build-depends:
     base
-      >= 4.14.0 && < 4.18,
+      >= 4.13.0 && < 4.18,
     ghc
-      >= 8.10   && < 9.5,
+      >= 8.8   && < 9.5,
     transformers
       >= 0.5    && < 0.6,
 
@@ -140,4 +140,13 @@           ( Predicate  as GHC.Core.Predicate
           , Constraint as GHC.Tc.Types.Constraint
           , TcOrigin   as GHC.Tc.Types.Origin
+          )
+
+    else
+
+      mixins:
+        ghc
+          ( Type      as GHC.Core.Predicate
+          , TcRnTypes as GHC.Tc.Types.Constraint
+          , TcRnTypes as GHC.Tc.Types.Origin
           )

@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE PatternSynonyms #-}
@@ -251,6 +252,7 @@     -- by combining evidence that is already available.
 
   , mkPluginUnivEvTerm
+  , evDataConApp
   , newEvVar, setEvBind
   , evCoercion, evCast
   , ctEvExpr
@@ -419,7 +421,9 @@   , FastString
 
     -- | == Constraints
-  , Pred(..), EqRel(..), FunDep, CtFlavour
+  , Pred
+  , pattern ClassPred, pattern EqPred, pattern IrredPred, pattern ForAllPred
+  , EqRel(..), FunDep, CtFlavour
   , Ct, CtLoc, CtEvidence, CtOrigin
   , QCInst
   , Type, PredType
@@ -451,7 +455,10 @@   ( Class(..), FunDep )
 import GHC.Core.Coercion
   ( mkReflCo, mkSymCo, mkTransCo
-  , mkUnivCo, mkPrimEqPredRole
+  , mkUnivCo
+#if MIN_VERSION_ghc(8,10,0)
+  , mkPrimEqPredRole
+#endif
   )
 import GHC.Core.Coercion.Axiom
   ( Role(..) )
@@ -465,7 +472,13 @@   ( InstEnvs(..) )
 import GHC.Core.Make
 import GHC.Core.Predicate
-  ( Pred(..), EqRel(..)
+  ( EqRel(..)
+#if MIN_VERSION_ghc(8,10,0)
+  , Pred(..)
+#else
+  , PredTree(..), TyCoBinder
+  , mkPrimEqPred, mkReprPrimEqPred
+#endif
   , classifyPredType, mkClassPred
   )
 #if HAS_REWRITING
@@ -478,11 +491,15 @@   ( Type, PredType, Kind
   , Coercion(..), CoercionHole(..)
   , UnivCoProvenance(..)
+#if MIN_VERSION_ghc(8,10,0)
   , AnonArgFlag(..)
+  , mkVisFunTy, mkInvisFunTy, mkVisFunTys
+  , mkPiTy
+#endif
+  , mkPiTys
   , mkTyVarTy, mkTyVarTys
-  , mkFunTy, mkVisFunTy, mkInvisFunTy, mkVisFunTys
   , mkForAllTy, mkForAllTys
-  , mkPiTy, mkPiTys
+  , mkFunTy
 #if MIN_VERSION_ghc(9,0,0)
   , Mult
   , mkFunTyMany
@@ -520,7 +537,7 @@   )
 import GHC.Tc.Types.Evidence
   ( EvBind(..), EvTerm(..), EvExpr, EvBindsVar(..)
-  , evCoercion, evCast, lookupEvBind
+  , evCoercion, evCast, lookupEvBind, evDataConApp
   )
 import GHC.Tc.Types.Origin
   ( CtOrigin(..) )
@@ -557,7 +574,11 @@   , mkTyVar
   )
 import GHC.Utils.Outputable
-  ( Outputable(..), SDoc )
+  ( Outputable(..), SDoc
+#if !MIN_VERSION_ghc(8,10,0)
+  , panic
+#endif
+  )
 #if MIN_VERSION_ghc(9,2,0)
 import GHC.Unit.Finder
   ( FindResult(..) )
@@ -828,4 +849,38 @@ 
 type UniqFM ty a = GHC.UniqFM a
 
-#endif+#endif
+
+#if !MIN_VERSION_ghc(8,10,0)
+
+-- | The non-dependent version of 'ArgFlag'.
+-- See Note [AnonArgFlag]
+-- Appears here partly so that it's together with its friends ArgFlag
+-- and ForallVisFlag, but also because it is used in IfaceType, rather
+-- early in the compilation chain
+data AnonArgFlag
+  = VisArg    -- ^ Used for @(->)@: an ordinary non-dependent arrow.
+              --   The argument is visible in source code.
+  | InvisArg  -- ^ Used for @(=>)@: a non-dependent predicate arrow.
+              --   The argument is invisible in source code.
+  deriving stock (Eq, Ord)
+
+type Pred = PredTree
+
+mkVisFunTy, mkInvisFunTy :: Type -> Type -> Type
+mkVisFunTy   = mkFunTy
+mkInvisFunTy = mkFunTy
+
+mkVisFunTys :: [Type] -> Type -> Type
+mkVisFunTys tys ty = foldr mkFunTy ty tys
+
+mkPiTy :: TyCoBinder -> Type -> Type
+mkPiTy bndr ty = mkPiTys [bndr] ty
+
+-- | Makes a lifted equality predicate at the given role
+mkPrimEqPredRole :: Role -> Type -> Type -> PredType
+mkPrimEqPredRole Nominal          = mkPrimEqPred
+mkPrimEqPredRole Representational = mkReprPrimEqPred
+mkPrimEqPredRole Phantom          = panic "mkPrimEqPredRole phantom"
+
+#endif

@@ -10,7 +10,6 @@ {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneKindSignatures #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 
@@ -63,7 +62,7 @@ import Data.Coerce
   ( Coercible )
 import Data.Kind
-  ( Constraint, Type )
+  ( Type )
 import GHC.TypeLits
   ( TypeError, ErrorMessage(..) )
 
@@ -230,8 +229,7 @@ 
 -- | The monad used for a type-checker plugin, parametrised by
 -- the 'TcPluginStage' of the plugin.
-type TcPluginM :: TcPluginStage -> ( Type -> Type )
-data family TcPluginM s
+data family TcPluginM (s :: TcPluginStage) :: Type -> Type
 newtype instance TcPluginM Init a =
   TcPluginInitM { tcPluginInitM :: GHC.TcPluginM a }
   deriving newtype ( Functor, Applicative, Monad )
@@ -293,8 +291,7 @@ --
 -- Note that you must import the internal module in order to access the methods.
 -- Please report a bug if you find yourself needing this functionality.
-type  MonadTcPlugin :: ( Type -> Type ) -> Constraint
-class ( Monad m, ( forall x y. Coercible x y => Coercible (m x) (m y) ) ) => MonadTcPlugin m where
+class ( Monad m, ( forall x y. Coercible x y => Coercible (m x) (m y) ) ) => MonadTcPlugin (m :: Type -> Type) where
 
   {-# MINIMAL liftTcPluginM, unsafeWithRunInTcM #-}
 
@@ -479,7 +476,6 @@ --
 -- See 'mkTcPluginErrorTy' and 'GHC.TcPlugin.API.emitWork' for functions
 -- which require this typeclass.
-type  MonadTcPluginWork :: ( Type -> Type ) -> Constraint
 class MonadTcPlugin m => MonadTcPluginWork m where
   {-# MINIMAL #-} -- to avoid the methods appearing in the haddocks
   askBuiltins :: m BuiltinDefs

@@ -364,13 +364,15 @@ 
 rewrite_one
   (FunTy
-    { ft_af = vis
+#if MIN_VERSION_ghc(8,10,0)
+    vis
+#endif
 #if MIN_VERSION_ghc(9,0,0)
-    , ft_mult = mult
+    mult
 #endif
-    , ft_arg = ty1
-    , ft_res = ty2
-    })
+    ty1
+    ty2
+  )
   = do { arg_redn <- rewrite_one ty1
        ; res_redn <- rewrite_one ty2
 #if MIN_VERSION_ghc(9,0,0)
@@ -380,7 +382,9 @@        ; return $
            mkFunRedn
              role
+#if MIN_VERSION_ghc(8,10,0)
              vis
+#endif
 #if MIN_VERSION_ghc(9,0,0)
              w_redn
 #endif
@@ -676,17 +680,20 @@     in  (Named b : bs, ty', True)
   split _
     (FunTy
-      { ft_af = af
+#if MIN_VERSION_ghc(8,10,0)
+      af
+#endif
 #if MIN_VERSION_ghc(9,0,0)
-      , ft_mult = w
+      w
 #endif
-      , ft_arg = arg
-      , ft_res = res
-      }
+      arg
+      res
     ) =
     let !(bs, ty', named) = split res res
     in  ( Anon
+#if MIN_VERSION_ghc(8,10,0)
           af
+#endif
 #if MIN_VERSION_ghc(9,0,0)
           (mkScaled w arg)
 #else
@@ -704,8 +711,17 @@   where
     go (Bndr tv (NamedTCB vis)) (bndrs, _)
       = (Named (Bndr tv vis) : bndrs, True)
-    go (Bndr tv (AnonTCB af))   (bndrs, n)
-      = (Anon af
+    go (Bndr tv
+         (AnonTCB
+#if MIN_VERSION_ghc(8,10,0)
+           af
+#endif
+         )
+       )   (bndrs, n)
+      = (Anon
+#if MIN_VERSION_ghc(8,10,0)
+          af
+#endif
           (
 #if MIN_VERSION_ghc(9,0,0)
             tymult

@@ -20,7 +20,11 @@   , mkCoherenceLeftCo, mkNomReflCo
 #endif
   , coercionKind
+#if MIN_VERSION_ghc(8,10,0)
   , coToMCo
+#else
+  , isReflCo
+#endif
   , decomposePiCos, downgradeRole
   , liftCoSubst, emptyLiftingContext, extendLiftingContextAndInScope, zapLiftingContext
   , mkAppCo, mkAppCos
@@ -41,7 +45,10 @@ import GHC.Core.TyCon
   ( TyCon )
 import GHC.Core.Type
-  ( AnonArgFlag, ArgFlag, Kind, Type, TyVar, TyVarBinder
+  ( ArgFlag, Kind, Type, TyVar, TyVarBinder
+#if MIN_VERSION_ghc(8,10,0)
+  , AnonArgFlag
+#endif
   , binderVars
   , mkAppTy, mkAppTys, mkCastTy, mkCoercionTy, mkForAllTy, mkForAllTys
   , mkTyConApp, mkPiTys
@@ -323,14 +330,19 @@ --
 -- Combines 'mkFunCo' and 'mkFunTy'.
 mkFunRedn :: Role
+#if MIN_VERSION_ghc(8,10,0)
           -> AnonArgFlag
+#endif
 #if MIN_VERSION_ghc(9,0,0)
           -> ReductionN -- ^ multiplicity reduction
 #endif
           -> Reduction  -- ^ argument reduction
           -> Reduction  -- ^ result reduction
           -> Reduction
-mkFunRedn r vis
+mkFunRedn r
+#if MIN_VERSION_ghc(8,10,0)
+  vis
+#endif
 #if MIN_VERSION_ghc(9,0,0)
   (Reduction w_co w_ty)
 #endif
@@ -346,7 +358,9 @@             res_co
         )
         ( mkFunTy
+#if MIN_VERSION_ghc(8,10,0)
             vis
+#endif
 #if MIN_VERSION_ghc(9,0,0)
             w_ty
 #endif
@@ -579,4 +593,12 @@            MCo kind_co -> GRefl r (mkCastTy t1 h) $
                           MCo (mkSymCo h `mkTransCo` kind_co `mkTransCo` h)
       _ -> castCoercionKind2 g r t1 t2 h h
+#endif
+
+#if !MIN_VERSION_ghc(8,10,0)
+
+coToMCo :: Coercion -> MCoercion
+coToMCo co | isReflCo co = MRefl
+           | otherwise   = MCo co
+
 #endif

@@ -12,12 +12,15 @@ {-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneKindSignatures #-}
 {-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 {-# LANGUAGE UndecidableInstances #-}
 
+#if MIN_VERSION_ghc(9,0,0)
+{-# LANGUAGE StandaloneKindSignatures #-}
+#endif
+
 {-|
 Module: GHC.TcPlugin.API.Names
 
@@ -153,8 +156,7 @@ 
 -- | A 'QualifiedName' is the name of something,
 -- together with the names of the module and package it comes from.
-type QualifiedName :: k -> Type
-data QualifiedName thing
+data QualifiedName (thing :: Type)
   = Qualified
     { -- | Name of the thing (e.g. name of the 'TyCon' or 'Class').
       name    :: String
@@ -177,8 +179,7 @@ data NameResolution = Named | Resolved
 
 -- | Use this to refer to a @Promoted DataCon@.
-type Promoted :: k -> Type
-data Promoted thing
+data Promoted (thing :: k) :: Type
 
 -- | Type-family used for higher-kinded data pattern.
 --
@@ -197,9 +198,15 @@ -- (a typeclass name and a type-constructor name, with associated module & packages),
 -- whereas a record of type @MyData Resolved@ contains a typeclass's @Class@
 -- as well as a type-constructor's @TyCon@.
+#if MIN_VERSION_ghc(9,0,0)
 type Wear :: forall k. NameResolution -> k -> Type
-type family Wear n thing where
-  Wear Named    thing              = QualifiedName thing
+#endif
+type family Wear (n :: NameResolution) (thing :: k) :: Type where
+#if MIN_VERSION_ghc(9,0,0)
+  Wear @Type Named thing           = QualifiedName thing
+#else
+  Wear Named thing                 = QualifiedName thing
+#endif
   Wear Resolved (Promoted DataCon) = TyCon
   Wear Resolved (Promoted a)
     = TypeError
@@ -210,8 +217,7 @@ 
 -- | Retrieve the underlying thing being referred to by inspecting
 -- the type parameter of 'QualifiedName'.
-type UnwearNamed :: Type -> Type
-type family UnwearNamed loc where
+type family UnwearNamed (loc :: Type) :: Type where
   UnwearNamed (QualifiedName thing) = thing
 
 -- | Type-class overloading things that can be looked up by name:
@@ -222,7 +228,7 @@ #if MIN_VERSION_ghc(9,0,0)
 type Lookupable :: forall {k}. k -> Constraint
 #endif
-class Lookupable a where
+class Lookupable (a :: k) where
   mkOccName :: String -> OccName
   lookup :: MonadTcPlugin m => Name -> m (Wear Resolved a)
 
@@ -274,8 +280,7 @@ --
 -- This returns a record containing the looked up things we want,
 -- e.g. @myClass :: Class@, @myPromDataCon :: TyCon@, etc.
-type ResolveNames :: ( NameResolution -> Type ) -> Constraint
-class ResolveNames f where
+class ResolveNames (f :: NameResolution -> Type) where
   resolve_names :: ( Coercible res ( f Resolved ), MonadTcPlugin m )
                 => f Named -> m res
   -- Workaround: the result is anything coercible to "f Resolved" rather than just "f Resolved",
@@ -321,27 +326,37 @@ -- which allows one to write 'resolveName':
 --
 -- > resolveName :: ... => Wear Named thing -> m ( Wear Resolved thing )
-type     ResolveName :: Type -> Type -> Constraint
 class    ( a ~ Wear Named    ( UnwearNamed a )
          , b ~ Wear Resolved ( UnwearNamed a )
          , Lookupable ( UnwearNamed a )
          )
-      => ResolveName a b
+      => ResolveName (a :: Type) (b :: Type)
 instance ( a ~ Wear Named    ( UnwearNamed a )
          , b ~ Wear Resolved ( UnwearNamed a )
          , Lookupable ( UnwearNamed a )
          )
       => ResolveName a b
 
-resolveName :: forall thing m
+resolveName :: forall (thing :: Type) m
             .  ResolveName ( Wear Named thing ) ( Wear Resolved thing )
             => MonadTcPlugin m
             => Wear Named thing
             -> StateT ImportedModules m ( Wear Resolved thing )
 resolveName (Qualified str mod_name mb_pkg) = do
   md <- lookupModule mb_pkg mod_name
-  nm <- lift $ lookupOrig md (mkOccName @thing str)
-  lift $ lookup @thing nm
+  nm <- lift $ lookupOrig md
+                 (mkOccName
+#if !MIN_VERSION_ghc(9,0,0)
+                   @_
+#endif
+                   @thing
+                   str
+                 )
+  lift $ lookup
+#if !MIN_VERSION_ghc(9,0,0)
+           @_
+#endif
+           @thing nm
 
 --------------------------------------------------------------------------------
 -- Caching of found modules.
@@ -410,16 +425,11 @@ --------------------------------------------------------------------------------
 -- Constrained traversals.
 
-type TraversalC :: ( Type -> Type -> Constraint ) -> Type -> Type -> Type
-type TraversalC c s t
+type TraversalC (c :: Type -> Type -> Constraint) (s :: Type)  (t :: Type)
   =  forall f. ( Applicative f )
   => ( forall a b. c a b => a -> f b ) -> s -> f t
 
-type GTraversableC :: ( Type -> Type -> Constraint )
-                   -> ( Type -> Type )
-                   -> ( Type -> Type )
-                   -> Constraint
-class GTraversableC c s t where
+class GTraversableC (c :: Type -> Type -> Constraint) (s :: Type -> Type) (t :: Type -> Type) where
   gtraverseC :: TraversalC c (s x) (t x)
 
 instance
@@ -459,7 +469,6 @@ --
 -- Generic instances can be derived for type constructors via
 -- @'Generically1' F@ using @-XDerivingVia@.
-type    Generically1 :: ( k -> Type ) -> ( k -> Type )
-newtype Generically1 f a = Generically1 ( f a )
+newtype Generically1 (f :: k -> Type) (a :: k) = Generically1 ( f a )
   deriving newtype Generic
 #endif