ghc-tcplugin-api 0.7.1.0 → 0.8.0.0

raw patch · 5 files changed

+136/−59 lines, 5 filesdep ~basedep ~ghcPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, ghc

API changes (from Hackage documentation)

Files

• changelog.md +10/−0
• ghc-tcplugin-api.cabal +4/−6
• src/GHC/TcPlugin/API.hs +71/−11
• src/GHC/TcPlugin/API/Internal.hs +3/−14
• src/GHC/TcPlugin/API/Names.hs +48/−28

@@ -1,4 +1,14 @@ 
+# Version 0.8.0.0 (2022-07-07)
+
+- Compatibility for GHC 9.4.
+
+- Change API for `lookupImportedModule` to use `PkgQual` and `UnitId`
+  instead of `Maybe FastString`, with back-compatibility function `pkgQual_pkg`
+  for use with older module lookup functions.
+
+- Re-export `splitAppTys` and `unpackFS`.
+
 # Version 0.7.1.0 (2022-01-04)
 
 - `newWanted` now always uses the `CtLoc` information that it is provided with,

@@ -1,6 +1,6 @@ cabal-version:  3.0
 name:           ghc-tcplugin-api
-version:        0.7.1.0
+version:        0.8.0.0
 synopsis:       An API for type-checker plugins.
 license:        BSD-3-Clause
 build-type:     Simple
@@ -33,9 +33,9 @@ 
   build-depends:
     base
-      >= 4.13.0 && < 4.18,
+      >= 4.13.0 && < 4.19,
     ghc
-      >= 8.8    && < 9.5,
+      >= 8.8    && < 9.7,
     transformers
       >= 0.5    && < 0.6,
 
@@ -71,12 +71,10 @@   if impl(ghc >= 9.3.0)
     cpp-options: -DHAS_REWRITING
   else
+    cpp-options: -DHAS_DERIVEDS
     other-modules:
       GHC.TcPlugin.API.Internal.Shim
       GHC.TcPlugin.API.Internal.Shim.Reduction
-
-  if impl(ghc < 9.5.0)
-    cpp-options: -DHAS_DERIVEDS
 
   -- Compatibility for versions of GHC prior to 9.0.
   if impl(ghc < 9.0)

@@ -3,6 +3,7 @@ {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE UndecidableInstances #-}
 
@@ -98,8 +99,9 @@ 
     -- | Use these functions to lookup a module,
     -- from the current package or imported packages.
-  , findImportedModule, fsLit, mkModuleName
-  , Module, ModuleName, FindResult(..)
+  , findImportedModule, fsLit, unpackFS, mkModuleName
+  , unitIdFS, stringToUnitId, pkgQual_pkg
+  , Module, ModuleName, FindResult(..), UnitId, PkgQual(..)
 
     -- ** Names
 
@@ -379,7 +381,7 @@   , mkTyConTy, mkTyConApp, mkAppTy, mkAppTys
   , splitTyConApp_maybe
   , tyConAppTyConPicky_maybe, tyConAppTyCon_maybe
-  , splitAppTy_maybe
+  , splitAppTy_maybe, splitAppTys
 
     -- ** Function types
   , mkVisFunTyMany, mkVisFunTysMany
@@ -545,7 +547,7 @@   )
 import GHC.Core.Type
   ( eqType, mkTyConTy, mkTyConApp, splitTyConApp_maybe
-  , splitAppTy_maybe
+  , splitAppTy_maybe, splitAppTys
   , tyConAppTyConPicky_maybe, tyConAppTyCon_maybe
   , mkAppTy, mkAppTys, isTyVarTy, getTyVar_maybe
   , mkCoercionTy, isCoercionTy, isCoercionTy_maybe
@@ -555,7 +557,7 @@ #endif
   )
 import GHC.Data.FastString
-  ( FastString, fsLit )
+  ( FastString, fsLit, unpackFS )
 import qualified GHC.Tc.Plugin
   as GHC
 import GHC.Tc.Types
@@ -606,6 +608,10 @@   ( OccName(..)
   , mkVarOcc, mkDataOcc, mkTyVarOcc, mkTcOcc, mkClsOcc
   )
+#if MIN_VERSION_ghc(9,3,0)
+import GHC.Types.PkgQual
+  ( PkgQual(..) )
+#endif
 import GHC.Types.SrcLoc
   ( GenLocated(..), Located, RealLocated
   , unLoc, getLoc
@@ -632,6 +638,9 @@ #if !MIN_VERSION_ghc(9,2,0)
   , panic, pprPanic
 #endif
+#if !MIN_VERSION_ghc(9,3,0)
+  , (<+>), doubleQuotes, empty, text
+#endif
   )
 #if MIN_VERSION_ghc(9,2,0)
 import GHC.Utils.Panic
@@ -645,9 +654,14 @@   ( FindResult(..) )
 #endif
 import GHC.Unit.Module
-  ( mkModuleName )
+  ( UnitId, unitIdFS, stringToUnitId, mkModuleName )
+#if MIN_VERSION_ghc(9,5,0)
+import Language.Haskell.Syntax.Module.Name
+  ( ModuleName )
+#else
 import GHC.Unit.Module.Name
   ( ModuleName )
+#endif
 import GHC.Unit.Types
   ( Module )
 
@@ -676,13 +690,54 @@ 
 --------------------------------------------------------------------------------
 
+#if !MIN_VERSION_ghc(9,3,0)
+-- | Package-qualifier after renaming
+data PkgQual
+  = NoPkgQual       -- ^ No package qualifier
+  | ThisPkg  UnitId -- ^ Import from home-unit
+  | OtherPkg UnitId -- ^ Import from another unit
+  deriving stock ( Ord, Eq )
+
+instance Outputable PkgQual where
+  ppr = \case
+    NoPkgQual  -> empty
+    ThisPkg  u -> doubleQuotes (ppr u)
+    OtherPkg u -> doubleQuotes (ppr u)
+#endif
+
+-- | Compatibility function to convert a 'PkgQual' to @Maybe FastString@
+-- on older versions of GHC (9.2 and below).
+--
+-- On newer GHCs, this is the identity function.
+pkgQual_pkg :: PkgQual
+#if MIN_VERSION_ghc(9,3,0)
+            -> PkgQual
+#else
+            -> Maybe FastString
+#endif
+pkgQual_pkg pkg =
+#if MIN_VERSION_ghc(9,3,0)
+  pkg
+#else
+  case pkg of
+    NoPkgQual        -> Nothing
+    ThisPkg  this    ->
+      let fs = unitIdFS this
+      in if fs == fsLit "this"
+      then Just fs
+      else pprPanic "pkgQual_pkg: \'ThisPkg\' package name should be \"this\"" (text "pkg:" <+> ppr pkg)
+    OtherPkg unit_id -> Just $ unitIdFS unit_id
+#endif
+
 -- | Lookup a Haskell module from the given package.
 findImportedModule :: MonadTcPlugin m
                    => ModuleName -- ^ Module name, e.g. @"Data.List"@.
-                   -> Maybe FastString -- ^ Package name, e.g. @Just "base"@.
-                                       -- Use @Nothing@ for the current home package
+                   -> PkgQual -- ^ Package name, e.g. @Just "base"@.
+                              -- Use @Nothing@ for the current home package
                    -> m FindResult
-findImportedModule mod_name mb_pkg = liftTcPluginM $ GHC.findImportedModule mod_name mb_pkg
+findImportedModule mod_name pkg
+  = liftTcPluginM
+  $ GHC.findImportedModule mod_name (pkgQual_pkg pkg)
 
 -- | Obtain the full internal 'Name' (with its unique identifier, etc) from its 'OccName'.
 --
@@ -820,7 +875,12 @@ -- so that newly emitted constraints can be given
 -- the same location information.
 rewriteEnvCtLoc :: RewriteEnv -> CtLoc
-rewriteEnvCtLoc = fe_loc
+rewriteEnvCtLoc =
+#if MIN_VERSION_ghc(9,3,0)
+  re_loc
+#else
+  fe_loc
+#endif
 
 -- | Set the location information for a computation.
 setCtLocM :: MonadTcPluginWork m => CtLoc -> m a -> m a
@@ -829,7 +889,7 @@ -- | Use the 'RewriteEnv' to set the 'CtLoc' for a computation.
 setCtLocRewriteM :: TcPluginM Rewrite a -> TcPluginM Rewrite a
 setCtLocRewriteM ma = do
-  rewriteCtLoc <- fe_loc <$> askRewriteEnv
+  rewriteCtLoc <- rewriteEnvCtLoc <$> askRewriteEnv
   setCtLocM rewriteCtLoc ma
 
 --------------------------------------------------------------------------------

@@ -347,12 +347,9 @@       ->
         GHC.unsafeTcPluginTcM $ runInTcM
 #ifdef HAS_REWRITING
+  -- (no deriveds)
           ( GHC.runTcPluginM
-#ifdef HAS_DERIVEDS
-          . ( \ f -> f builtinDefs evBinds deriveds )
-#else
           . ( \ f -> f builtinDefs evBinds )
-#endif
           . tcPluginSolveM )
 #else
           ( ( `GHC.runTcPluginM` evBinds )
@@ -419,22 +416,14 @@       pure ( TcPluginDefs { tcPluginBuiltinDefs, tcPluginUserDefs })
 
 #ifdef HAS_REWRITING
+  -- (no deriveds)
     adaptUserSolve :: ( userDefs -> TcPluginSolver )
                    -> TcPluginDefs userDefs
-                   -> GHC.EvBindsVar
                    -> GHC.TcPluginSolver
     adaptUserSolve userSolve ( TcPluginDefs { tcPluginUserDefs, tcPluginBuiltinDefs } )
-     evBindsVar
-#ifdef HAS_DERIVEDS
-      = \ givens deriveds wanteds -> do
-        tcPluginSolveM ( userSolve tcPluginUserDefs givens wanteds )
-          tcPluginBuiltinDefs evBindsVar deriveds
-#else
-      = \ givens _deriveds wanteds -> do
+      = \ evBindsVar givens wanteds -> do
         tcPluginSolveM ( userSolve tcPluginUserDefs givens wanteds )
           tcPluginBuiltinDefs evBindsVar
-#endif
-
     adaptUserRewrite :: ( userDefs -> GHC.UniqFM GHC.TyCon TcPluginRewriter )
                      -> TcPluginDefs userDefs -> GHC.UniqFM GHC.TyCon GHC.TcPluginRewriter
     adaptUserRewrite userRewrite ( TcPluginDefs { tcPluginUserDefs, tcPluginBuiltinDefs })

@@ -137,10 +137,17 @@ import GHC.Driver.Session
   ( DynFlags )
 #endif
-import GHC.Utils.Panic
-  ( pgmErrorDoc )
+#if MIN_VERSION_ghc(9,5,0)
+import Language.Haskell.Syntax.Module.Name
+  ( moduleNameString )
+#else
 import GHC.Unit.Module.Name
   ( moduleNameString )
+#endif
+import GHC.Unit.Types
+  ( unitIdString )
+import GHC.Utils.Panic
+  ( pgmErrorDoc )
 import GHC.Tc.Plugin
   ( getTopEnv )
 import GHC.Types.Unique.FM
@@ -163,8 +170,7 @@       -- | Name of the module in which the thing can be found.
     , module' :: ModuleName
       -- | Name of the package in which the module can be found.
-      -- Use 'Nothing' to signify the current home package.
-    , package :: Maybe FastString
+    , package :: PkgQual
     }
 
 -- | Type-level parameter to 'Wear' type family, for higher-kinded data.
@@ -312,7 +318,7 @@          res
     .  ( Coercible res ( Generically1 f Resolved ), MonadTcPlugin m )
     => Generically1 f Named -> m res
-  resolve_names dat
+  resolve_names ( Generically1 dat )
     =  ( `evalStateT` emptyModules )
     $  coerce . to @(f Resolved)
    <$> gtraverseC @ResolveName resolveName ( from dat )
@@ -342,8 +348,8 @@             => 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
+resolveName (Qualified str mod_name pkg) = do
+  md <- lookupModule pkg mod_name
   nm <- lift $ lookupOrig md
                  (mkOccName
 #if !MIN_VERSION_ghc(9,0,0)
@@ -363,41 +369,55 @@ 
 data ImportedModules
   = ImportedModules
-    { home_modules :: UniqFM ModuleName Module
-    , pkg_modules  :: UniqFM FastString ( UniqFM ModuleName Module )
+    { home_modules      :: UniqFM ModuleName Module
+    , this_pkg_modules  :: UniqFM UnitId ( UniqFM ModuleName Module )
+    , other_pkg_modules :: UniqFM UnitId ( UniqFM ModuleName Module )
     }
 
 emptyModules :: ImportedModules
-emptyModules = ImportedModules emptyUFM emptyUFM
+emptyModules =
+  ImportedModules
+    { home_modules      = emptyUFM
+    , this_pkg_modules  = emptyUFM
+    , other_pkg_modules = emptyUFM
+    }
 
-lookupCachedModule :: Monad m => Maybe FastString -> ModuleName -> StateT ImportedModules m (Maybe Module)
-lookupCachedModule Nothing    mod_name
+lookupCachedModule :: Monad m => PkgQual -> ModuleName -> StateT ImportedModules m (Maybe Module)
+lookupCachedModule NoPkgQual    mod_name
   =   ( `lookupUFM` mod_name )
   .   home_modules
   <$> get
-lookupCachedModule (Just pkg) mod_name
+lookupCachedModule (ThisPkg pkg) mod_name
   =   ( ( `lookupUFM` mod_name ) =<< )
   .   ( `lookupUFM` pkg )
-  .   pkg_modules
+  .   this_pkg_modules
   <$> get
+lookupCachedModule (OtherPkg pkg) mod_name
+  =   ( ( `lookupUFM` mod_name ) =<< )
+  .   ( `lookupUFM` pkg )
+  .   other_pkg_modules
+  <$> get
 
-insertCachedModule :: Monad m => Maybe FastString -> ModuleName -> Module -> StateT ImportedModules m ()
-insertCachedModule Nothing    mod_name md = do
+insertCachedModule :: Monad m => PkgQual -> ModuleName -> Module -> StateT ImportedModules m ()
+insertCachedModule NoPkgQual    mod_name md = do
   mods@( ImportedModules { home_modules = prev } ) <- get
   put $ mods { home_modules = addToUFM prev mod_name md }
-insertCachedModule (Just pkg) mod_name md = do
-  mods@( ImportedModules { pkg_modules = prev } ) <- get
-  put $ mods { pkg_modules = addToUFM_C plusUFM prev pkg (unitUFM mod_name md) }
+insertCachedModule (ThisPkg pkg) mod_name md = do
+  mods@( ImportedModules { this_pkg_modules = prev } ) <- get
+  put $ mods { this_pkg_modules = addToUFM_C plusUFM prev pkg (unitUFM mod_name md) }
+insertCachedModule (OtherPkg pkg) mod_name md = do
+  mods@( ImportedModules { other_pkg_modules = prev } ) <- get
+  put $ mods { other_pkg_modules = addToUFM_C plusUFM prev pkg (unitUFM mod_name md) }
 
-lookupModule :: MonadTcPlugin m => Maybe FastString -> ModuleName -> StateT ImportedModules m Module
-lookupModule mb_pkg mod_name = do
-  cachedResult <- lookupCachedModule mb_pkg mod_name
+lookupModule :: MonadTcPlugin m => PkgQual -> ModuleName -> StateT ImportedModules m Module
+lookupModule pkg mod_name = do
+  cachedResult <- lookupCachedModule pkg mod_name
   case cachedResult of
     Just res -> do
-      insertCachedModule mb_pkg mod_name res
+      insertCachedModule pkg mod_name res
       pure res
     Nothing -> do
-      findResult <- lift $ findImportedModule mod_name mb_pkg
+      findResult <- lift $ findImportedModule mod_name pkg
       case findResult of
         Found _ res
           -> pure res
@@ -417,9 +437,10 @@             err_doc
   where
     pkg_name, mod_str :: String
-    pkg_name = case mb_pkg of
-      Just pkg -> "package " <> show pkg
-      Nothing  -> "home package"
+    pkg_name = case pkg of
+      NoPkgQual     -> "home package"
+      ThisPkg unit  -> "home-unit package " <> unitIdString unit
+      OtherPkg unit -> "other unit package" <> unitIdString unit
     mod_str = moduleNameString mod_name
 
 --------------------------------------------------------------------------------
@@ -470,5 +491,4 @@ -- Generic instances can be derived for type constructors via
 -- @'Generically1' F@ using @-XDerivingVia@.
 newtype Generically1 (f :: k -> Type) (a :: k) = Generically1 ( f a )
-  deriving newtype Generic
 #endif