ghc-tcplugin-api 0.9.0.0 → 0.10.0.0

raw patch · 5 files changed

+110/−97 lines, 5 filesdep +containersPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

API changes (from Hackage documentation)

Files

• changelog.md +6/−0
• ghc-tcplugin-api.cabal +3/−1
• src/GHC/TcPlugin/API.hs +75/−45
• src/GHC/TcPlugin/API/Internal/Shim.hs +5/−5
• src/GHC/TcPlugin/API/Names.hs +21/−46

@@ -1,3 +1,9 @@+# Version 0.10.0.0 (2023-02-28)
+
+- Introduce `resolveImport`, and make `PkgQual` opaque.
+- Rename `tcRewriterWanteds` to `tcRewriterNewWanteds`
+  (bringing it in line with nomenclature in ghc 9.4).
+
 # Version 0.9.0.0 (2023-01-24)
 
 - Add support for GHC 9.6 and `transformers` 0.6.

@@ -1,6 +1,6 @@ cabal-version:  3.0
 name:           ghc-tcplugin-api
-version:        0.9.0.0
+version:        0.10.0.0
 synopsis:       An API for type-checker plugins.
 license:        BSD-3-Clause
 build-type:     Simple
@@ -34,6 +34,8 @@   build-depends:
     base
       >= 4.13.0 && < 4.19,
+    containers
+      >= 0.6    && < 0.7,
     ghc
       >= 8.8    && < 9.7,
     transformers

@@ -3,6 +3,7 @@ {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE PatternSynonyms #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -83,7 +84,10 @@     --
     -- > lookupMyModule :: MonadTcPlugin m => m Module
     -- > lookupMyModule = do
-    -- >    findResult <- findImportedModule ( mkModuleName "MyModule" ) ( Just $ fsLit "my-pkg" )
+    -- >    let modlName = mkModuleName "MyModule"
+    -- >        pkgName  = Just $ fsLit "my-pkg"
+    -- >    pkgQual    <- resolveImport      modlName pkgName
+    -- >    findResult <- findImportedModule modlName pkgQual
     -- >    case findResult of
     -- >      Found _ myModule -> pure myModule
     -- >      _ -> error "MyPlugin couldn't find MyModule in my-pkg"
@@ -99,9 +103,9 @@ 
     -- | Use these functions to lookup a module,
     -- from the current package or imported packages.
-  , findImportedModule, fsLit, unpackFS, mkModuleName
-  , unitIdFS, stringToUnitId, pkgQual_pkg
-  , Module, ModuleName, FindResult(..), UnitId, PkgQual(..)
+  , findImportedModule, resolveImport, fsLit, unpackFS, mkModuleName
+  , unitIdFS, stringToUnitId, pkgQualToPkgName
+  , Module, ModuleName, FindResult(..), UnitId, PkgQual
 
     -- ** Names
 
@@ -624,8 +628,19 @@   , mkVarOcc, mkDataOcc, mkTyVarOcc, mkTcOcc, mkClsOcc
   )
 #if MIN_VERSION_ghc(9,3,0)
+import GHC
+  ( HscEnv )
 import GHC.Types.PkgQual
   ( PkgQual(..) )
+import GHC.Rename.Names
+  ( renamePkgQual )
+import GHC.Driver.Env
+  ( hsc_unit_env )
+import GHC.Unit.Module
+  ( unitIdString )
+#elif MIN_VERSION_ghc(9,1,0)
+import GHC.Data.FastString
+  ( NonDetFastString(NonDetFastString) )
 #endif
 import GHC.Types.SrcLoc
   ( GenLocated(..), Located, RealLocated
@@ -653,9 +668,6 @@ #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
@@ -723,54 +735,72 @@ 
 --------------------------------------------------------------------------------
 
-#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 )
+#if MIN_VERSION_ghc(9,3,0)
 
-instance Outputable PkgQual where
-  ppr = \case
-    NoPkgQual  -> empty
-    ThisPkg  u -> doubleQuotes (ppr u)
-    OtherPkg u -> doubleQuotes (ppr u)
+-- Use PkgQual from ghc itself
+
+#elif MIN_VERSION_ghc(9,1,0)
+
+newtype PkgQual = PkgQual (Maybe NonDetFastString)
+  deriving stock ( Eq, Ord )
+  deriving newtype ( Outputable )
+
+-- | INTERNAL: Unwrap 'PkgQual'
+getPkgQual :: PkgQual -> Maybe FastString
+getPkgQual (PkgQual Nothing)                       = Nothing
+getPkgQual (PkgQual (Just (NonDetFastString pkg))) = Just pkg
+
+#else
+
+newtype PkgQual = PkgQual (Maybe FastString)
+  deriving stock ( Eq, Ord )
+  deriving newtype ( Outputable )
+
+-- | INTERNAL: Unwrap 'PkgQual'
+getPkgQual :: PkgQual -> Maybe FastString
+getPkgQual (PkgQual mPkg) = mPkg
+
 #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
+-- | Get package name from package qualifier
+pkgQualToPkgName :: PkgQual -> Maybe String
 #if MIN_VERSION_ghc(9,3,0)
-            -> PkgQual
+pkgQualToPkgName NoPkgQual       = Nothing
+pkgQualToPkgName (ThisPkg  unit) = Just $ unitIdString unit
+pkgQualToPkgName (OtherPkg unit) = Just $ unitIdString unit
 #else
-            -> Maybe FastString
+pkgQualToPkgName = fmap unpackFS . getPkgQual
 #endif
-pkgQual_pkg pkg =
+
+-- | Resolve import
+resolveImport :: MonadTcPlugin m
+              => ModuleName        -- ^ Module name to import from
+              -> Maybe FastString  -- ^ Optional package qualifier
+              -> m PkgQual
 #if MIN_VERSION_ghc(9,3,0)
-  pkg
+resolveImport mod_name mPkg = do
+  hscEnv <- getTopEnv
+  return $ renamePkgQual (hsc_unit_env hscEnv) mod_name mPkg
+#elif MIN_VERSION_ghc(9,1,0)
+resolveImport _mod_name mPkg = do
+  return $ PkgQual (NonDetFastString <$> mPkg)
 #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
+resolveImport _mod_name mPkg = do
+  return $ PkgQual mPkg
 #endif
 
--- | Lookup a Haskell module from the given package.
+-- | Lookup a Haskell module, with an optional package qualifier.
 findImportedModule :: MonadTcPlugin m
-                   => ModuleName -- ^ Module name, e.g. @"Data.List"@.
-                   -> PkgQual -- ^ Package name, e.g. @Just "base"@.
-                              -- Use @Nothing@ for the current home package
+                   => ModuleName  -- ^ Module name, e.g. @"Data.List"@
+                   -> PkgQual     -- ^ Package qualifier. See 'resolveImport'
                    -> m FindResult
-findImportedModule mod_name pkg
-  = liftTcPluginM
-  $ GHC.findImportedModule mod_name (pkgQual_pkg pkg)
+#if MIN_VERSION_ghc(9,3,0)
+findImportedModule mod_name pkg = liftTcPluginM $
+    GHC.findImportedModule mod_name pkg
+#else
+findImportedModule mod_name pkg = liftTcPluginM $
+    GHC.findImportedModule mod_name (getPkgQual pkg)
+#endif
 
 -- | Obtain the full internal 'Name' (with its unique identifier, etc) from its 'OccName'.
 --
@@ -811,10 +841,10 @@ 
 --------------------------------------------------------------------------------
 
-{-
+#if MIN_VERSION_ghc(9,3,0)
 getTopEnv :: MonadTcPlugin m => m HscEnv
 getTopEnv = liftTcPluginM GHC.getTopEnv
--}
+#endif
 
 -- | Obtain the current global and local type-checking environments.
 getEnvs :: MonadTcPlugin m => m ( TcGblEnv, TcLclEnv )

@@ -252,8 +252,8 @@   --
   -- The plugin can also emit additional wanted constraints.
   | TcPluginRewriteTo
-    { tcPluginReduction :: !Reduction
-    , tcRewriterWanteds :: [Ct]
+    { tcPluginReduction    :: !Reduction
+    , tcRewriterNewWanteds :: [Ct]
     }
 
 type Rewriter = RewriteEnv -> [Ct] -> [Type] -> TcPluginM TcPluginRewriteResult
@@ -591,8 +591,8 @@       pure ( res, s )
     case rewriteResult of
       TcPluginRewriteTo
-        { tcPluginReduction = redn
-        , tcRewriterWanteds = wanteds
+        { tcPluginReduction    = redn
+        , tcRewriterNewWanteds = wanteds
         } -> addRewriting ( Just redn ) wanteds
       TcPluginNoRewrite { }
           -> addRewriting Nothing []
@@ -668,7 +668,7 @@                 (ReprEq, _rel)  -> rewriting_co1
                 (NomEq, NomEq)  -> rewriting_co1
                 (NomEq, ReprEq) -> mkSubCo rewriting_co1
-          return $ RTRFollowed $ mkReduction rewriting_co rhs_ty 
+          return $ RTRFollowed $ mkReduction rewriting_co rhs_ty
     _other -> return RTRNotFollowed
 
 rewrite_vector :: Kind

@@ -41,7 +41,9 @@ >
 > findMyModule :: MonadTcPlugin m => m Module
 > findMyModule = do
->   findResult <- findImportedModule ( mkModuleName "MyModule" ) Nothing
+>   let modlName = mkModuleName "MyModule"
+>   pkgQual    <- resolveImport      modlName Nothing
+>   findResult <- findImportedModule modlName pkgQual
 >   case findResult of
 >     Found _ res -> pure res
 >     _           -> error $ "MyPlugin: could not find any module named MyModule."
@@ -116,9 +118,14 @@ import GHC.TypeLits
   ( TypeError, ErrorMessage(..) )
 
+-- containers
+import Data.Map
+  ( Map )
+import qualified Data.Map as Map
+
 -- transformers
 import Control.Monad.Trans.State.Strict
-  ( StateT, evalStateT, get, put )
+  ( StateT, evalStateT, get, modify )
 import Control.Monad.Trans.Class
   ( MonadTrans(lift) )
 
@@ -144,14 +151,10 @@ 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
-  ( addToUFM, addToUFM_C, lookupUFM, plusUFM, unitUFM )
 
 -- ghc-tcplugin-api
 import GHC.TcPlugin.API
@@ -367,47 +370,21 @@ --------------------------------------------------------------------------------
 -- Caching of found modules.
 
-data ImportedModules
+newtype ImportedModules
   = ImportedModules
-    { home_modules      :: UniqFM ModuleName Module
-    , this_pkg_modules  :: UniqFM UnitId ( UniqFM ModuleName Module )
-    , other_pkg_modules :: UniqFM UnitId ( UniqFM ModuleName Module )
+    { imported_modules :: Map (PkgQual, ModuleName) Module
     }
 
 emptyModules :: ImportedModules
 emptyModules =
-  ImportedModules
-    { home_modules      = emptyUFM
-    , this_pkg_modules  = emptyUFM
-    , other_pkg_modules = emptyUFM
-    }
+  ImportedModules Map.empty
 
 lookupCachedModule :: Monad m => PkgQual -> ModuleName -> StateT ImportedModules m (Maybe Module)
-lookupCachedModule NoPkgQual    mod_name
-  =   ( `lookupUFM` mod_name )
-  .   home_modules
-  <$> get
-lookupCachedModule (ThisPkg pkg) mod_name
-  =   ( ( `lookupUFM` mod_name ) =<< )
-  .   ( `lookupUFM` pkg )
-  .   this_pkg_modules
-  <$> get
-lookupCachedModule (OtherPkg pkg) mod_name
-  =   ( ( `lookupUFM` mod_name ) =<< )
-  .   ( `lookupUFM` pkg )
-  .   other_pkg_modules
-  <$> get
+lookupCachedModule pkg modl = Map.lookup (pkg, modl) . imported_modules <$> get
 
 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 (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) }
+insertCachedModule pkg modl md = modify $ \mods ->
+   mods{ imported_modules = Map.insert (pkg, modl) md (imported_modules mods) }
 
 lookupModule :: MonadTcPlugin m => PkgQual -> ModuleName -> StateT ImportedModules m Module
 lookupModule pkg mod_name = do
@@ -433,15 +410,13 @@             dflags = hsc_dflags hsc_env
 #endif
           pgmErrorDoc
-            ( "GHC.TcPlugin.API: could not find module " <> mod_str <> " in " <> pkg_name )
+            (    "GHC.TcPlugin.API: could not find module "
+              <> moduleNameString mod_name
+              <> case pkgQualToPkgName pkg of
+                   Just p  -> " in package " <> p
+                   Nothing -> mempty
+            )
             err_doc
-  where
-    pkg_name, mod_str :: String
-    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
 
 --------------------------------------------------------------------------------
 -- Constrained traversals.