diff --git a/changelog.md b/changelog.md --- a/changelog.md +++ b/changelog.md @@ -1,3 +1,38 @@ +# Version 0.15.0.0 (2025-06-03) + +- Remove `tcPluginIO` in favour of new `MonadIO` instance. + To migrate, use `liftIO` instead of `tcPluginIO`. + +- Add `lookupTHName` function, which allows looking up Template Haskell names + in typechecker plugins. Useful in conjunction with `TemplateHaskellQuotes`. + +- Helper functions to construct evidence terms have been adjusted to return + values of type `EvExpr`, rather than `EvTerm`. This makes the functions more + composable, and allows typechecker plugin to provide evidence for quantified + constraints more easily. + + Affected functions: `evDFunApp`, `evDataConApp`, `evCast`. + + To migrate, you will need to manually wrap evidence terms with the + `EvExpr` constructor in places that expect an `EvTerm`. + +- Added `natKind`, `symbolKind` and `charKind` for the kinds of type-level + `Nat`, `Symbol` and `Char`. + +- Added several re-exports from the `ghc` library: + - `isGiven` & `isWanted`. + - `ctEvPred`, `ctEvId`, `ctEvExpr` and `ctEvLoc`. + - `className` & `tyConName`. + - `isEqPred` (unboxed equality) and `isEqClassPred` (boxed equality). + - `evId` & `ctEvId`. + - `typeKind`. + - `nonDetCmpType`. + +- Removed re-exports of `ctev_pred`, `ctev_loc`, `ctev_evar`, and `ctev_dest`. + + Migration: use `ctEvPred` instead of `ctev_pred` and `ctEvLoc` instead of `ctev_loc`. + Uses of `ctev_evar` and `ctev_dest` should be covered by `ctEvEvId` and/or + `ctEvExpr`. # Version 0.14.0.0 (2024-11-28) diff --git a/ghc-tcplugin-api.cabal b/ghc-tcplugin-api.cabal --- a/ghc-tcplugin-api.cabal +++ b/ghc-tcplugin-api.cabal @@ -1,12 +1,12 @@ cabal-version: 3.0 name: ghc-tcplugin-api -version: 0.14.0.0 +version: 0.15.0.0 synopsis: An API for type-checker plugins. license: BSD-3-Clause build-type: Simple author: Sam Derbyshire maintainer: Sam Derbyshire -copyright: 2021-2024 Sam Derbyshire +copyright: 2021-2025 Sam Derbyshire homepage: https://github.com/sheaf/ghc-tcplugin-api category: Type System, GHC, Plugin description: @@ -37,9 +37,11 @@ containers >= 0.6 && < 0.8, ghc - >= 8.8 && < 9.14, + >= 8.8 && < 9.16, transformers >= 0.5 && < 0.7, + template-haskell + >= 2.15 && < 2.25, default-language: Haskell2010 @@ -72,6 +74,11 @@ , GHC.Types.Unique.DSet , GHC.Utils.Outputable + if impl(ghc >= 9.13.0) + -- Don't warn on exports of the form "pattern ClassPred". + -- We can migrate to using "data" when that becomes necessary. + ghc-options: -Wno-pattern-namespace-specifier + if impl(ghc >= 9.3.0) cpp-options: -DHAS_REWRITING else @@ -110,6 +117,8 @@ , DynFlags as GHC.Driver.Session , HscTypes as GHC.Driver.Types + , IfaceEnv as GHC.Iface.Env + , GhcPlugins as GHC.Plugins , TcPluginM as GHC.Tc.Plugin @@ -125,6 +134,7 @@ , Literal as GHC.Types.Literal , Name as GHC.Types.Name , OccName as GHC.Types.Name.Occurrence + , RdrName as GHC.Types.Name.Reader , SrcLoc as GHC.Types.SrcLoc , Unique as GHC.Types.Unique , UniqDFM as GHC.Types.Unique.DFM @@ -152,6 +162,7 @@ ( Predicate as GHC.Core.Predicate , Constraint as GHC.Tc.Types.Constraint , TcOrigin as GHC.Tc.Types.Origin + , GHC.ThToHs as GHC.ThToHs ) else @@ -161,4 +172,5 @@ ( Type as GHC.Core.Predicate , TcRnTypes as GHC.Tc.Types.Constraint , TcRnTypes as GHC.Tc.Types.Origin + , Convert as GHC.ThToHs ) diff --git a/src/GHC/TcPlugin/API.hs b/src/GHC/TcPlugin/API.hs --- a/src/GHC/TcPlugin/API.hs +++ b/src/GHC/TcPlugin/API.hs @@ -1,6 +1,9 @@ {-# LANGUAGE CPP #-} + +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -64,7 +67,6 @@ -- typeclass providing overloading (for operations that work in all stages). , TcPluginStage(..), MonadTcPlugin , TcPluginM - , tcPluginIO -- *** Emitting new work, and throwing type-errors @@ -80,10 +82,23 @@ -- | Name resolution is usually the first step in writing a type-checking plugin: -- plugins need to look up the names of the objects they want to manipulate. -- - -- For instance, to lookup the type family @MyFam@ in module @MyModule@ in package @my-pkg@: + -- The most convenient way to look up a Name is to bring the name into scope + -- in the module defining the plugin, and use @TemplateHaskellQuotes@ + -- in conjunction with the 'lookupTHName' function. -- - -- > lookupMyModule :: MonadTcPlugin m => m Module - -- > lookupMyModule = do + -- > import Data.Maybe + -- > + -- > lookupMaybeTyCon :: MonadTcPluginM m => m TyCon + -- > lookupMaybeTyCon = lookupTHName ''Maybe >>= tcLookupTyCon + -- + -- This is recommended over manually looking up the package and module + -- name, because the manual method does not robustly deal with re-exports; + -- one must specify the exact package/module which defines the identifier. + -- For instance, to manually lookup the type family @MyFam@ in module + -- @MyModule@ in package @my-pkg@: + -- + -- > lookupMyFam :: MonadTcPluginM m => m Name + -- > lookupMyFam = do -- > let modlName = mkModuleName "MyModule" -- > pkgName = Just $ fsLit "my-pkg" -- > pkgQual <- resolveImport modlName pkgName @@ -99,31 +114,38 @@ -- to the other stages: the plugin initialisation is called only once in each module -- that the plugin is used, whereas the solver and rewriter are usually called repeatedly. - -- ** Packages and modules + -- ** Name resolution: TH method + -- | Look up a Name from a Template Haskell Name (e.g. a Name constructed + -- using TemplateHaskellQuotes). + , lookupTHName + + -- ** Name resolution: manual method + -- *** Packages and modules + -- | Use these functions to lookup a module, -- from the current package or imported packages. , findImportedModule, resolveImport, fsLit, unpackFS, mkModuleName , unitIdFS, stringToUnitId, pkgQualToPkgName , Module, ModuleName, FindResult(..), UnitId, PkgQual - -- ** Names + -- *** Names - -- *** Occurence names + -- **** Occurence names -- | The most basic type of name is the 'OccName', which is a -- simple textual name within a namespace (e.g. the class namespace), -- without any disambiguation (no module qualifier, etc). , mkVarOcc, mkDataOcc, mkTyVarOcc, mkTcOcc, mkClsOcc - -- *** Names + -- **** Names -- | After having looked up the 'Module', we can obtain the full 'Name' -- referred to by an 'OccName'. This is fully unambiguous, as it -- contains a 'Unique' identifier for the name. , lookupOrig - -- *** 'TyCon', 'Class', 'DataCon', etc + -- ** Name resolution: resolving the Name to a 'TyCon', 'Class', 'DataCon', etc -- | Finally, we can obtain the actual objects we're interested in handling, -- such as classes, type families, data constructors... by looking them up @@ -244,8 +266,12 @@ , readTcRef, writeTcRef -- | == Some further functions for inspecting constraints - , eqType + , eqType, nonDetCmpType , ctLoc, ctEvidence, ctFlavour, ctEqRel, ctOrigin + , ctEvPred, ctEvId, ctEvExpr, ctEvLoc + , isGiven, isWanted + , isEqPred, isEqClassPred + , className, tyConName -- ** Constraint evidence @@ -282,13 +308,11 @@ -- by combining evidence that is already available. , mkPluginUnivEvTerm - , evDataConApp + , evDFunApp, evDataConApp , newEvVar, setEvBind - , evCoercion, evCast - , ctEvExpr + , evId, evCoercion, evCast , askEvBinds, lookupEvBind, eb_lhs, eb_rhs , newName, mkLocalId, mkTyVar - , ctev_pred, ctev_evar, ctev_loc, ctev_dest -- *** Class dictionaries @@ -395,6 +419,7 @@ -- ** Type literals (natural numbers, type-level strings) , mkNumLitTy, isNumLitTy , mkStrLitTy, isStrLitTy + , natKind, symbolKind, charKind -- ** Creating and decomposing applications , mkTyConTy, mkTyConApp, mkAppTy, mkAppTys @@ -408,6 +433,8 @@ , mkForAllTy, mkForAllTys , mkPiTy, mkPiTys + -- ** Kinds + , typeKind #if MIN_VERSION_ghc(9,0,0) , Mult @@ -503,6 +530,19 @@ -- ghc import GHC ( TyThing(..) ) +import GHC.Builtin.Names + ( hasKey + , eqPrimTyConKey, eqReprPrimTyConKey + , heqTyConKey, eqTyConKey, coercibleTyConKey + ) +import GHC.Builtin.Types + ( typeSymbolKind, charTy +#if MIN_VERSION_ghc(9,1,0) + , naturalTy +#else + , typeNatKind +#endif + ) #if !MIN_VERSION_ghc(9,0,0) import GHC.Builtin.Types ( intDataCon ) @@ -510,12 +550,12 @@ ( intPrimTy ) #endif import GHC.Core - ( CoreBndr, CoreExpr, Expr(..) ) + ( CoreBndr, CoreExpr, Expr(..), mkTyApps, mkApps ) import GHC.Core.Class ( Class(..), FunDep ) import GHC.Core.Coercion ( mkReflCo, mkSymCo, mkTransCo - , mkUnivCo + , mkUnivCo, isReflCo #if !MIN_VERSION_ghc(9,13,0) && MIN_VERSION_ghc(8,10,0) , mkPrimEqPredRole #endif @@ -524,7 +564,7 @@ ( Role(..) ) import GHC.Core.DataCon ( DataCon - , classDataCon, promoteDataCon + , classDataCon, promoteDataCon, dataConWrapId ) import GHC.Core.FamInstEnv ( FamInstEnv ) @@ -552,7 +592,7 @@ ( Reduction(..) ) #endif import GHC.Core.TyCon - ( TyCon(..) ) + ( TyCon(..), tyConClass_maybe ) #if MIN_VERSION_ghc(9,6,0) import GHC.Core.TyCo.Compare ( eqType ) @@ -589,6 +629,7 @@ , mkAppTy, mkAppTys, isTyVarTy, getTyVar_maybe , mkCoercionTy, isCoercionTy, isCoercionTy_maybe , mkNumLitTy, isNumLitTy, mkStrLitTy, isStrLitTy + , typeKind #if !MIN_VERSION_ghc(9,6,0) , eqType #endif @@ -600,6 +641,28 @@ ) import GHC.Data.FastString ( FastString, fsLit, unpackFS ) +#if MIN_VERSION_ghc(9,5,0) +import GHC.Plugins + ( thNameToGhcNameIO ) +#else +import Data.Maybe + ( listToMaybe ) +#if MIN_VERSION_ghc(9,3,0) +import GHC.Iface.Env + ( lookupNameCache ) +#else +import GHC.Iface.Env + ( lookupOrigIO ) +#endif +import GHC.ThToHs + ( thRdrNameGuesses ) +import GHC.Types.Name + ( isExternalName ) +import GHC.Types.Name.Reader + ( isExact_maybe, isOrig_maybe ) +import GHC.Utils.Monad + ( mapMaybeM ) +#endif import qualified GHC.Tc.Plugin as GHC #if MIN_VERSION_ghc(9,4,0) @@ -628,21 +691,27 @@ #if MIN_VERSION_ghc(9,11,0) import GHC.Tc.Types.CtLoc ( CtLoc(..), bumpCtLocDepth ) +#else +import GHC.Tc.Types.Constraint + ( CtLoc(..), bumpCtLocDepth ) #endif +#if MIN_VERSION_ghc(9,13,0) import GHC.Tc.Types.Constraint + ( GivenCtEvidence(..) ) +#endif +import GHC.Tc.Types.Constraint ( Ct(..), CtEvidence(..), CtFlavour(..) , QCInst(..), TcEvDest(..) , ctPred, ctLoc, ctEvidence, ctEvExpr , ctEvCoercion , ctFlavour, ctEqRel, ctOrigin - , mkNonCanonical -#if !MIN_VERSION_ghc(9,11,0) - , CtLoc(..), bumpCtLocDepth -#endif + , ctEvFlavour, ctEvPred, ctEvLoc + , mkNonCanonical, ctEvId ) import GHC.Tc.Types.Evidence ( EvBind(..), EvTerm(..), EvExpr, EvBindsVar(..) - , evCoercion, evCast, lookupEvBind, evDataConApp + , evCoercion, lookupEvBind + , mkGivenEvBind, evId ) import GHC.Tc.Types.Origin ( CtOrigin(..) ) @@ -654,6 +723,7 @@ import GHC.Tc.Utils.TcType ( TcType, TcLevel, MetaDetails, MetaInfo , isSkolemTyVar, isMetaTyVar + , nonDetCmpType ) import GHC.Tc.Utils.TcMType ( isFilledMetaTyVar_maybe, writeMetaTyVar ) @@ -673,15 +743,20 @@ ( OccName(..) , mkVarOcc, mkDataOcc, mkTyVarOcc, mkTcOcc, mkClsOcc ) -#if MIN_VERSION_ghc(9,3,0) -import GHC +#if MIN_VERSION_ghc(9,1,0) +import GHC.Driver.Env.Types ( HscEnv ) +#else +import GHC.Driver.Types + ( HscEnv ) +#endif +#if MIN_VERSION_ghc(9,3,0) +import GHC.Driver.Env.Types + ( hsc_unit_env, hsc_NC ) 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) @@ -707,17 +782,16 @@ ( UniqDFM, lookupUDFM, lookupUDFM_Directly, elemUDFM ) import GHC.Types.Var ( TyVar, CoVar, TcTyVar, EvVar - , mkTyVar + , mkTyVar, DFunId ) import GHC.Utils.Outputable - ( Outputable(..), SDoc -#if !MIN_VERSION_ghc(9,2,0) - , panic, pprPanic -#endif - ) + ( Outputable(..), SDoc, text ) #if MIN_VERSION_ghc(9,2,0) import GHC.Utils.Panic ( panic, pprPanic ) +#else +import GHC.Utils.Outputable + ( panic, pprPanic ) #endif #if MIN_VERSION_ghc(9,2,0) import GHC.Unit.Finder @@ -742,22 +816,21 @@ ( HasDebugCallStack ) #endif --- transformers -import Control.Monad.IO.Class - ( MonadIO ( liftIO ) ) - -- ghc-tcplugin-api import GHC.TcPlugin.API.Internal #ifndef HAS_REWRITING import GHC.TcPlugin.API.Internal.Shim #endif --------------------------------------------------------------------------------- +-- template-haskell +import qualified Language.Haskell.TH as TH --- | Run an 'IO' computation within the plugin. -tcPluginIO :: MonadTcPlugin m => IO a -> m a -tcPluginIO = unsafeLiftTcM . liftIO +-- transformers +import Control.Monad.IO.Class + ( MonadIO ( liftIO ) ) +-------------------------------------------------------------------------------- + -- | Output some debugging information within the plugin. tcPluginTrace :: MonadTcPlugin m => String -- ^ Text at the top of the debug message. @@ -887,10 +960,8 @@ -------------------------------------------------------------------------------- -#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 ) @@ -950,6 +1021,18 @@ -------------------------------------------------------------------------------- +-- | Is this a "Given" constraint? +isGiven :: CtEvidence -> Bool +isGiven ev = case ctEvFlavour ev of + Given {} -> True + _ -> False + +-- | Is this a "Wanted" constraint? +isWanted :: CtEvidence -> Bool +isWanted = not . isGiven + +-------------------------------------------------------------------------------- + -- | Create a new Wanted constraint. -- -- Requires a location (so that error messages can say where the constraint came from, @@ -967,15 +1050,19 @@ -- | Create a new Given constraint. -- -- Unlike 'newWanted', we need to supply evidence for this constraint. -newGiven :: CtLoc -> PredType -> EvExpr -> TcPluginM Solve CtEvidence +newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM Solve CtEvidence newGiven loc pty evtm = do -#if HAS_REWRITING - tc_evbinds <- askEvBinds - liftTcPluginM $ GHC.newGiven tc_evbinds loc pty evtm -#else - liftTcPluginM $ GHC.newGiven loc pty evtm + new_ev <- newEvVar pty + setEvBind $ mkGivenEvBind new_ev evtm + return $ + CtGiven +#if MIN_VERSION_ghc(9,13,0) + $ GivenCt #endif - + { ctev_pred = pty + , ctev_evar = new_ev + , ctev_loc = loc + } -- | Obtain the 'CtLoc' from a 'RewriteEnv'. -- @@ -1078,7 +1165,9 @@ -> TcType -- ^ The type that the type family application reduces to -> Reduction mkTyFamAppReduction str role deps tc args ty = - Reduction ( mkPluginUnivCo str role deps ( mkTyConApp tc args ) ty ) ty + Reduction + ( mkPluginUnivCo str role deps ( mkTyConApp tc args ) ty ) + ty -------------------------------------------------------------------------------- @@ -1145,6 +1234,123 @@ setInertSet :: InertSet -> TcS () setInertSet = setTcSInerts +#endif + +-------------------------------------------------------------------------------- + +-- | Resolve a @template-haskell@ 'TH.Name' to a GHC 'Name'. +-- +-- Especially useful in conjunction with @TemplateHaskellQuotes@, e.g. to +-- look up the 'Name' of the @Maybe@ type constructor, you can do: +-- +-- > lookupName ''Maybe +-- +-- @since 0.15.0.0 +lookupTHName :: ( Monad (TcPluginM s), MonadTcPlugin (TcPluginM s) ) + => TH.Name -> TcPluginM s Name +lookupTHName thNm = do + hscEnv <- getTopEnv + mbNm <- + liftIO $ + thNameToGhcNameIO +#if MIN_VERSION_ghc(9,6,0) + (hsc_NC hscEnv) +#else + hscEnv +#endif + thNm + case mbNm of + Just nm -> + return nm + Nothing -> + pprPanic "lookupTHName: lookup failed" (text $ show thNm) + +-------------------------------------------------------------------------------- + +-- | Apply an instance dictionary function to type and value arguments. +-- +-- NB: different from @evDFunApp@ defined in GHC, as this function returns +-- an @EvExpr@ rather than an @EvTerm@. +evDFunApp :: DFunId -> [Type] -> [EvExpr] -> EvExpr +evDFunApp df tys ets = Var df `mkTyApps` tys `mkApps` ets + +-- | Apply a data constructor to type and value arguments. +-- +-- NB: different from @evDataConApp@ defined in GHC, as this function returns +-- an @EvExpr@ rather than an @EvTerm@. +evDataConApp :: DataCon -> [Type] -> [EvExpr] -> EvExpr +evDataConApp dc tys ets = evDFunApp (dataConWrapId dc) tys ets + +-- | Cast an evidence expression by a coercion. +-- +-- NB: different from @evCast@ defined in GHC, as this function returns +-- an @EvExpr@ rather than an @EvTerm@. +evCast :: EvExpr -> Coercion -> EvExpr +evCast et co | isReflCo co = et + | otherwise = Cast et co + +-------------------------------------------------------------------------------- + +natKind, symbolKind, charKind :: Type +natKind = +#if MIN_VERSION_ghc(9,1,0) + naturalTy +#else + typeNatKind +#endif +symbolKind = typeSymbolKind +charKind = charTy + +-------------------------------------------------------------------------------- + +-- | Is this a primitive (unboxed) equality type, i.e. one of: +-- +-- - @~#@ (heterogeneous nominal unboxed equality), +-- - @~R#@ (heterogeneous representational unboxed equality). +-- +-- NB: returns @False@ for **boxed** equalities such as @(~)@, @(~~)@ and @Coercible@. +-- If you want to detect those, use 'isEqClassPred'. +isEqPred :: PredType -> Bool +isEqPred pty + | Just tc <- tyConAppTyCon_maybe pty + = tc `hasKey` eqPrimTyConKey || tc `hasKey` eqReprPrimTyConKey + | otherwise + = False + +-- | Is this a boxed equality type, i.e. one of: +-- +-- - @(~)@ (homogeneous nominal boxed equality), +-- - @(~~)@ (heterogeneous nominal boxed equality), +-- - @Coercible@ (homogeneous boxed representational equality). +isEqClassPred :: PredType -> Bool +isEqClassPred pty + | Just tc <- tyConAppTyCon_maybe pty + , Just cls <- tyConClass_maybe tc + = cls `hasKey` heqTyConKey + || cls `hasKey` eqTyConKey + || cls `hasKey` coercibleTyConKey + | otherwise + = False + +-------------------------------------------------------------------------------- + +#if !MIN_VERSION_ghc(9,6,0) +thNameToGhcNameIO :: HscEnv -> TH.Name -> IO (Maybe Name) +thNameToGhcNameIO hscEnv th_name + = do { names <- mapMaybeM do_lookup (thRdrNameGuesses th_name) + ; return (listToMaybe names) } + where + do_lookup rdr_name + | Just n <- isExact_maybe rdr_name + = return $ if isExternalName n then Just n else Nothing + | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name +#if MIN_VERSION_ghc(9,3,0) + = Just <$> lookupNameCache (hsc_NC hscEnv) rdr_mod rdr_occ +#else + = Just <$> lookupOrigIO hscEnv rdr_mod rdr_occ +#endif + | otherwise + = return Nothing #endif -------------------------------------------------------------------------------- diff --git a/src/GHC/TcPlugin/API/Internal.hs b/src/GHC/TcPlugin/API/Internal.hs --- a/src/GHC/TcPlugin/API/Internal.hs +++ b/src/GHC/TcPlugin/API/Internal.hs @@ -69,6 +69,8 @@ ( TypeError, ErrorMessage(..) ) -- transformers +import Control.Monad.IO.Class + ( MonadIO ( liftIO ) ) import Control.Monad.Trans.Reader ( ReaderT(..) ) @@ -464,6 +466,10 @@ adaptUserStop :: ( userDefs -> TcPluginM Stop () ) -> TcPluginDefs userDefs -> GHC.TcPluginM () adaptUserStop userStop ( TcPluginDefs { tcPluginUserDefs } ) = tcPluginStopM $ userStop tcPluginUserDefs + +-- | @since 0.15.0.0 +instance ( Monad ( TcPluginM s ), MonadTcPlugin ( TcPluginM s ) ) => MonadIO ( TcPluginM s ) where + liftIO = unsafeLiftTcM . liftIO -- | Monads for type-checking plugins which are able to emit new constraints -- and throw errors.