ghc-tcplugin-api 0.8.3.0 → 0.19.0.0
raw patch · 8 files changed
Files
- changelog.md +295/−116
- ghc-tcplugin-api.cabal +182/−158
- src/GHC/TcPlugin/API.hs +1498/−1005
- src/GHC/TcPlugin/API/Internal.hs +670/−575
- src/GHC/TcPlugin/API/Internal/Shim.hs +1098/−975
- src/GHC/TcPlugin/API/Internal/Shim/Reduction.hs +604/−604
- src/GHC/TcPlugin/API/Names.hs +477/−494
- src/GHC/TcPlugin/API/TyConSubst.hs +537/−0
changelog.md view
@@ -1,116 +1,295 @@-# Version 0.8.3.0 (2022-10-05)--- Bugfix for the GHC 9.0 rewriter plugin compatibility shim:- fix coercion orientations in family application cache--# Version 0.8.2.0 (2022-10-05)--- Bugfix for the GHC 9.0 rewriter plugin compatibility shim:- fix coercion orientations in family rewriting.--# Version 0.8.1.0 (2022-10-05)--- Bugfix for the GHC 9.2 rewriter plugin compatibility shim:- fix coercion orientations in family rewriting.--# 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,- as opposed to obtaining some information from the monadic environment.- This means you no longer need to wrap calls to `newWanted` in `setCtLocM`- to ensure that GHC reports the correct source span when reporting unsolved- Wanteds in error messages.--- Remove the `newDerived` function, as Derived constraints are going to be- removed from GHC.--# Version 0.7.0.0 (2021-12-31)--- Re-export functions for dealing with type-level literals,- such as `mkNumLitTy` and `isStrLitTy`.--- Re-export functions for splitting apart type applications, such as- `splitAppTy_maybe` and `tyConAppTyCon_maybe`.--- Redefine and re-export `mkUncheckedIntExpr` for GHC versions prior to 9.0.--- Re-export some basic types from `GHC.Types.Basic` such as `Arity`,- `PromotionFlag` and `Boxity`.--- Re-export `GHC.Builtin.Names` and `GHC.Builin.Types.Prim`.--- Provide `MonadThings` instances for `TcPluginM` monads.--# Version 0.6.1.0 (2021-12-13)--- Re-export various useful types and functions to deal with type and coercion variables.--- Re-export a few types and functions to deal with source locations.--- Remove some re-exports for constructing function types, as not all functions make sense- across all GHC versions supported by the library.--- Re-export `panic` and `pprPanic`.--# 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)- by correctly downgrading the coercion used to cast the evidence, when necessary.--# Version 0.5.0.0 (2021-08-30)--- Re-export some additional types and functions that are useful for inspecting- and constructing evidence terms, such as `mkTyVar`, `newName`, `mkLocalId`, `lookupEvBind`...--# Version 0.4.1.0 (2021-08-24)--- Re-export a few GHC modules, such as GHC.Core.Make and GHC.Plugins.- These re-exports might be changed to be more selective in the future- to aid cross-version compatibility.--# Version 0.4.0.0 (2021-08-24)--- Adapt to GHC 9.4 changes in the `TcPluginSolveResult` datatype:- are now able to solve and emit constraints even when reporting- a contradiction. This can help with error messages.- Unfortunately these extra constraints will be dropped in versions- of GHC prior to 9.4.--- Add a utility module for name resolution using constrained traversals.--- Add compatibility for GHC 8.10.--# Version 0.3.1.0 (2021-08-09)--Ensure that the coercions stored in `Reduction`s are always-oriented left-to-right, by making the internal rewriting compatibility layer-also use left-to-right coercions.--# Version 0.3.0.0 (2021-08-04)--Account for changes in rewriting in GHC 9.4:-- - rewriter plugins can no longer emit new Wanted constraints- if they don't rewrite the type family application;- - coercions in the rewriter are now oriented left-to-right,- requiring `mkTyFamAppReduction` to be adapted.--# Version 0.2.0.0 (2021-07-22)--Initial release on Hackage.+ +# Version 0.19.0.0 (2026-05-12) + +- Starting from GHC 10.0, typechecker plugins are kept running during the + desugaring phase, in order to improve the accuracy of pattern-match warnings. + + For this reason, the `tcPluginStop` function has been split into two: + - `tcPluginPostTc`, for actions to run at the end of typechecking. + - `tcPluginShutdown`, to shut down the plugin. This action runs in `IO` + instead of a `TcM`-like monad. + + On GHC versions prior to 10.0, both of these actions will run at the end of + typechecking, and typechecker plugins aren't invoked during pattern-match + checking. + +# Version 0.18.2.1 (2026-04-28) + +- Add preliminary support for GHC 10.0. + +# Version 0.18.2.0 (2025-01-14) + +- Add a new function `ctsSubst` which computes a fix-point substitution from + a collection of constraints which define a terminating generalised + substitution. Mainly for use with the set of inert Given constraints. + +- Re-export several functions to deal with substitutions: `substTy`, + `substTys`, `extendTvSubst` and `mkTvSubstPrs`. Also re-export the `Subst` + type (alias for `TCvSubst` on GHC <= 9.6). + +# Version 0.18.1.0 (2025-10-09) + +- Bugfix for v0.18.0.0: deal with constraints generated by unflattening + in `splitTyConApp_upTo`. Fixes #19. + +# Version 0.18.0.0 (2025-09-15) + +- On GHC 9.0 and below, `ghc-tcplugin-api` will now automatically unflatten all + Given constraints. That is, all flattening skolems `[G] fsk ~ F tys` will be + substituted away, both in Givens and in Wanteds/Deriveds. + + No change for GHC 9.2 and above, as GHC stopped producing flattening variables + from 9.2 onwards. + +# Version 0.17.2.0 (2025-09-08) + +- Fix the package failing to build on GHC 9.6.1 through 9.6.6 and + on GHC 9.8.1 through 9.8.3. GHC versions 9.6.7 and 9.8.4 are unaffected. + +# Version 0.17.1.0 (2025-08-27) + +- Fix a regression, introduced in `0.17.0.0`, in which `splitTyConApp_upTo` would + fail to take into account equalities of the form `tv1 ~ tv2`. + +# Version 0.17.0.0 (2025-08-25) + +- `splitTyConApp_upTo` now additionally returns a `[Coercion]` for tracking + Given dependencies (which should be passed to functions such as `mkPluginUnivCo`, + `mkPluginUnivEvTerm` and `mkTyFamAppReduction`). + +# Version 0.16.2.0 (2025-08-22) + +- `splitTyConApp_upTo` now correctly splits apart type families. This ensures + it is a valid drop-in replacement for `splitTyConApp_maybe` (fixes issue #13). + +# Version 0.16.1.0 (2025-07-18) + +- Correctness fix for the `GHC.TcPlugin.API.TyConSubst` module: ensure that + the `TyConSubst` does not mistake representational Given equalities for + nominal equalities. For the time being, the `splitTyConApp_upTo` functionality + only works at nominal role. + +# Version 0.16.0.0 (2025-07-18) + +- Re-export `tyConDataCons`, `tyConSingleDataCon_maybe`, + `tyConSingleDataCon`, `dataConTyCon`, `isNewTyCon` and `isNewDataCon` + from GHC. + +- The `isWanted` function now correctly returns `False` for derived + constraints. This is only relevant for GHC 9.2 and below. + +- Add `GHC.TcPlugin.API.TyConSubst` module, which implements logic for + recognising when a type is a `TyConApp` up to Given constraints. + +# 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) + +- Rename `mkPrimEqPredRole` to `mkEqPredRole`. This is a re-exported function + from GHC, and the renaming adapts to the renaming in GHC-9.13. + +# Version 0.13.0.0 (2024-10-30) + +- Update to changes in the type of GHC's `mkUnivCo` + in order to (properly) add support for GHC 9.12. + +- Change `mkPluginUnivCo`, `mkPluginUnivEvTerm` and `mkTyFamAppReduction` + to take a `[Coercion]` rather than a `DVarSet` for specifying dependencies. + +- Stop re-exporting `DVarSet`, `emptyDVarSet`, `extendDVarSet`, `unionDVarSet`, + `unitDVarSet`, and `mkDVarSet`. + +- Update documentation to suggest using `ctEvCoercion` + rather than `ctEvId` to specify coercions that a `UnivCo` depends on. + +- Re-export `ctEvCoercion`, and stop re-exporting `ctEvId`. + +# Version 0.12.0.0 (2024-10-22) + +- Add preliminary support for GHC 9.12. + +- `mkPluginUnivCo`, `mkPluginUnivEvTerm` and `mkTyFamAppReduction` now all take + an additional `DVarSet` argument which allows specifying evidence that we + depend on. This stops evidence terms being floated out past used enclosing + Givens (see [GHC issue #23923](https://gitlab.haskell.org/ghc/ghc/-/issues/23923)). + +- Re-export `DVarSet`, `emptyDVarSet`, `extendDVarSet`, `unionDVarSet`, + `unitDVarSet`, and `mkDVarSet`, as well as `ctEvId`, in order to facilitate + construction and manipulation of `DVarSet`s. + +- Re-export `GHC.Types.Unique.Set`, `GHC.Types.Unique.DSet`. + +# Version 0.11.0.0 (2023-08-29) + +- Add support for GHC 9.8. + +- Re-export functionality relating to GHC's constraint solving `TcS` monad, + such as `{get,set}InertSet`, `{get,set}TcEvBindsMap`. + +- Re-export `readTcRef` and `writeTcRef`. + +# 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. + +- The `One` and `Many` pattern synonyms are now `OneTy` and `ManyTy`. + +- Use `mkInvisFunTy`/`mkInvisFunTys` instead of `mkInvisFunTyMany`/`mkInvisFunTysMany`. + +# Version 0.8.3.0 (2022-10-05) + +- Bugfix for the GHC 9.0 rewriter plugin compatibility shim: + fix coercion orientations in family application cache + +# Version 0.8.2.0 (2022-10-05) + +- Bugfix for the GHC 9.0 rewriter plugin compatibility shim: + fix coercion orientations in family rewriting. + +# Version 0.8.1.0 (2022-10-05) + +- Bugfix for the GHC 9.2 rewriter plugin compatibility shim: + fix coercion orientations in family rewriting. + +# 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, + as opposed to obtaining some information from the monadic environment. + This means you no longer need to wrap calls to `newWanted` in `setCtLocM` + to ensure that GHC reports the correct source span when reporting unsolved + Wanteds in error messages. + +- Remove the `newDerived` function, as Derived constraints are going to be + removed from GHC. + +# Version 0.7.0.0 (2021-12-31) + +- Re-export functions for dealing with type-level literals, + such as `mkNumLitTy` and `isStrLitTy`. + +- Re-export functions for splitting apart type applications, such as + `splitAppTy_maybe` and `tyConAppTyCon_maybe`. + +- Redefine and re-export `mkUncheckedIntExpr` for GHC versions prior to 9.0. + +- Re-export some basic types from `GHC.Types.Basic` such as `Arity`, + `PromotionFlag` and `Boxity`. + +- Re-export `GHC.Builtin.Names` and `GHC.Builin.Types.Prim`. + +- Provide `MonadThings` instances for `TcPluginM` monads. + +# Version 0.6.1.0 (2021-12-13) + +- Re-export various useful types and functions to deal with type and coercion variables. + +- Re-export a few types and functions to deal with source locations. + +- Remove some re-exports for constructing function types, as not all functions make sense + across all GHC versions supported by the library. + +- Re-export `panic` and `pprPanic`. + +# 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) + by correctly downgrading the coercion used to cast the evidence, when necessary. + +# Version 0.5.0.0 (2021-08-30) + +- Re-export some additional types and functions that are useful for inspecting + and constructing evidence terms, such as `mkTyVar`, `newName`, `mkLocalId`, `lookupEvBind`... + +# Version 0.4.1.0 (2021-08-24) + +- Re-export a few GHC modules, such as GHC.Core.Make and GHC.Plugins. + These re-exports might be changed to be more selective in the future + to aid cross-version compatibility. + +# Version 0.4.0.0 (2021-08-24) + +- Adapt to GHC 9.4 changes in the `TcPluginSolveResult` datatype: + are now able to solve and emit constraints even when reporting + a contradiction. This can help with error messages. + Unfortunately these extra constraints will be dropped in versions + of GHC prior to 9.4. + +- Add a utility module for name resolution using constrained traversals. + +- Add compatibility for GHC 8.10. + +# Version 0.3.1.0 (2021-08-09) + +Ensure that the coercions stored in `Reduction`s are always +oriented left-to-right, by making the internal rewriting compatibility layer +also use left-to-right coercions. + +# Version 0.3.0.0 (2021-08-04) + +Account for changes in rewriting in GHC 9.4: + + - rewriter plugins can no longer emit new Wanted constraints + if they don't rewrite the type family application; + - coercions in the rewriter are now oriented left-to-right, + requiring `mkTyFamAppReduction` to be adapted. + +# Version 0.2.0.0 (2021-07-22) + +Initial release on Hackage.
ghc-tcplugin-api.cabal view
@@ -1,158 +1,182 @@-cabal-version: 3.0-name: ghc-tcplugin-api-version: 0.8.3.0-synopsis: An API for type-checker plugins.-license: BSD-3-Clause-build-type: Simple-author: Sam Derbyshire-maintainer: Sam Derbyshire-copyright: 2021 Sam Derbyshire-homepage: https://github.com/sheaf/ghc-tcplugin-api-category: Type System, GHC, Plugin-description:-- This library provides a streamlined monadic interface- for writing GHC type-checking plugins.-- Each stage in a type-checking plugin (initialisation, solving, rewriting,- shutdown) has a corresponding monad, preventing operations that are only- allowed in some stages to be used in the other stages.- Operations that work across multiple stages are overloaded across monads- using MTL-like typeclasses.-- Some operations, like creating evidence for constraints or creating- custom type error messages, are also simplified.-- Please refer to the <https://github.com/sheaf/ghc-tcplugin-api associated GitHub repository>- for example usage.--extra-source-files:- changelog.md--library-- build-depends:- base- >= 4.13.0 && < 4.19,- ghc- >= 8.8 && < 9.7,- transformers- >= 0.5 && < 0.6,-- default-language:- Haskell2010-- ghc-options:- -Wall- -Wcompat- -fwarn-missing-local-signatures- -fwarn-incomplete-uni-patterns- -fwarn-missing-deriving-strategies- -fno-warn-unticked-promoted-constructors-- hs-source-dirs:- src-- exposed-modules:- GHC.TcPlugin.API,- GHC.TcPlugin.API.Names,- GHC.TcPlugin.API.Internal-- reexported-modules:- GHC.Builtin.Names- , GHC.Builtin.Types- , GHC.Builtin.Types.Prim- , GHC.Core.Make- , GHC.Plugins- , GHC.Types.Unique.DFM- , GHC.Types.Unique.FM- , GHC.Utils.Outputable-- 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-- -- Compatibility for versions of GHC prior to 9.0.- if impl(ghc < 9.0)-- mixins:- ghc- ( GHC as GHC-- , PrelNames as GHC.Builtin.Names- , TysWiredIn as GHC.Builtin.Types- , TysPrim as GHC.Builtin.Types.Prim-- , CoreSyn as GHC.Core- , CoAxiom as GHC.Core.Coercion.Axiom- , Coercion as GHC.Core.Coercion- , Class as GHC.Core.Class- , DataCon as GHC.Core.DataCon- , FamInstEnv as GHC.Core.FamInstEnv- , InstEnv as GHC.Core.InstEnv- , MkCore as GHC.Core.Make- , TyCoRep as GHC.Core.TyCo.Rep- , TyCon as GHC.Core.TyCon- , Type as GHC.Core.Type-- , FastString as GHC.Data.FastString- , Pair as GHC.Data.Pair-- , Finder as GHC.Driver.Finder- , DynFlags as GHC.Driver.Session- , HscTypes as GHC.Driver.Types-- , GhcPlugins as GHC.Plugins-- , TcPluginM as GHC.Tc.Plugin- , TcSMonad as GHC.Tc.Solver.Monad- , TcRnTypes as GHC.Tc.Types- , TcEvidence as GHC.Tc.Types.Evidence- , TcRnMonad as GHC.Tc.Utils.Monad- , TcType as GHC.Tc.Utils.TcType- , TcMType as GHC.Tc.Utils.TcMType-- , BasicTypes as GHC.Types.Basic- , Id as GHC.Types.Id- , Literal as GHC.Types.Literal- , Name as GHC.Types.Name- , OccName as GHC.Types.Name.Occurrence- , SrcLoc as GHC.Types.SrcLoc- , Unique as GHC.Types.Unique- , UniqDFM as GHC.Types.Unique.DFM- , UniqFM as GHC.Types.Unique.FM- , Var as GHC.Types.Var- , VarEnv as GHC.Types.Var.Env- , VarSet as GHC.Types.Var.Set-- , Module as GHC.Unit.Module- , Module as GHC.Unit.Module.Name- , Module as GHC.Unit.Types-- , Util as GHC.Utils.Misc- , TcRnMonad as GHC.Utils.Monad- , Outputable as GHC.Utils.Outputable- , Panic as GHC.Utils.Panic- )-- if impl(ghc > 8.10)-- mixins:- ghc- ( 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- )+cabal-version: 3.0 +name: ghc-tcplugin-api +version: 0.19.0.0 +synopsis: An API for type-checker plugins. +license: BSD-3-Clause +build-type: Simple +author: Sam Derbyshire +maintainer: Sam Derbyshire +copyright: 2021-2025 Sam Derbyshire +homepage: https://github.com/sheaf/ghc-tcplugin-api +category: Type System, GHC, Plugin +description: + + This library provides a streamlined monadic interface + for writing GHC type-checking plugins. + + Each stage in a type-checking plugin (initialisation, solving, rewriting, + post-tc) has a corresponding monad, preventing operations that are only + allowed in some stages to be used in the other stages. + Operations that work across multiple stages are overloaded across monads + using MTL-like typeclasses. + + Some operations, like creating evidence for constraints or creating + custom type error messages, are also simplified. + + Please refer to the <https://github.com/sheaf/ghc-tcplugin-api associated GitHub repository> + for example usage. + +extra-source-files: + changelog.md + +library + + build-depends: + base + >= 4.13.0 && < 5, + array + >= 0.5.3.0 && < 0.6, + containers + >= 0.6 && < 0.9, + ghc + >= 8.8 && < 10.1, + transformers + >= 0.5 && < 0.7, + template-haskell + >= 2.15 && < 2.26, + + default-language: + Haskell2010 + + ghc-options: + -Wall + -Wcompat + -fwarn-missing-local-signatures + -fwarn-incomplete-uni-patterns + -fwarn-missing-deriving-strategies + -fno-warn-unticked-promoted-constructors + + hs-source-dirs: + src + + exposed-modules: + GHC.TcPlugin.API, + GHC.TcPlugin.API.Names, + GHC.TcPlugin.API.TyConSubst, + + GHC.TcPlugin.API.Internal + + reexported-modules: + GHC.Builtin.Names + , GHC.Builtin.Types + , GHC.Builtin.Types.Prim + , GHC.Core.Make + , GHC.Plugins + , GHC.Types.Unique.DFM + , GHC.Types.Unique.FM + , GHC.Types.Unique.Set + , 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 + cpp-options: -DHAS_DERIVEDS + other-modules: + GHC.TcPlugin.API.Internal.Shim + GHC.TcPlugin.API.Internal.Shim.Reduction + + -- Compatibility for versions of GHC prior to 9.0. + if impl(ghc < 9.0) + + mixins: + ghc + ( GHC as GHC + + , PrelNames as GHC.Builtin.Names + , TysWiredIn as GHC.Builtin.Types + , TysPrim as GHC.Builtin.Types.Prim + + , CoreSyn as GHC.Core + , CoAxiom as GHC.Core.Coercion.Axiom + , Coercion as GHC.Core.Coercion + , Class as GHC.Core.Class + , DataCon as GHC.Core.DataCon + , FamInstEnv as GHC.Core.FamInstEnv + , InstEnv as GHC.Core.InstEnv + , MkCore as GHC.Core.Make + , TyCoRep as GHC.Core.TyCo.Rep + , TyCon as GHC.Core.TyCon + , Type as GHC.Core.Type + + , FastString as GHC.Data.FastString + , Pair as GHC.Data.Pair + + , Finder as GHC.Driver.Finder + , DynFlags as GHC.Driver.Session + , HscTypes as GHC.Driver.Types + + , IfaceEnv as GHC.Iface.Env + + , GhcPlugins as GHC.Plugins + + , TcPluginM as GHC.Tc.Plugin + , TcSMonad as GHC.Tc.Solver.Monad + , TcRnTypes as GHC.Tc.Types + , TcEvidence as GHC.Tc.Types.Evidence + , TcRnMonad as GHC.Tc.Utils.Monad + , TcType as GHC.Tc.Utils.TcType + , TcMType as GHC.Tc.Utils.TcMType + + , BasicTypes as GHC.Types.Basic + , Id as GHC.Types.Id + , 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 + , UniqDSet as GHC.Types.Unique.DSet + , UniqFM as GHC.Types.Unique.FM + , UniqSet as GHC.Types.Unique.Set + , Var as GHC.Types.Var + , VarEnv as GHC.Types.Var.Env + , VarSet as GHC.Types.Var.Set + + , Module as GHC.Unit.Module + , Module as GHC.Unit.Module.Name + , Module as GHC.Unit.Types + + , FV as GHC.Utils.FV + , Util as GHC.Utils.Misc + , TcRnMonad as GHC.Utils.Monad + , Outputable as GHC.Utils.Outputable + , Panic as GHC.Utils.Panic + ) + + if impl(ghc > 8.10) + + mixins: + ghc + ( Predicate as GHC.Core.Predicate + , Constraint as GHC.Tc.Types.Constraint + , TcOrigin as GHC.Tc.Types.Origin + , GHC.ThToHs as GHC.ThToHs + -- I forget what this last line does, but it is needed on GHC 9.10 + ) + + else + + mixins: + ghc + ( Type as GHC.Core.Predicate + , TcRnTypes as GHC.Tc.Types.Constraint + , TcRnTypes as GHC.Tc.Types.Origin + , Convert as GHC.ThToHs + )
src/GHC/TcPlugin/API.hs view
@@ -1,1005 +1,1498 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE UndecidableInstances #-}--{-|-Module: GHC.TcPlugin.API--This module provides a unified interface for writing type-checking plugins for GHC.--It attempts to re-export all the functionality from GHC that is relevant to plugin authors,-as well as providing utility functions to streamline certain common operations such as-creating evidence (to solve constraints), rewriting type family applications, throwing custom type errors.--Consider making use of the table of contents to help navigate this documentation;-don't hesitate to jump between sections to get an overview of the relevant aspects.--For an illustration of the functionality, check the examples in the associated-<https://github.com/sheaf/ghc-tcplugin-api GitHub repository>.--The internal module "GHC.TcPlugin.API.Internal" can be used to directly-lift and unlift computations in GHC's 'GHC.Tc.Types.TcM' monad, but it is hoped that-the interface provided in this module is sufficient.---}--module GHC.TcPlugin.API- ( -- * Basic TcPlugin functionality-- -- ** The 'TcPlugin' type- TcPlugin(..)- , mkTcPlugin-- -- ** Plugin state- -- | A type-checker plugin can define its own state, corresponding to the existential parameter @s@- -- in the definition of 'TcPlugin'.- -- This allows a plugin to look up information a single time- -- on initialisation, and pass it on for access in all further invocations of the plugin.- --- -- For example:- --- -- > data MyDefinitions { myTyFam :: !TyCon, myClass :: !Class }- --- -- Usually, the 'tcPluginInit' part of the plugin looks up all this information and returns it:- --- -- > myTcPluginInit :: TcPluginM Init MyDefinitions- --- -- This step should also be used to initialise any external tools,- -- such as an external SMT solver.- --- -- This information will then be passed to other stages of the plugin:- --- -- > myTcPluginSolve :: MyDefinitions -> TcPluginSolver-- -- ** The type-checking plugin monads-- -- | Different stages of type-checking plugins have access to different information.- -- For a unified interface, an MTL-style approach is used, with the 'MonadTcPlugin'- -- typeclass providing overloading (for operations that work in all stages).- , TcPluginStage(..), MonadTcPlugin- , TcPluginM- , tcPluginIO-- -- *** Emitting new work, and throwing type-errors-- -- | Some operations only make sense in the two main phases, solving and rewriting.- -- This is captured by the 'MonadTcPluginWork' typeclass, which allows emitting- -- new work, including throwing type errors.- , MonadTcPluginWork- , TcPluginErrorMessage(..)- , mkTcPluginErrorTy-- -- * Name resolution-- -- | 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@:- --- -- > lookupMyModule :: MonadTcPlugin m => m Module- -- > lookupMyModule = do- -- > findResult <- findImportedModule ( mkModuleName "MyModule" ) ( Just $ fsLit "my-pkg" )- -- > case findResult of- -- > Found _ myModule -> pure myModule- -- > _ -> error "MyPlugin couldn't find MyModule in my-pkg"- -- >- -- > lookupMyFam :: MonadTcPlugin m => Module -> m TyCon- -- > lookupMyFam myModule = tcLookupTyCon =<< lookupOrig myModule ( mkTcOcc "MyFam" )- --- -- Most of these operations should be performed in 'tcPluginInit', and passed on- -- 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-- -- | 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(..)-- -- ** 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-- -- | 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-- -- | Finally, we can obtain the actual objects we're interested in handling,- -- such as classes, type families, data constructors... by looking them up- -- using their 'Name'.- , tcLookupTyCon- , tcLookupDataCon- , tcLookupClass- , tcLookupGlobal- , tcLookup- , tcLookupId- , promoteDataCon-- -- * Constraint solving-- -- | Type-checking plugins will often want to manipulate constraints,- -- e.g. solve constraints that GHC can't solve on its own, or emit- -- their own constraints.- --- -- There are two different constraint flavours:- --- -- - Given constraints, which are already known and- -- have evidence associated to them,- -- - Wanted constraints, for which evidence has not yet been found.- --- -- When GHC can't solve a Wanted constraint, it will get reported to the- -- user as a type error.-- , TcPluginSolver-#if HAS_REWRITING- , TcPluginSolveResult(..)-#else- , TcPluginSolveResult- , pattern TcPluginContradiction, pattern TcPluginOk-#endif-- -- | The 'tcPluginSolve' method of a typechecker plugin will be invoked- -- in two different ways:- --- -- 1. to simplify Given constraints. In this case, the 'tcPluginSolve' function- -- will not be passed any Wanted constraints, and- -- 2. to solve Wanted constraints.- --- -- The plugin can then respond in one of two ways:- --- -- - with @TcPluginOk solved new@, where @solved@ is a list of solved constraints- -- and @new@ is a list of new constraints for GHC to process;- -- - with @TcPluginContradiction contras@, where @contras@ is a list of impossible- -- constraints, so that they can be turned into errors.- --- -- In both cases, the plugin must respond with constraints of the same flavour,- -- i.e. in (1) it should return only Givens, and for (2) it should return only- -- Wanteds; all other constraints will be ignored.-- -- ** Getting started with constraint solving-- -- | To get started, it can be helpful to immediately print out all the constraints- -- that the plugin is given, using 'tcPluginTrace':- --- -- > solver _ givens wanteds = do- -- > tcPluginTrace "---Plugin start---" (ppr givens $$ ppr wanteds)- -- > pure $ TcPluginOk [] []- --- -- This creates a plugin that prints outs the constraints it is passed,- -- without doing anything with them.- --- -- To see this output, you will need to pass the flags @-ddump-tc-trace@- -- and @-ddump-to-file@ to GHC. This will output the trace as a log file,- -- and you can search for @"---Plugin start---"@ to find the plugin inputs.- --- -- Note that pretty-printing in GHC is done using the 'Outputable' type class.- -- We use its 'ppr' method to turn things into pretty-printable documents,- -- and '($$)' to combine documents vertically.- -- If you need more capabilities for pretty-printing documents,- -- import GHC's "GHC.Utils.Outputable" module.- , tcPluginTrace-- -- ** Inspecting constraints & predicates-- -- *** Canonical and non-canonical constraints-- -- | A constraint in GHC starts out as "non-canonical", which means that- -- GHC doesn't know what type of constraint it is.- -- GHC will inspect the constraint to turn it into a canonical form- -- (class constraint, equality constraint, etc.) which satisfies certain- -- invariants used during constraint solving.- --- -- Thus, whenever emitting new constraints, it is usually best to emit a- -- non-canonical constraint, letting GHC canonicalise it.- , mkNonCanonical-- -- *** Predicates-- -- | A type-checking plugin will usually need to inspect constraints,- -- so that it can pick out the constraints it is going to interact with.- --- -- In general, type-checking plugins can encounter all sorts of constraints,- -- whether in canonical form or not.- -- In order to handle these constraints in a uniform manner, it is usually- -- preferable to inspect each constraint's predicate, which can be obtained- -- by using 'classifyPredType' and 'ctPred'.- --- -- This allows the plugin to determine what kind of constraints it is dealing with:- --- -- - an equality constraint? at 'Nominal' or 'Representational' role?- -- - a type-class constraint? for which class?- -- - an irreducible constraint, e.g. something of the form @c a@?- -- - a quantified constraint?- , Pred- , pattern ClassPred, pattern EqPred, pattern IrredPred, pattern ForAllPred- , classifyPredType, ctPred-- -- | == Handling type variables- , TyVar, CoVar- , MetaDetails, MetaInfo- , isSkolemTyVar- , isMetaTyVar, isFilledMetaTyVar_maybe- , writeMetaTyVar-- -- | == Some further functions for inspecting constraints- , eqType- , ctLoc, ctEvidence, ctFlavour, ctEqRel, ctOrigin-- -- ** Constraint evidence-- -- *** Coercions-- -- | 'GHC.Core.TyCo.Rep.Coercion's are the evidence for type equalities.- -- As such, when proving an equality, a type-checker plugin needs- -- to construct the associated coercions.- , mkPluginUnivCo- , newCoercionHole- , mkReflCo, mkSymCo, mkTransCo, mkUnivCo- , mkCoercionTy, isCoercionTy, isCoercionTy_maybe-- -- *** Evidence terms-- -- | Typeclass constraints have a different notion of evidence: evidence terms.- --- -- A plugin that wants to solve a class constraint will need to provide- -- an evidence term. Such evidence can be created from scratch, or it can be obtained- -- by combining evidence that is already available.-- , mkPluginUnivEvTerm- , evDataConApp- , newEvVar, setEvBind- , evCoercion, evCast- , ctEvExpr- , askEvBinds, lookupEvBind, eb_lhs, eb_rhs- , newName, mkLocalId, mkTyVar- , ctev_pred, ctev_evar, ctev_loc, ctev_dest-- -- *** Class dictionaries-- -- | To create evidence terms for class constraints, type-checking plugins- -- need to be able to construct the appropriate dictionaries containing- -- the values for the class methods.- --- -- The class dictionary constructor can be obtained using 'classDataCon'.- -- Functions from "GHC.Core.Make", which is re-exported by this library,- -- will be useful for constructing the necessary terms- --- -- For instance, we can apply the class data constructor using 'mkCoreConApps'.- -- Remember that the type-level arguments (the typeclass variables) come first,- -- before the actual evidence term (the class dictionary expression).-- , classDataCon-#if !MIN_VERSION_ghc(9,0,0)- , mkUncheckedIntExpr-#endif-- -- | ==== Class instances-- -- | In some cases, a type-checking plugin might need to access the- -- class instances that are currently in scope, e.g. to obtain certain- -- evidence terms.- , getInstEnvs-- -- ** Emitting new constraints-- , newWanted, newGiven-- -- | The following functions allow plugins to create constraints- -- for typeclasses and type equalities.- , mkClassPred, mkPrimEqPredRole-- -- | === Deriveds-- -- | Derived constraints are like Wanted constraints, except that they- -- don't require evidence in order to be solved, and won't be seen- -- in error messages if they go unsolved.- --- -- Solver plugins usually ignore this type of constraint entirely.- -- They occur mostly when dealing with functional dependencies and type-family- -- injectivity annotations.- --- -- GHC 9.4 removes this flavour of constraints entirely, subsuming their uses into- -- Wanted constraints.- , askDeriveds-- -- ** Location information and 'CtLoc's-- -- | When creating new constraints, one still needs a mechanism allowing GHC- -- to report a certain source location associated to them when throwing an error,- -- as well as other information the type-checker was aware of at that point- -- (e.g. available instances, given constraints, etc).- --- -- This is the purpose of 'CtLoc'.- , setCtLocM- , setCtLocRewriteM-- -- | 'bumpCtLocDepth' adds one to the "depth" of the constraint.- -- Can help avoid loops, by triggering a "maximum depth exceeded" error.- , bumpCtLocDepth-- -- * Rewriting type-family applications-- , TcPluginRewriter, TcPluginRewriteResult(..)-- -- ** Querying for type family reductions-- , matchFam- , getFamInstEnvs- , FamInstEnv-- -- ** Specifying type family reductions-- -- | A plugin that wants to rewrite a type family application must provide two- -- pieces of information:- --- -- - the type that the type family application reduces to,- -- - evidence for this reduction, i.e. a 'GHC.Core.TyCo.Rep.Coercion' proving the equality.- --- -- In the rewriting stage, type-checking plugins have access to the rewriter- -- environment 'RewriteEnv', which has information about the location of the- -- type family application, the local type-checking environment, among other things.- --- -- Note that a plugin should provide a 'UniqFM' from 'TyCon' to rewriting functions,- -- which specifies a rewriting function for each type family.- -- Use 'emptyUFM' or 'listToUFM' to construct this map,- -- or import the GHC module "GHC.Types.Unique.FM" for a more complete API.- , askRewriteEnv, rewriteEnvCtLoc, RewriteEnv- , mkTyFamAppReduction, Reduction(..)-- -- * Handling Haskell types-- -- ** Type variables- , newUnique- , newFlexiTyVar- , isTouchableTcPluginM- , mkTyVarTy, mkTyVarTys- , isTyVarTy, getTyVar_maybe- , TcType, TcTyVar, Unique, Kind-- -- ** Type literals (natural numbers, type-level strings)- , mkNumLitTy, isNumLitTy- , mkStrLitTy, isStrLitTy-- -- ** Creating and decomposing applications- , mkTyConTy, mkTyConApp, mkAppTy, mkAppTys- , splitTyConApp_maybe- , tyConAppTyConPicky_maybe, tyConAppTyCon_maybe- , splitAppTy_maybe, splitAppTys-- -- ** Function types- , mkVisFunTyMany, mkVisFunTysMany- , mkInvisFunTyMany, mkInvisFunTysMany- , mkForAllTy, mkForAllTys- , mkPiTy, mkPiTys--#if MIN_VERSION_ghc(9,0,0)- , Mult, pattern One, pattern Many-#endif-- -- ** Zonking-- -- | Zonking is the operation in which GHC actually switches out mutable unification variables- -- for their actual filled in type.- --- -- See the Note [What is zonking?] in GHC's source code for more information.- , zonkTcType- , zonkCt-- -- ** Panicking-- -- | It is often better for type-checking plugins to panic when encountering a problem,- -- as opposed to silently doing something wrong. Use 'pprPanic' to throw an informative- -- error message, so that users of your plugin can report an issue if a problem occurs.- , panic, pprPanic-- -- ** Map-like data structures based on 'Unique's-- -- | Import "GHC.Types.Unique.FM" or "GHC.Types.Unique.DFM" for- -- a more complete interface to maps whose keys are 'Unique's.-- , UniqDFM- , lookupUDFM, lookupUDFM_Directly, elemUDFM- , UniqFM- , emptyUFM, listToUFM-- -- * The type-checking environment- , getEnvs-- -- * Built-in types-- -- | This module also re-exports the built-in types that GHC already knows about.- --- -- This allows plugins to directly refer to e.g. the promoted data constructor- -- 'True' without having to look up its name.- --- -- Refer to "GHC.Builtin.Names", "GHC.Builtin.Types" and "GHC.Builtin.Types.Prim".-- -- * GHC types-- -- | These are the types that the plugin will inspect and manipulate.-- -- | = END OF API DOCUMENTATION, RE-EXPORTS FOLLOW-- -- | == Some basic types-- , module GHC.Types.Basic-- -- | == Names- , Name, OccName, TyThing, TcTyThing- , MonadThings(..)- , Class(classTyCon), DataCon, TyCon, Id- , FastString-- -- | == Constraints- , EqRel(..), FunDep, CtFlavour- , Ct, CtLoc, CtEvidence, CtOrigin- , QCInst- , Type, PredType- , InstEnvs, TcLevel-- -- | === Coercions and evidence- , Coercion, Role(..), UnivCoProvenance- , CoercionHole(..)- , EvBind, EvTerm(EvExpr), EvVar, EvExpr, EvBindsVar- , Expr(Var, Type, Coercion), CoreBndr, CoreExpr- , TcEvDest(..)-- -- | == The type-checking environment- , TcGblEnv, TcLclEnv-- -- | == Source locations- , GenLocated(..), Located, RealLocated- , unLoc, getLoc-- -- | == Pretty-printing- , SDoc, Outputable(..)-- )- where---- ghc-import GHC- ( TyThing(..) )-#if !MIN_VERSION_ghc(9,0,0)-import GHC.Builtin.Types- ( intDataCon )-import GHC.Builtin.Types.Prim- ( intPrimTy )-#endif-import GHC.Core- ( CoreBndr, CoreExpr, Expr(..) )-import GHC.Core.Class- ( Class(..), FunDep )-import GHC.Core.Coercion- ( mkReflCo, mkSymCo, mkTransCo- , mkUnivCo-#if MIN_VERSION_ghc(8,10,0)- , mkPrimEqPredRole-#endif- )-import GHC.Core.Coercion.Axiom- ( Role(..) )-import GHC.Core.DataCon- ( DataCon- , classDataCon, promoteDataCon- )-import GHC.Core.FamInstEnv- ( FamInstEnv )-import GHC.Core.InstEnv- ( InstEnvs(..) )-#if !MIN_VERSION_ghc(9,0,0)-import GHC.Core.Make- ( mkCoreConApps )-#endif-import GHC.Core.Predicate- ( EqRel(..)-#if MIN_VERSION_ghc(8,10,0)- , Pred(..)-#else- , PredTree(..), TyCoBinder- , mkPrimEqPred, mkReprPrimEqPred-#endif- , classifyPredType, mkClassPred- )-#if HAS_REWRITING-import GHC.Core.Reduction- ( Reduction(..) )-#endif-import GHC.Core.TyCon- ( TyCon(..) )-import GHC.Core.TyCo.Rep- ( Type, PredType, Kind- , Coercion(..), CoercionHole(..)- , UnivCoProvenance(..)-#if MIN_VERSION_ghc(9,0,0)- , Mult- , mkVisFunTyMany, mkVisFunTysMany- , mkInvisFunTyMany, mkInvisFunTysMany-#elif MIN_VERSION_ghc(8,10,0)- , mkVisFunTy, mkVisFunTys- , mkInvisFunTy, mkInvisFunTys-#else- , mkFunTy, mkFunTys-#endif-#if MIN_VERSION_ghc(8,10,0)- , mkPiTy-#endif- , mkPiTys- , mkTyVarTy, mkTyVarTys- , mkForAllTy, mkForAllTys- )-import GHC.Core.Type- ( eqType, mkTyConTy, mkTyConApp, splitTyConApp_maybe- , splitAppTy_maybe, splitAppTys- , tyConAppTyConPicky_maybe, tyConAppTyCon_maybe- , mkAppTy, mkAppTys, isTyVarTy, getTyVar_maybe- , mkCoercionTy, isCoercionTy, isCoercionTy_maybe- , mkNumLitTy, isNumLitTy, mkStrLitTy, isStrLitTy-#if MIN_VERSION_ghc(9,0,0)- , pattern One, pattern Many-#endif- )-import GHC.Data.FastString- ( FastString, fsLit, unpackFS )-import qualified GHC.Tc.Plugin- as GHC-import GHC.Tc.Types- ( TcTyThing(..), TcGblEnv(..), TcLclEnv(..)-#if HAS_REWRITING- , TcPluginSolveResult(..), TcPluginRewriteResult(..)- , RewriteEnv(..)-#endif- )-import GHC.Tc.Types.Constraint- ( Ct(..), CtLoc(..), CtEvidence(..), CtFlavour(..)- , QCInst(..), TcEvDest(..)- , ctPred, ctLoc, ctEvidence, ctEvExpr- , ctFlavour, ctEqRel, ctOrigin- , bumpCtLocDepth- , mkNonCanonical- )-import GHC.Tc.Types.Evidence- ( EvBind(..), EvTerm(..), EvExpr, EvBindsVar(..)- , evCoercion, evCast, lookupEvBind, evDataConApp- )-import GHC.Tc.Types.Origin- ( CtOrigin(..) )-import GHC.Tc.Utils.Monad- ( newName )-import qualified GHC.Tc.Utils.Monad- as GHC- ( traceTc, setCtLocM )-import GHC.Tc.Utils.TcType- ( TcType, TcLevel, MetaDetails, MetaInfo- , isSkolemTyVar, isMetaTyVar- )-import GHC.Tc.Utils.TcMType- ( isFilledMetaTyVar_maybe, writeMetaTyVar )-import GHC.Types.Basic- ( Arity, PromotionFlag(..), isPromoted- , Boxity(..), TupleSort(..)- )-import GHC.Types.Id- ( Id, mkLocalId )-#if !MIN_VERSION_ghc(9,0,0)-import GHC.Types.Literal- ( Literal(..), LitNumType(..) )-#endif-import GHC.Types.Name- ( Name )-import GHC.Types.Name.Occurrence- ( 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- )-import GHC.Types.Unique- ( Unique )-#if MIN_VERSION_ghc(9,0,0)-import GHC.Types.Unique.FM as UniqFM- ( UniqFM, emptyUFM, listToUFM )-#else-import qualified GHC.Types.Unique.FM as GHC- ( UniqFM )-import GHC.Types.Unique.FM as UniqFM- ( emptyUFM, listToUFM )-#endif-import GHC.Types.Unique.DFM- ( UniqDFM, lookupUDFM, lookupUDFM_Directly, elemUDFM )-import GHC.Types.Var- ( TyVar, CoVar, TcTyVar, EvVar- , mkTyVar- )-import GHC.Utils.Outputable- ( Outputable(..), SDoc-#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- ( panic, pprPanic )-#endif-#if MIN_VERSION_ghc(9,2,0)-import GHC.Unit.Finder- ( FindResult(..) )-#else-import GHC.Driver.Finder- ( FindResult(..) )-#endif-import GHC.Unit.Module- ( 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 )---- 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-------------------------------------------------------------------------------------- | Run an 'IO' computation within the plugin.-tcPluginIO :: MonadTcPlugin m => IO a -> m a-tcPluginIO = unsafeLiftTcM . liftIO---- | Output some debugging information within the plugin.-tcPluginTrace :: MonadTcPlugin m- => String -- ^ Text at the top of the debug message.- -> SDoc -- ^ Formatted document to print (use the 'ppr' pretty-printing function to obtain an 'SDoc' from any 'Outputable')- -> m ()-tcPluginTrace a b = unsafeLiftTcM $ GHC.traceTc a b------------------------------------------------------------------------------------#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"@.- -> PkgQual -- ^ Package name, e.g. @Just "base"@.- -- Use @Nothing@ for the current home package- -> m FindResult-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'.------ Example usage:------ > lookupOrig preludeModule ( mkTcOcc "Bool" )------ This will obtain the 'Name' associated with the type 'Bool'.------ You can then call 'tcLookupTyCon' to obtain the associated 'TyCon'.-lookupOrig :: MonadTcPlugin m => Module -> OccName -> m Name-lookupOrig md = liftTcPluginM . GHC.lookupOrig md---- | Lookup a type constructor from its name (datatype, type synonym or type family).-tcLookupTyCon :: MonadTcPlugin m => Name -> m TyCon-tcLookupTyCon = liftTcPluginM . GHC.tcLookupTyCon---- | Lookup a data constructor (such as 'True', 'Just', ...) from its name.-tcLookupDataCon :: MonadTcPlugin m => Name -> m DataCon-tcLookupDataCon = liftTcPluginM . GHC.tcLookupDataCon---- | Lookup a typeclass from its name.-tcLookupClass :: MonadTcPlugin m => Name -> m Class-tcLookupClass = liftTcPluginM . GHC.tcLookupClass---- | Lookup a global typecheckable-thing from its name.-tcLookupGlobal :: MonadTcPlugin m => Name -> m TyThing-tcLookupGlobal = liftTcPluginM . GHC.tcLookupGlobal---- | Lookup a typecheckable-thing available in a local context,--- such as a local type variable.-tcLookup :: MonadTcPlugin m => Name -> m TcTyThing-tcLookup = liftTcPluginM . GHC.tcLookup---- | Lookup an identifier, such as a type variable.-tcLookupId :: MonadTcPlugin m => Name -> m Id-tcLookupId = liftTcPluginM . GHC.tcLookupId------------------------------------------------------------------------------------{--getTopEnv :: MonadTcPlugin m => m HscEnv-getTopEnv = liftTcPluginM GHC.getTopEnv--}---- | Obtain the current global and local type-checking environments.-getEnvs :: MonadTcPlugin m => m ( TcGblEnv, TcLclEnv )-getEnvs = liftTcPluginM GHC.getEnvs---- | Obtain all currently-reachable typeclass instances.-getInstEnvs :: MonadTcPlugin m => m InstEnvs-getInstEnvs = liftTcPluginM GHC.getInstEnvs---- | Obtain all currently-reachable data/type family instances.------ First result: external instances.--- Second result: instances in the current home package.-getFamInstEnvs :: MonadTcPlugin m => m ( FamInstEnv, FamInstEnv )-getFamInstEnvs = liftTcPluginM GHC.getFamInstEnvs---- | Ask GHC what a type family application reduces to.------ __Warning__: can cause a loop when used within 'tcPluginRewrite'.-matchFam :: MonadTcPlugin m- => TyCon -> [ TcType ]- -> m ( Maybe Reduction )-matchFam tycon args =-#ifndef HAS_REWRITING- fmap ( \ (co,ty) -> mkReduction (mkSymCo co) ty ) <$>- -- GHC 9.0 and 9.2 use a different orientation- -- when rewriting type family applications.-#endif- ( liftTcPluginM $ GHC.matchFam tycon args )-------------------------------------------------------------------------------------- | Create a new unique. Useful for generating new variables in the plugin.-newUnique :: MonadTcPlugin m => m Unique-newUnique = liftTcPluginM GHC.newUnique---- | Create a new meta-variable (unification variable) of the given kind.-newFlexiTyVar :: MonadTcPlugin m => Kind -> m TcTyVar-newFlexiTyVar = liftTcPluginM . GHC.newFlexiTyVar---- | Query whether a type variable is touchable:--- - is it a unification variable (and not a skolem variable)?--- - is it actually unifiable given the current 'TcLevel'?-isTouchableTcPluginM :: MonadTcPlugin m => TcTyVar -> m Bool-isTouchableTcPluginM = liftTcPluginM . GHC.isTouchableTcPluginM-------------------------------------------------------------------------------------- | Zonk the given type, which takes the metavariables in the type and--- substitutes their actual value.-zonkTcType :: MonadTcPluginWork m => TcType -> m TcType-zonkTcType = liftTcPluginM . GHC.zonkTcType---- | Zonk a given constraint.-zonkCt :: MonadTcPluginWork m => Ct -> m Ct-zonkCt = liftTcPluginM . GHC.zonkCt-------------------------------------------------------------------------------------- | Create a new Wanted constraint.------ Requires a location (so that error messages can say where the constraint came from,--- what things were in scope at that point, etc), as well as the actual constraint (encoded as a type).-newWanted :: MonadTcPluginWork m => CtLoc -> PredType -> m CtEvidence-newWanted loc pty =-#if !HAS_REWRITING- -- On GHC 9.2 and below, 'newWanted' doesn't use the location information- -- that is passed to it, retrieving it from the 'TcM' environment instead.- -- https://gitlab.haskell.org/ghc/ghc/-/issues/20895- setCtLocM loc $-#endif- liftTcPluginM $ GHC.newWanted loc pty---- | Create a new Given constraint.------ Unlike 'newWanted', we need to supply evidence for this constraint.-newGiven :: CtLoc -> PredType -> EvExpr -> 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-#endif----- | Obtain the 'CtLoc' from a 'RewriteEnv'.------ This can be useful to obtain the location of the--- constraint currently being rewritten,--- so that newly emitted constraints can be given--- the same location information.-rewriteEnvCtLoc :: RewriteEnv -> CtLoc-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-setCtLocM loc = unsafeLiftThroughTcM ( GHC.setCtLocM loc )---- | Use the 'RewriteEnv' to set the 'CtLoc' for a computation.-setCtLocRewriteM :: TcPluginM Rewrite a -> TcPluginM Rewrite a-setCtLocRewriteM ma = do- rewriteCtLoc <- rewriteEnvCtLoc <$> askRewriteEnv- setCtLocM rewriteCtLoc ma-------------------------------------------------------------------------------------- | Create a fresh evidence variable.-newEvVar :: PredType -> TcPluginM Solve EvVar-newEvVar = liftTcPluginM . GHC.newEvVar---- | Create a fresh coercion hole.-newCoercionHole :: PredType -> TcPluginM Solve CoercionHole-newCoercionHole = liftTcPluginM . GHC.newCoercionHole---- | Bind an evidence variable.-setEvBind :: EvBind -> TcPluginM Solve ()-setEvBind ev_bind = do-#if HAS_REWRITING- tc_evbinds <- askEvBinds- liftTcPluginM $ GHC.setEvBind tc_evbinds ev_bind-#else- liftTcPluginM $ GHC.setEvBind ev_bind-#endif-------------------------------------------------------------------------------------- | Conjure up a coercion witnessing an equality between two types--- at the given 'Role' ('Nominal' or 'Representational').------ This amounts to telling GHC "believe me, these things are equal".------ The plugin is responsible for not emitting any unsound coercions,--- such as a coercion between 'Int' and 'Float'.-mkPluginUnivCo- :: String -- ^ Name of equality (for the plugin's internal use, or for debugging)- -> Role- -> TcType -- ^ LHS- -> TcType -- ^ RHS- -> Coercion-mkPluginUnivCo str role lhs rhs = mkUnivCo ( PluginProv str ) role lhs rhs---- | Conjure up an evidence term for an equality between two types--- at the given 'Role' ('Nominal' or 'Representational').------ This can be used to supply a proof of a wanted equality in 'TcPluginOk'.------ The plugin is responsible for not emitting any unsound equalities,--- such as an equality between 'Int' and 'Float'.-mkPluginUnivEvTerm- :: String -- ^ Name of equality (for the plugin's internal use, or for debugging)- -> Role- -> TcType -- ^ LHS- -> TcType -- ^ RHS- -> EvTerm-mkPluginUnivEvTerm str role lhs rhs = evCoercion $ mkPluginUnivCo str role lhs rhs---- | Provide a rewriting of a saturated type family application--- at the given 'Role' ('Nominal' or 'Representational').------ The result can be passed to 'TcPluginRewriteTo' to specify the outcome--- of rewriting a type family application.-mkTyFamAppReduction- :: String -- ^ Name of reduction (for debugging)- -> Role -- ^ Role of reduction ('Nominal' or 'Representational')- -> TyCon -- ^ Type family 'TyCon'- -> [TcType] -- ^ Type family arguments- -> TcType -- ^ The type that the type family application reduces to- -> Reduction-mkTyFamAppReduction str role tc args ty =- Reduction ( mkPluginUnivCo str role ( mkTyConApp tc args ) ty ) ty------------------------------------------------------------------------------------#if !MIN_VERSION_ghc(9,0,0)--type UniqFM ty a = GHC.UniqFM a--mkUncheckedIntExpr :: Integer -> CoreExpr-mkUncheckedIntExpr i = mkCoreConApps intDataCon [Lit lit]- where- lit = LitNumber LitNumInt i intPrimTy--#if MIN_VERSION_ghc(8,10,0)--mkInvisFunTyMany, mkVisFunTyMany :: Type -> Type -> Type-mkInvisFunTyMany = mkInvisFunTy-mkVisFunTyMany = mkVisFunTy--mkInvisFunTysMany, mkVisFunTysMany :: [Type] -> Type -> Type-mkInvisFunTysMany = mkInvisFunTys-mkVisFunTysMany = mkVisFunTys--#else--type Pred = PredTree--mkInvisFunTyMany, mkVisFunTyMany :: Type -> Type -> Type-mkInvisFunTyMany = mkFunTy-mkVisFunTyMany = mkFunTy--mkInvisFunTysMany, mkVisFunTysMany :: [Type] -> Type -> Type-mkInvisFunTysMany = mkFunTys-mkVisFunTysMany = mkFunTys--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-#endif+{-# LANGUAGE CPP #-} + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE UndecidableInstances #-} + +#if !MIN_VERSION_ghc(8,11,0) +{-# OPTIONS_GHC -Wno-orphans #-} +#endif + +{-| +Module: GHC.TcPlugin.API + +This module provides a unified interface for writing type-checking plugins for GHC. + +It attempts to re-export all the functionality from GHC that is relevant to plugin authors, +as well as providing utility functions to streamline certain common operations such as +creating evidence (to solve constraints), rewriting type family applications, throwing custom type errors. + +Consider making use of the table of contents to help navigate this documentation; +don't hesitate to jump between sections to get an overview of the relevant aspects. + +For an illustration of the functionality, check the examples in the associated +<https://github.com/sheaf/ghc-tcplugin-api GitHub repository>. + +The internal module "GHC.TcPlugin.API.Internal" can be used to directly +lift and unlift computations in GHC's 'GHC.Tc.Types.TcM' monad, but it is hoped that +the interface provided in this module is sufficient. + +-} + +module GHC.TcPlugin.API + ( -- * Basic TcPlugin functionality + + -- ** The 'TcPlugin' type + TcPlugin(..) + , mkTcPlugin + + -- ** Plugin state + -- | A type-checker plugin can define its own state, corresponding to the existential parameter @s@ + -- in the definition of 'TcPlugin'. + -- This allows a plugin to look up information a single time + -- on initialisation, and pass it on for access in all further invocations of the plugin. + -- + -- For example: + -- + -- > data MyDefinitions { myTyFam :: !TyCon, myClass :: !Class } + -- + -- Usually, the 'tcPluginInit' part of the plugin looks up all this information and returns it: + -- + -- > myTcPluginInit :: TcPluginM Init MyDefinitions + -- + -- This step should also be used to initialise any external tools, + -- such as an external SMT solver. + -- + -- This information will then be passed to other stages of the plugin: + -- + -- > myTcPluginSolve :: MyDefinitions -> TcPluginSolver + + -- ** The type-checking plugin monads + + -- | Different stages of type-checking plugins have access to different information. + -- For a unified interface, an MTL-style approach is used, with the 'MonadTcPlugin' + -- typeclass providing overloading (for operations that work in all stages). + , TcPluginStage(..), MonadTcPlugin + , TcPluginM + + -- *** Emitting new work, and throwing type-errors + + -- | Some operations only make sense in the two main phases, solving and rewriting. + -- This is captured by the 'MonadTcPluginWork' typeclass, which allows emitting + -- new work, including throwing type errors. + , MonadTcPluginWork + , TcPluginErrorMessage(..) + , mkTcPluginErrorTy + + -- * Name resolution + + -- | 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. + -- + -- 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. + -- + -- > 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 + -- > findResult <- findImportedModule modlName pkgQual + -- > case findResult of + -- > Found _ myModule -> pure myModule + -- > _ -> error "MyPlugin couldn't find MyModule in my-pkg" + -- > + -- > lookupMyFam :: MonadTcPlugin m => Module -> m TyCon + -- > lookupMyFam myModule = tcLookupTyCon =<< lookupOrig myModule ( mkTcOcc "MyFam" ) + -- + -- Most of these operations should be performed in 'tcPluginInit', and passed on + -- 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. + + -- ** 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 + + -- **** 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 + + -- | 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 + + -- ** 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 + -- using their 'Name'. + , tcLookupTyCon + , tcLookupDataCon + , tcLookupClass + , tcLookupGlobal + , tcLookup + , tcLookupId + , promoteDataCon + + -- * Constraint solving + + -- | Type-checking plugins will often want to manipulate constraints, + -- e.g. solve constraints that GHC can't solve on its own, or emit + -- their own constraints. + -- + -- There are two different constraint flavours: + -- + -- - Given constraints, which are already known and + -- have evidence associated to them, + -- - Wanted constraints, for which evidence has not yet been found. + -- + -- When GHC can't solve a Wanted constraint, it will get reported to the + -- user as a type error. + + , TcPluginSolver +#if HAS_REWRITING + , TcPluginSolveResult(..) +#else + , TcPluginSolveResult + , pattern TcPluginContradiction, pattern TcPluginOk +#endif + + -- | The 'tcPluginSolve' method of a typechecker plugin will be invoked + -- in two different ways: + -- + -- 1. to simplify Given constraints. In this case, the 'tcPluginSolve' function + -- will not be passed any Wanted constraints, and + -- 2. to solve Wanted constraints. + -- + -- The plugin can then respond in one of two ways: + -- + -- - with @TcPluginOk solved new@, where @solved@ is a list of solved constraints + -- and @new@ is a list of new constraints for GHC to process; + -- - with @TcPluginContradiction contras@, where @contras@ is a list of impossible + -- constraints, so that they can be turned into errors. + -- + -- In both cases, the plugin must respond with constraints of the same flavour, + -- i.e. in (1) it should return only Givens, and for (2) it should return only + -- Wanteds; all other constraints will be ignored. + + -- ** Getting started with constraint solving + + -- | To get started, it can be helpful to immediately print out all the constraints + -- that the plugin is given, using 'tcPluginTrace': + -- + -- > solver _ givens wanteds = do + -- > tcPluginTrace "---Plugin start---" (ppr givens $$ ppr wanteds) + -- > pure $ TcPluginOk [] [] + -- + -- This creates a plugin that prints outs the constraints it is passed, + -- without doing anything with them. + -- + -- To see this output, you will need to pass the flags @-ddump-tc-trace@ + -- and @-ddump-to-file@ to GHC. This will output the trace as a log file, + -- and you can search for @"---Plugin start---"@ to find the plugin inputs. + -- + -- Note that pretty-printing in GHC is done using the 'Outputable' type class. + -- We use its 'ppr' method to turn things into pretty-printable documents, + -- and '($$)' to combine documents vertically. + -- If you need more capabilities for pretty-printing documents, + -- import GHC's "GHC.Utils.Outputable" module. + , tcPluginTrace + + -- ** Inspecting constraints & predicates + + -- *** Canonical and non-canonical constraints + + -- | A constraint in GHC starts out as "non-canonical", which means that + -- GHC doesn't know what type of constraint it is. + -- GHC will inspect the constraint to turn it into a canonical form + -- (class constraint, equality constraint, etc.) which satisfies certain + -- invariants used during constraint solving. + -- + -- Thus, whenever emitting new constraints, it is usually best to emit a + -- non-canonical constraint, letting GHC canonicalise it. + , mkNonCanonical + + -- *** Predicates + + -- | A type-checking plugin will usually need to inspect constraints, + -- so that it can pick out the constraints it is going to interact with. + -- + -- In general, type-checking plugins can encounter all sorts of constraints, + -- whether in canonical form or not. + -- In order to handle these constraints in a uniform manner, it is usually + -- preferable to inspect each constraint's predicate, which can be obtained + -- by using 'classifyPredType' and 'ctPred'. + -- + -- This allows the plugin to determine what kind of constraints it is dealing with: + -- + -- - an equality constraint? at 'Nominal' or 'Representational' role? + -- - a type-class constraint? for which class? + -- - an irreducible constraint, e.g. something of the form @c a@? + -- - a quantified constraint? + , Pred + , pattern ClassPred, pattern EqPred, pattern IrredPred, pattern ForAllPred + , classifyPredType, ctPred + + -- | == Handling type variables + , TyVar, CoVar + , MetaDetails, MetaInfo + , isSkolemTyVar + , isMetaTyVar, isFilledMetaTyVar_maybe + , writeMetaTyVar + , readTcRef, writeTcRef + + -- | == Some further functions for inspecting constraints + , eqType, nonDetCmpType + , ctLoc, ctEvidence, ctFlavour, ctEqRel, ctOrigin + , ctEvPred, ctEvId, ctEvExpr, ctEvLoc + , isGiven, isWanted + , isEqPred, isEqClassPred + , className, tyConName + + -- ** Constraint evidence + + -- *** Coercions + + -- | 'GHC.Core.TyCo.Rep.Coercion's are the evidence for type equalities. + -- As such, when proving an equality, a type-checker plugin needs + -- to construct the associated coercions. + , mkPluginUnivCo + , newCoercionHole + , mkReflCo, mkSymCo, mkTransCo, mkUnivCo + , mkCoercionTy, isCoercionTy, isCoercionTy_maybe + + -- *** Depending on outer Givens + + -- | When a plugin returns a coercion that depends on outer Given constraints, + -- it should declare this dependency using the '[Coercion]' argument to + -- functions such as 'mkPluginUnivCo', 'mkPluginUnivEvTerm' and 'mkTyFamAppReduction' + -- in order to avoid this coercion getting floated out past such enclosing + -- Givens. + -- + -- You can use 'ctEvCoercion' to obtain the coercion underlying an equality + -- constraint (whether Given or Wanted). It is not possible to declare + -- a dependency on non-equality constraints, and calling 'ctEvCoercion' + -- on a non-equality constraint will cause a crash. + , ctEvCoercion + + -- *** Evidence terms + + -- | Typeclass constraints have a different notion of evidence: evidence terms. + -- + -- A plugin that wants to solve a class constraint will need to provide + -- an evidence term. Such evidence can be created from scratch, or it can be obtained + -- by combining evidence that is already available. + + , mkPluginUnivEvTerm + , evDFunApp, evDataConApp + , newEvVar, setEvBind + , evId, evCoercion, evCast + , askEvBinds, lookupEvBind, eb_lhs, eb_rhs + , newName, mkLocalId, mkTyVar + + -- *** Class dictionaries + + -- | To create evidence terms for class constraints, type-checking plugins + -- need to be able to construct the appropriate dictionaries containing + -- the values for the class methods. + -- + -- The class dictionary constructor can be obtained using 'classDataCon'. + -- Functions from "GHC.Core.Make", which is re-exported by this library, + -- will be useful for constructing the necessary terms + -- + -- For instance, we can apply the class data constructor using 'mkCoreConApps'. + -- Remember that the type-level arguments (the typeclass variables) come first, + -- before the actual evidence term (the class dictionary expression). + + , classDataCon +#if !MIN_VERSION_ghc(9,0,0) + , mkUncheckedIntExpr +#endif + + -- | ==== Class instances + + -- | In some cases, a type-checking plugin might need to access the + -- class instances that are currently in scope, e.g. to obtain certain + -- evidence terms. + , getInstEnvs + + -- ** Emitting new constraints + + , newWanted, newGiven + + -- | The following functions allow plugins to create constraints + -- for typeclasses and type equalities. + , mkClassPred, mkEqPredRole + + -- | === Deriveds + + -- | Derived constraints are like Wanted constraints, except that they + -- don't require evidence in order to be solved, and won't be seen + -- in error messages if they go unsolved. + -- + -- Solver plugins usually ignore this type of constraint entirely. + -- They occur mostly when dealing with functional dependencies and type-family + -- injectivity annotations. + -- + -- GHC 9.4 removes this flavour of constraints entirely, subsuming their uses into + -- Wanted constraints. + , askDeriveds + + -- ** Location information and 'CtLoc's + + -- | When creating new constraints, one still needs a mechanism allowing GHC + -- to report a certain source location associated to them when throwing an error, + -- as well as other information the type-checker was aware of at that point + -- (e.g. available instances, given constraints, etc). + -- + -- This is the purpose of 'CtLoc'. + , setCtLocM + , setCtLocRewriteM + + -- | 'bumpCtLocDepth' adds one to the "depth" of the constraint. + -- Can help avoid loops, by triggering a "maximum depth exceeded" error. + , bumpCtLocDepth + + -- * Rewriting type-family applications + + , TcPluginRewriter, TcPluginRewriteResult(..) + + -- ** Querying for type family reductions + + , matchFam + , getFamInstEnvs + , FamInstEnv + + -- ** Specifying type family reductions + + -- | A plugin that wants to rewrite a type family application must provide two + -- pieces of information: + -- + -- - the type that the type family application reduces to, + -- - evidence for this reduction, i.e. a 'GHC.Core.TyCo.Rep.Coercion' proving the equality. + -- + -- In the rewriting stage, type-checking plugins have access to the rewriter + -- environment 'RewriteEnv', which has information about the location of the + -- type family application, the local type-checking environment, among other things. + -- + -- Note that a plugin should provide a 'UniqFM' from 'TyCon' to rewriting functions, + -- which specifies a rewriting function for each type family. + -- Use 'emptyUFM' or 'listToUFM' to construct this map, + -- or import the GHC module "GHC.Types.Unique.FM" for a more complete API. + , askRewriteEnv, rewriteEnvCtLoc, RewriteEnv + , mkTyFamAppReduction, Reduction(..) + + -- * Handling Haskell types + + -- ** Type variables + , newUnique + , newFlexiTyVar + , isTouchableTcPluginM + , mkTyVarTy, mkTyVarTys + , isTyVarTy, getTyVar_maybe + , TcType, TcTyVar, Unique, Kind + + -- ** Type literals (natural numbers, type-level strings) + , mkNumLitTy, isNumLitTy + , mkStrLitTy, isStrLitTy + , natKind, symbolKind, charKind + + -- ** Creating and decomposing applications + , mkTyConTy, mkTyConApp, mkAppTy, mkAppTys + , splitTyConApp_maybe + , tyConAppTyConPicky_maybe, tyConAppTyCon_maybe + , splitAppTy_maybe, splitAppTys + , isNewTyCon, dataConTyCon + + -- ** Data constructors + , tyConDataCons, tyConSingleDataCon_maybe, tyConSingleDataCon + , isNewDataCon + + -- ** Function types + , mkVisFunTyMany, mkVisFunTysMany + , mkInvisFunTy, mkInvisFunTys + , mkForAllTy, mkForAllTys + , mkPiTy, mkPiTys + + -- ** Kinds + , typeKind + +#if MIN_VERSION_ghc(9,0,0) + , Mult + , pattern OneTy, pattern ManyTy +#endif + + -- ** Substitution + , Subst + , substTy, substTys + , mkTvSubstPrs, extendTvSubst + , ctsSubst + + -- ** Zonking + + -- | Zonking is the operation in which GHC actually switches out mutable unification variables + -- for their actual filled in type. + -- + -- See the Note [What is zonking?] in GHC's source code for more information. + , zonkTcType + , zonkCt + + -- ** Panicking + + -- | It is often better for type-checking plugins to panic when encountering a problem, + -- as opposed to silently doing something wrong. Use 'pprPanic' to throw an informative + -- error message, so that users of your plugin can report an issue if a problem occurs. + , panic, pprPanic + + -- ** Map-like data structures based on 'Unique's + + -- | Import "GHC.Types.Unique.FM" or "GHC.Types.Unique.DFM" for + -- a more complete interface to maps whose keys are 'Unique's. + + , UniqDFM + , lookupUDFM, lookupUDFM_Directly, elemUDFM + , UniqFM + , emptyUFM, listToUFM + + -- * The type-checking environment + , getEnvs + + -- * Interacting with GHC's constraint solver + , TcS + , InertSet, getInertSet, setInertSet + , getTcEvBindsMap, setTcEvBindsMap + + -- * Built-in types + + -- | This module also re-exports the built-in types that GHC already knows about. + -- + -- This allows plugins to directly refer to e.g. the promoted data constructor + -- 'True' without having to look up its name. + -- + -- Refer to "GHC.Builtin.Names", "GHC.Builtin.Types" and "GHC.Builtin.Types.Prim". + + -- * GHC types + + -- | These are the types that the plugin will inspect and manipulate. + + -- | = END OF API DOCUMENTATION, RE-EXPORTS FOLLOW + + -- | == Some basic types + + , module GHC.Types.Basic + + -- | == Names + , Name, OccName, TyThing, TcTyThing + , MonadThings(..) + , Class(classTyCon), DataCon, TyCon, Id + , FastString + + -- | == Constraints + , EqRel(..), FunDep, CtFlavour + , Ct, CtLoc, CtEvidence, CtOrigin + , QCInst + , Type, PredType + , InstEnvs, TcLevel + + -- | === Coercions and evidence + , Coercion, Role(..), UnivCoProvenance + , CoercionHole(..) + , EvBind, EvTerm(EvExpr), EvVar, EvExpr, EvBindsVar + , Expr(Var, Type, Coercion), CoreBndr, CoreExpr + , TcEvDest(..) + + -- | == The type-checking environment + , TcGblEnv, TcLclEnv + + -- | == Source locations + , GenLocated(..), Located, RealLocated + , unLoc, getLoc + + -- | == Pretty-printing + , SDoc, Outputable(..) + + ) + where + +-- base +import Prelude + hiding ( cos ) +#if !MIN_VERSION_base(4,20,0) +import Data.Foldable + ( foldl' ) +#endif +#if !MIN_VERSION_ghc(8,11,0) +import Data.List.NonEmpty + ( NonEmpty(..) ) +#endif +import Data.Maybe + ( mapMaybe ) + +-- 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 ) +import GHC.Builtin.Types.Prim + ( intPrimTy ) +#endif +import GHC.Core + ( CoreBndr, CoreExpr, Expr(..), mkTyApps, mkApps ) +import GHC.Core.Class + ( Class(..), FunDep ) +import GHC.Core.Coercion + ( mkReflCo, mkSymCo, mkTransCo + , mkUnivCo, isReflCo +#if !MIN_VERSION_ghc(9,13,0) && MIN_VERSION_ghc(8,10,0) + , mkPrimEqPredRole +#endif + ) +import GHC.Core.Coercion.Axiom + ( Role(..) ) +import GHC.Core.DataCon + ( DataCon + , classDataCon, promoteDataCon, dataConWrapId + , dataConTyCon +#if MIN_VERSION_ghc(9,1,0) + , isNewDataCon +#endif + ) +import GHC.Core.FamInstEnv + ( FamInstEnv ) +import GHC.Core.InstEnv + ( InstEnvs(..) ) +#if !MIN_VERSION_ghc(9,0,0) +import GHC.Core.Make + ( mkCoreConApps ) +#endif +import GHC.Core.Predicate + ( EqRel(..) +#if MIN_VERSION_ghc(9,13,0) + , mkEqPredRole +#endif +#if MIN_VERSION_ghc(8,10,0) + , Pred(..) +#else + , PredTree(..), TyCoBinder + , mkPrimEqPred, mkReprPrimEqPred +#endif + , classifyPredType, mkClassPred + ) +#if HAS_REWRITING +import GHC.Core.Reduction + ( Reduction(..) ) +#endif +import GHC.Core.TyCon + ( TyCon(..), tyConClass_maybe + , tyConDataCons, tyConSingleDataCon_maybe, tyConSingleDataCon + , isNewTyCon + ) +#if MIN_VERSION_ghc(9,6,0) +import GHC.Core.TyCo.Compare + ( eqType ) +#endif +import GHC.Core.TyCo.Rep + ( Type, PredType, Kind + , Coercion(..), CoercionHole(..) + , UnivCoProvenance(..) +#if MIN_VERSION_ghc(9,0,0) + , Mult + , mkVisFunTyMany, mkVisFunTysMany +#if MIN_VERSION_ghc(9,6,0) + , mkInvisFunTy, mkInvisFunTys +#else + , mkInvisFunTyMany, mkInvisFunTysMany +#endif +#elif MIN_VERSION_ghc(8,10,0) + , mkVisFunTy, mkVisFunTys + , mkInvisFunTy, mkInvisFunTys +#else + , mkFunTy, mkFunTys +#endif +#if MIN_VERSION_ghc(8,10,0) + , mkPiTy +#endif + , mkPiTys + , mkTyVarTy, mkTyVarTys + , mkForAllTy, mkForAllTys + ) +import GHC.Core.Type + ( mkTyConTy, mkTyConApp, splitTyConApp_maybe + , splitAppTy_maybe, splitAppTys + , tyConAppTyConPicky_maybe, tyConAppTyCon_maybe + , mkAppTy, mkAppTys, isTyVarTy, getTyVar_maybe + , mkCoercionTy, isCoercionTy, isCoercionTy_maybe + , mkNumLitTy, isNumLitTy, mkStrLitTy, isStrLitTy + , typeKind +#if !MIN_VERSION_ghc(9,6,0) + , eqType +#endif +#if MIN_VERSION_ghc(9,6,0) + , pattern OneTy, pattern ManyTy +#elif MIN_VERSION_ghc(9,0,0) + , pattern One, pattern Many +#endif + , TvSubstEnv +#if MIN_VERSION_ghc(9,6,0) + , Subst +#else + , TCvSubst +#endif + ) +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) +import GHC.Tc.Solver.InertSet + ( InertSet ) +#endif +import GHC.Tc.Solver.Monad + ( TcS +#if !MIN_VERSION_ghc(9,4,0) + , InertSet +#endif +#if MIN_VERSION_ghc(9,8,0) + , getInertSet, updInertSet +#else + , getTcSInerts, setTcSInerts +#endif + , getTcEvBindsMap, setTcEvBindsMap + ) +import GHC.Tc.Types + ( TcTyThing(..), TcGblEnv(..), TcLclEnv(..) +#if HAS_REWRITING + , TcPluginSolveResult(..), TcPluginRewriteResult(..) + , RewriteEnv(..) +#endif + ) +#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 + , ctEvFlavour, ctEvPred, ctEvLoc + , mkNonCanonical, ctEvId + ) +import GHC.Tc.Types.Evidence + ( EvBind(..), EvTerm(..), EvExpr, EvBindsVar(..) + , evCoercion, lookupEvBind + , mkGivenEvBind, evId + ) +import GHC.Tc.Types.Origin + ( CtOrigin(..) ) +import GHC.Tc.Utils.Monad + ( newName, readTcRef, writeTcRef ) +import qualified GHC.Tc.Utils.Monad + as GHC + ( traceTc, setCtLocM ) +import GHC.Tc.Utils.TcType + ( TcType, TcLevel, MetaDetails, MetaInfo + , isSkolemTyVar, isMetaTyVar + , nonDetCmpType + , mkTvSubst, extendTvSubst + , substTy, substTys, mkTvSubstPrs + , tyCoVarsOfTypes + , scopedSort +#if MIN_VERSION_ghc(9,15,0) + , tyCoVarsOfTypes +#else + , tyCoFVsOfTypes +#endif + ) +import GHC.Tc.Utils.TcMType + ( isFilledMetaTyVar_maybe, writeMetaTyVar ) +import GHC.Types.Basic + ( Arity, PromotionFlag(..), isPromoted + , Boxity(..), TupleSort(..) + ) +import GHC.Types.Id + ( Id, mkLocalId ) +#if !MIN_VERSION_ghc(9,0,0) +import GHC.Types.Literal + ( Literal(..), LitNumType(..) ) +#endif +import GHC.Types.Name + ( Name ) +import GHC.Types.Name.Occurrence + ( OccName(..) + , mkVarOcc, mkDataOcc, mkTyVarOcc, mkTcOcc, mkClsOcc + ) +#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.Unit.Module + ( unitIdString ) +#elif MIN_VERSION_ghc(9,1,0) +import GHC.Data.FastString + ( NonDetFastString(NonDetFastString) ) +#endif +import GHC.Types.SrcLoc + ( GenLocated(..), Located, RealLocated + , unLoc, getLoc + ) +import GHC.Types.Unique + ( Unique ) +-- UniqFM didn't have the first argument in GHC < 9.0. +-- This adds a little compatibility shim for that. +#if MIN_VERSION_ghc(9,0,0) +import GHC.Types.Unique.FM as UniqFM + ( UniqFM ) +#else +import qualified GHC.Types.Unique.FM as GHC + ( UniqFM ) +#endif +import GHC.Types.Unique.FM + ( emptyUFM, listToUFM, nonDetEltsUFM ) +import GHC.Types.Unique.DFM + ( UniqDFM, lookupUDFM, lookupUDFM_Directly, elemUDFM ) +import GHC.Types.Var + ( TyVar, CoVar, TcTyVar, EvVar + , mkTyVar, DFunId, isTyVar, updateTyVarKind + ) +import GHC.Types.Var.Env + ( InScopeSet, mkInScopeSet, mapVarEnv, elemVarEnv ) +import GHC.Types.Var.Set + ( mkVarSet, unionVarSet +#if MIN_VERSION_ghc(9,15,0) + , nonDetVarSetElems +#endif + ) +import GHC.Utils.Outputable + ( 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 + ( FindResult(..) ) +#else +import GHC.Driver.Finder + ( FindResult(..) ) +#endif +import GHC.Unit.Module + ( 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 ) +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,5,0) +import GHC.Utils.Misc + ( HasDebugCallStack ) +#endif +#if MIN_VERSION_ghc(9,15,0) +#else +import GHC.Utils.FV + ( fvVarList ) +#endif +import GHC.Utils.Misc + ( filterOut ) + +-- 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 + +-- 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. + -> SDoc -- ^ Formatted document to print (use the 'ppr' pretty-printing function to obtain an 'SDoc' from any 'Outputable') + -> m () +tcPluginTrace a b = unsafeLiftTcM $ GHC.traceTc a b + +-------------------------------------------------------------------------------- + +#if MIN_VERSION_ghc(9,0,0) && !MIN_VERSION_ghc(9,5,0) +pattern OneTy, ManyTy :: Mult +pattern OneTy = One +pattern ManyTy = Many + +mkInvisFunTy :: HasDebugCallStack => Type -> Type -> Type +mkInvisFunTy = mkInvisFunTyMany + +mkInvisFunTys :: HasDebugCallStack => [Type] -> Type -> Type +mkInvisFunTys = mkInvisFunTysMany +#endif + +-------------------------------------------------------------------------------- + +#if MIN_VERSION_ghc(9,3,0) + +-- 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 + +-- | Get package name from package qualifier +pkgQualToPkgName :: PkgQual -> Maybe String +#if MIN_VERSION_ghc(9,3,0) +pkgQualToPkgName NoPkgQual = Nothing +pkgQualToPkgName (ThisPkg unit) = Just $ unitIdString unit +pkgQualToPkgName (OtherPkg unit) = Just $ unitIdString unit +#else +pkgQualToPkgName = fmap unpackFS . getPkgQual +#endif + +-- | 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) +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 +resolveImport _mod_name mPkg = do + return $ PkgQual mPkg +#endif + +-- | Lookup a Haskell module, with an optional package qualifier. +findImportedModule :: MonadTcPlugin m + => ModuleName -- ^ Module name, e.g. @"Data.List"@ + -> PkgQual -- ^ Package qualifier. See 'resolveImport' + -> m FindResult +#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'. +-- +-- Example usage: +-- +-- > lookupOrig preludeModule ( mkTcOcc "Bool" ) +-- +-- This will obtain the 'Name' associated with the type 'Bool'. +-- +-- You can then call 'tcLookupTyCon' to obtain the associated 'TyCon'. +lookupOrig :: MonadTcPlugin m => Module -> OccName -> m Name +lookupOrig md = liftTcPluginM . GHC.lookupOrig md + +-- | Lookup a type constructor from its name (datatype, type synonym or type family). +tcLookupTyCon :: MonadTcPlugin m => Name -> m TyCon +tcLookupTyCon = liftTcPluginM . GHC.tcLookupTyCon + +-- | Lookup a data constructor (such as 'True', 'Just', ...) from its name. +tcLookupDataCon :: MonadTcPlugin m => Name -> m DataCon +tcLookupDataCon = liftTcPluginM . GHC.tcLookupDataCon + +-- | Lookup a typeclass from its name. +tcLookupClass :: MonadTcPlugin m => Name -> m Class +tcLookupClass = liftTcPluginM . GHC.tcLookupClass + +-- | Lookup a global typecheckable-thing from its name. +tcLookupGlobal :: MonadTcPlugin m => Name -> m TyThing +tcLookupGlobal = liftTcPluginM . GHC.tcLookupGlobal + +-- | Lookup a typecheckable-thing available in a local context, +-- such as a local type variable. +tcLookup :: MonadTcPlugin m => Name -> m TcTyThing +tcLookup = liftTcPluginM . GHC.tcLookup + +-- | Lookup an identifier, such as a type variable. +tcLookupId :: MonadTcPlugin m => Name -> m Id +tcLookupId = liftTcPluginM . GHC.tcLookupId + +-------------------------------------------------------------------------------- + +#if !MIN_VERSION_ghc(9,6,0) +type Subst = TCvSubst +#endif + +-- | Compute an idempotent substitution from a collection of constraints, in +-- particular from inert Givens. +-- +-- NB: don't pass any set of constraints to this function; they should form a +-- terminating generalised substitution as in Note [inert_eqs: the inert equalities] +-- in GHC.Tc.Solver.InertSet. +ctsSubst :: [Ct] -> Subst +ctsSubst cts = niFixSubst inScope $ listToUFM prs + where + toSubstPair ct = + case classifyPredType (ctEvPred (ctEvidence ct)) of + EqPred NomEq t1 t2 + | Just tv <- getTyVar_maybe t1 + -- NB: deliberately don't re-orient constraints: we are only + -- guaranteed a terminating substitution by keeping the orientation. + -> Just (tv, t2) + _ -> Nothing + prs = mapMaybe toSubstPair cts + inScope = + mkInScopeSet $ + mkVarSet (map fst prs) + `unionVarSet` + tyCoVarsOfTypes (map snd prs) + +-- NB: copied from GHC, as GHC doesn't export this function. +niFixSubst :: InScopeSet -> TvSubstEnv -> Subst +niFixSubst in_scope tenv + | not_fixpoint = niFixSubst in_scope (mapVarEnv (substTy subst) tenv) + | otherwise = tenv_subst + where + tenv_subst = mkTvSubst in_scope tenv + + range_tvs :: [TyVar] + range_tvs = +#if MIN_VERSION_ghc(9,15,0) + nonDetVarSetElems $ tyCoVarsOfTypes +#else + fvVarList $ tyCoFVsOfTypes +#endif + $ nonDetEltsUFM tenv + + not_fixpoint = any in_domain range_tvs + in_domain tv = tv `elemVarEnv` tenv + + free_tvs = scopedSort (filterOut in_domain range_tvs) + + subst = foldl' add_free_tv tenv_subst free_tvs + + add_free_tv subst0 tv + | isTyVar tv = extendTvSubst subst0 tv (mkTyVarTy tv') + | otherwise = subst0 + where + tv' = updateTyVarKind (substTy subst0) tv + +-------------------------------------------------------------------------------- + +getTopEnv :: MonadTcPlugin m => m HscEnv +getTopEnv = liftTcPluginM GHC.getTopEnv + +-- | Obtain the current global and local type-checking environments. +getEnvs :: MonadTcPlugin m => m ( TcGblEnv, TcLclEnv ) +getEnvs = liftTcPluginM GHC.getEnvs + +-- | Obtain all currently-reachable typeclass instances. +getInstEnvs :: MonadTcPlugin m => m InstEnvs +getInstEnvs = liftTcPluginM GHC.getInstEnvs + +-- | Obtain all currently-reachable data/type family instances. +-- +-- First result: external instances. +-- Second result: instances in the current home package. +getFamInstEnvs :: MonadTcPlugin m => m ( FamInstEnv, FamInstEnv ) +getFamInstEnvs = liftTcPluginM GHC.getFamInstEnvs + +-- | Ask GHC what a type family application reduces to. +-- +-- __Warning__: can cause a loop when used within 'tcPluginRewrite'. +matchFam :: MonadTcPlugin m + => TyCon -> [ TcType ] + -> m ( Maybe Reduction ) +matchFam tycon args = +#ifndef HAS_REWRITING + fmap ( \ (co,ty) -> mkReduction (mkSymCo co) ty ) <$> + -- GHC 9.0 and 9.2 use a different orientation + -- when rewriting type family applications. +#endif + ( liftTcPluginM $ GHC.matchFam tycon args ) + +-------------------------------------------------------------------------------- + +-- | Create a new unique. Useful for generating new variables in the plugin. +newUnique :: MonadTcPlugin m => m Unique +newUnique = liftTcPluginM GHC.newUnique + +-- | Create a new meta-variable (unification variable) of the given kind. +newFlexiTyVar :: MonadTcPlugin m => Kind -> m TcTyVar +newFlexiTyVar = liftTcPluginM . GHC.newFlexiTyVar + +-- | Query whether a type variable is touchable: +-- - is it a unification variable (and not a skolem variable)? +-- - is it actually unifiable given the current 'TcLevel'? +isTouchableTcPluginM :: MonadTcPlugin m => TcTyVar -> m Bool +isTouchableTcPluginM = liftTcPluginM . GHC.isTouchableTcPluginM + +-------------------------------------------------------------------------------- + +-- | Zonk the given type, which takes the metavariables in the type and +-- substitutes their actual value. +zonkTcType :: MonadTcPluginWork m => TcType -> m TcType +zonkTcType = liftTcPluginM . GHC.zonkTcType + +-- | Zonk a given constraint. +zonkCt :: MonadTcPluginWork m => Ct -> m Ct +zonkCt = liftTcPluginM . GHC.zonkCt + +-------------------------------------------------------------------------------- + +-- | 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 ev = case ctEvFlavour ev of + Wanted {} -> True + _ -> False + +-------------------------------------------------------------------------------- + +-- | Create a new Wanted constraint. +-- +-- Requires a location (so that error messages can say where the constraint came from, +-- what things were in scope at that point, etc), as well as the actual constraint (encoded as a type). +newWanted :: MonadTcPluginWork m => CtLoc -> PredType -> m CtEvidence +newWanted loc pty = +#if !HAS_REWRITING + -- On GHC 9.2 and below, 'newWanted' doesn't use the location information + -- that is passed to it, retrieving it from the 'TcM' environment instead. + -- https://gitlab.haskell.org/ghc/ghc/-/issues/20895 + setCtLocM loc $ +#endif + liftTcPluginM $ GHC.newWanted loc pty + +-- | Create a new Given constraint. +-- +-- Unlike 'newWanted', we need to supply evidence for this constraint. +newGiven :: CtLoc -> PredType -> EvTerm -> TcPluginM Solve CtEvidence +newGiven loc pty evtm = do + 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'. +-- +-- This can be useful to obtain the location of the +-- constraint currently being rewritten, +-- so that newly emitted constraints can be given +-- the same location information. +rewriteEnvCtLoc :: RewriteEnv -> CtLoc +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 +setCtLocM loc = unsafeLiftThroughTcM ( GHC.setCtLocM loc ) + +-- | Use the 'RewriteEnv' to set the 'CtLoc' for a computation. +setCtLocRewriteM :: TcPluginM Rewrite a -> TcPluginM Rewrite a +setCtLocRewriteM ma = do + rewriteCtLoc <- rewriteEnvCtLoc <$> askRewriteEnv + setCtLocM rewriteCtLoc ma + +-------------------------------------------------------------------------------- + +-- | Create a fresh evidence variable. +newEvVar :: PredType -> TcPluginM Solve EvVar +newEvVar = liftTcPluginM . GHC.newEvVar + +-- | Create a fresh coercion hole. +newCoercionHole :: PredType -> TcPluginM Solve CoercionHole +newCoercionHole = liftTcPluginM . GHC.newCoercionHole + +-- | Bind an evidence variable. +setEvBind :: EvBind -> TcPluginM Solve () +setEvBind ev_bind = do +#if HAS_REWRITING + tc_evbinds <- askEvBinds + liftTcPluginM $ GHC.setEvBind tc_evbinds ev_bind +#else + liftTcPluginM $ GHC.setEvBind ev_bind +#endif + +-------------------------------------------------------------------------------- + +-- | Conjure up a coercion witnessing an equality between two types +-- at the given 'Role' ('Nominal' or 'Representational'). +-- +-- This amounts to telling GHC "believe me, these things are equal". +-- +-- The plugin is responsible for not emitting any unsound coercions, +-- such as a coercion between 'Int' and 'Float'. +mkPluginUnivCo + :: String -- ^ Name of equality (for the plugin's internal use, or for debugging) + -> Role + -> [Coercion] -- ^ Evidence that this proof term depends on (use 'ctEvCoercion') + -> TcType -- ^ LHS + -> TcType -- ^ RHS + -> Coercion +mkPluginUnivCo str role _deps lhs rhs = + mkUnivCo + ( PluginProv str ) +#if MIN_VERSION_ghc(9,12,0) + _deps +#endif + role + lhs + rhs + +-- | Conjure up an evidence term for an equality between two types +-- at the given 'Role' ('Nominal' or 'Representational'). +-- +-- This can be used to supply a proof of a wanted equality in 'TcPluginOk'. +-- +-- The plugin is responsible for not emitting any unsound equalities, +-- such as an equality between 'Int' and 'Float'. +mkPluginUnivEvTerm + :: String -- ^ Name of equality (for the plugin's internal use, or for debugging) + -> Role + -> [Coercion] -- ^ Evidence that this proof term depends on (use 'ctEvCoercion') + -> TcType -- ^ LHS + -> TcType -- ^ RHS + -> EvTerm +mkPluginUnivEvTerm str role deps lhs rhs = + evCoercion $ mkPluginUnivCo str role deps lhs rhs + +-- | Provide a rewriting of a saturated type family application +-- at the given 'Role' ('Nominal' or 'Representational'). +-- +-- The result can be passed to 'TcPluginRewriteTo' to specify the outcome +-- of rewriting a type family application. +mkTyFamAppReduction + :: String -- ^ Name of reduction (for debugging) + -> Role -- ^ Role of reduction ('Nominal' or 'Representational') + -> [Coercion] -- ^ Evidence that this reduction depends on (use 'ctEvCoercion') + -> TyCon -- ^ Type family 'TyCon' + -> [TcType] -- ^ Type family arguments + -> 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 + +-------------------------------------------------------------------------------- + +#if !MIN_VERSION_ghc(9,0,0) + +type UniqFM ty a = GHC.UniqFM a + +mkUncheckedIntExpr :: Integer -> CoreExpr +mkUncheckedIntExpr i = mkCoreConApps intDataCon [Lit lit] + where + lit = LitNumber LitNumInt i intPrimTy + +#if MIN_VERSION_ghc(8,10,0) + +mkVisFunTyMany :: Type -> Type -> Type +mkVisFunTyMany = mkVisFunTy + +mkVisFunTysMany :: [Type] -> Type -> Type +mkVisFunTysMany = mkVisFunTys + +#else + +type Pred = PredTree + +mkInvisFunTy, mkVisFunTyMany :: Type -> Type -> Type +mkInvisFunTy = mkFunTy +mkVisFunTyMany = mkFunTy + +mkInvisFunTys, mkVisFunTysMany :: [Type] -> Type -> Type +mkInvisFunTys = mkFunTys +mkVisFunTysMany = mkFunTys + +mkPiTy :: TyCoBinder -> Type -> Type +mkPiTy bndr ty = mkPiTys [bndr] ty + +#endif +#endif + +-------------------------------------------------------------------------------- + +#if !MIN_VERSION_ghc(9,13,0) +-- | Makes an unlifted equality predicate at the given role +-- (either 'Nominal' or 'Representational'). +mkEqPredRole :: Role -> Type -> Type -> PredType +#if MIN_VERSION_ghc(8,10,0) +mkEqPredRole = mkPrimEqPredRole +#else +mkEqPredRole Nominal = mkPrimEqPred +mkEqPredRole Representational = mkReprPrimEqPred +mkEqPredRole Phantom = panic "mkPrimEqPredRole phantom" +#endif +#endif + +-------------------------------------------------------------------------------- + +#if !MIN_VERSION_ghc(9,1,0) +isNewDataCon :: DataCon -> Bool +isNewDataCon dc = isNewTyCon (dataConTyCon dc) +#endif + +#if !MIN_VERSION_ghc(8,11,0) +instance Outputable a => Outputable (NonEmpty a) where + ppr (x :| xs) = ppr (x : xs) +#endif + +-------------------------------------------------------------------------------- + +#if MIN_VERSION_ghc(9,8,0) +setInertSet :: InertSet -> TcS () +setInertSet inerts = updInertSet ( const inerts ) + -- workaround for setInertSet not being exported + +#elif !MIN_VERSION_ghc(9,8,0) +getInertSet :: TcS InertSet +getInertSet = getTcSInerts + +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 + +--------------------------------------------------------------------------------
src/GHC/TcPlugin/API/Internal.hs view
@@ -1,575 +1,670 @@-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--{-|-Module: GHC.TcPlugin.API.Internal--This module provides operations to directly lift and unlift computations in-GHC's 'GHC.Tc.TcM' monad to the various type-checking plugin monads, in the form-of the functions-- > unsafeLiftTcM :: TcM a -> m a-- > unsafeWithRunInTcM :: ( ( forall a. m a -> TcM a ) -> TcM b ) -> m b--Here 'GHC.Tc.TcM' is GHC's internal type-checker monad.--It also exposes extra environment available in the solving/rewriting stages:-- > askRewriteEnv :: TcPluginM Rewrite RewriteEnv-- > askEvBinds :: TcPluginM Solve EvBindsVar--It is hoped that none of these internal operations are necessary, and that users-can fulfill their needs without importing this internal module.--Please file a bug on the issue tracker if you have encountered a situation-which requires the import of this module.---}--module GHC.TcPlugin.API.Internal- ( -- * Internal functions and types- MonadTcPlugin(..), MonadTcPluginWork- , unsafeLiftThroughTcM- -- * Re-exported functions and types- , TcPlugin(..), TcPluginStage(..)- , TcPluginSolver- , TcPluginM(..)- , TcPluginErrorMessage(..)- , TcPluginRewriter- , MonadThings(..)- , askRewriteEnv- , askDeriveds- , askEvBinds- , mkTcPlugin- , mkTcPluginErrorTy- )- where---- base-import Data.Coerce- ( Coercible )-import Data.Kind- ( Type )-import GHC.TypeLits- ( TypeError, ErrorMessage(..) )---- transformers-import Control.Monad.Trans.Reader- ( ReaderT(..) )---- ghc-import qualified GHC.Builtin.Names- as GHC.TypeLits- ( errorMessageTypeErrorFamName- , typeErrorTextDataConName- , typeErrorAppendDataConName- , typeErrorVAppendDataConName- , typeErrorShowTypeDataConName- )-import qualified GHC.Builtin.Types- as GHC- ( constraintKind )-import qualified GHC.Core.DataCon- as GHC- ( promoteDataCon )-import qualified GHC.Core.TyCon- as GHC- ( TyCon )-import qualified GHC.Core.TyCo.Rep- as GHC- ( PredType, Type(..), TyLit(..) )-import qualified GHC.Core.Type- as GHC- ( mkTyConApp, tcTypeKind )-import qualified GHC.Data.FastString- as GHC- ( fsLit )-import qualified GHC.Tc.Plugin- as GHC- ( tcLookupDataCon, tcLookupTyCon )-import qualified GHC.Tc.Types- as GHC- ( TcM, TcPlugin(..), TcPluginM- , TcPluginSolver-#ifdef HAS_REWRITING- , TcPluginRewriter-#else- , getEvBindsTcPluginM-#endif- , runTcPluginM, unsafeTcPluginTcM- )-#ifdef HAS_REWRITING-import GHC.Tc.Types- ( TcPluginSolveResult- , TcPluginRewriteResult- , RewriteEnv- )-#endif-import qualified GHC.Tc.Types.Constraint- as GHC- ( Ct )-import qualified GHC.Tc.Types.Evidence- as GHC- ( EvBindsVar )-import qualified GHC.Types.Unique.FM- as GHC- ( UniqFM )-#if MIN_VERSION_ghc(9,1,0)-import GHC.Types.TyThing- ( MonadThings(..) )-#else-import GHC.Driver.Types- ( MonadThings(..) )-#endif---- ghc-tcplugin-api-#ifndef HAS_REWRITING-import GHC.TcPlugin.API.Internal.Shim- ( TcPluginSolveResult, TcPluginRewriteResult(..)- , RewriteEnv- , shimRewriter- )-#endif------------------------------------------------------------------------------------- Public types and functions.---- | Stage of a type-checking plugin, used as a data kind.-data TcPluginStage- = Init- | Solve- | Rewrite- | Stop---- | The @solve@ function of a type-checking plugin takes in Given and Wanted--- constraints, and should return a 'GHC.Tc.Types.TcPluginSolveResult'--- indicating which Wanted constraints it could solve, or whether any are--- insoluble.-type TcPluginSolver- = [GHC.Ct] -- ^ Givens- -> [GHC.Ct] -- ^ Wanteds- -> TcPluginM Solve TcPluginSolveResult---- | For rewriting type family applications, a type-checking plugin provides--- a function of this type for each type family 'GHC.Core.TyCon.TyCon'.------ The function is provided with the current set of Given constraints, together--- with the arguments to the type family.--- The type family application will always be fully saturated.-type TcPluginRewriter- = [GHC.Ct] -- ^ Givens- -> [GHC.Type] -- ^ Type family arguments (saturated)- -> TcPluginM Rewrite TcPluginRewriteResult---- | A record containing all the stages necessary for the--- operation of a type-checking plugin, as defined in this API.------ __Note__: this is not the same record as GHC's built-in--- 'GHC.Tc.Types.TcPlugin' record. Use 'mkTcPlugin' for the conversion.------ To create a type-checking plugin, define something of this type--- and then call 'mkTcPlugin' on the result.--- This will return something that can be passed to 'GHC.Plugins.Plugin':------ > plugin :: GHC.Plugins.Plugin--- > plugin =--- > GHC.Plugins.defaultPlugin--- > { GHC.Plugins.tcPlugin =--- > \ args -> Just $--- > GHC.TcPlugin.API.mkTcPlugin ( myTcPlugin args )--- > }--- >--- > myTcPlugin :: [String] -> GHC.TcPlugin.API.TcPlugin--- > myTcPlugin args = ...-data TcPlugin = forall s. TcPlugin- { tcPluginInit :: TcPluginM Init s- -- ^ Initialise plugin, when entering type-checker.-- , tcPluginSolve :: s -> TcPluginSolver- -- ^ Solve some constraints.- --- -- This function will be invoked at two points in the constraint solving- -- process: once to manipulate given constraints, and once to solve- -- wanted constraints. In the first case (and only in the first case),- -- no wanted constraints will be passed to the plugin.- --- -- The plugin can either return a contradiction,- -- or specify that it has solved some constraints (with evidence),- -- and possibly emit additional wanted constraints.- --- -- Use @ \\ _ _ _ -> pure $ TcPluginOK [] [] @ if your plugin- -- does not provide this functionality.-- , tcPluginRewrite- :: s -> GHC.UniqFM-#if MIN_VERSION_ghc(9,0,0)- GHC.TyCon-#endif- TcPluginRewriter- -- ^ Rewrite saturated type family applications.- --- -- The plugin is expected to supply a mapping from type family names to- -- rewriting functions. For each type family 'GHC.Core.TyCon.TyCon',- -- the plugin should provide a function which takes in the given constraints- -- and arguments of a saturated type family application, and return- -- a possible rewriting.- -- See 'TcPluginRewriter' for the expected shape of such a function.- --- -- Use @ const emptyUFM @ if your plugin does not provide this functionality.-- , tcPluginStop :: s -> TcPluginM Stop ()- -- ^ Clean up after the plugin, when exiting the type-checker.- }---- | The monad used for a type-checker plugin, parametrised by--- the 'TcPluginStage' of the plugin.-data family TcPluginM (s :: TcPluginStage) :: Type -> Type-newtype instance TcPluginM Init a =- TcPluginInitM { tcPluginInitM :: GHC.TcPluginM a }- deriving newtype ( Functor, Applicative, Monad )-#ifdef HAS_DERIVEDS-newtype instance TcPluginM Solve a =- TcPluginSolveM { tcPluginSolveM :: BuiltinDefs -> GHC.EvBindsVar -> [GHC.Ct] -> GHC.TcPluginM a }- deriving ( Functor, Applicative, Monad )- via ( ReaderT BuiltinDefs ( ReaderT GHC.EvBindsVar ( ReaderT [GHC.Ct] GHC.TcPluginM ) ) )-#else-newtype instance TcPluginM Solve a =- TcPluginSolveM { tcPluginSolveM :: BuiltinDefs -> GHC.EvBindsVar -> GHC.TcPluginM a }- deriving ( Functor, Applicative, Monad )- via ( ReaderT BuiltinDefs ( ReaderT GHC.EvBindsVar GHC.TcPluginM ) )-#endif-newtype instance TcPluginM Rewrite a =- TcPluginRewriteM { tcPluginRewriteM :: BuiltinDefs -> RewriteEnv -> GHC.TcPluginM a }- deriving ( Functor, Applicative, Monad )- via ( ReaderT BuiltinDefs ( ReaderT RewriteEnv GHC.TcPluginM ) )-newtype instance TcPluginM Stop a =- TcPluginStopM { tcPluginStopM :: GHC.TcPluginM a }- deriving newtype ( Functor, Applicative, Monad )---- | Ask for the evidence currently gathered by the type-checker.------ Only available in the solver part of the type-checking plugin.-askEvBinds :: TcPluginM Solve GHC.EvBindsVar-askEvBinds = TcPluginSolveM- \ _defs- evBinds-#ifdef HAS_DERIVEDS- _deriveds-#endif- -> pure evBinds---- | Ask for the Derived constraints that the solver was provided with.------ Always returns the empty list on GHC 9.4 or above.-askDeriveds :: TcPluginM Solve [GHC.Ct]-askDeriveds =-#ifdef HAS_DERIVEDS- TcPluginSolveM \ _defs _evBinds deriveds -> pure deriveds-#else- pure []-#endif---- | Ask for the current rewriting environment.------ Only available in the rewriter part of the type-checking plugin.-askRewriteEnv :: TcPluginM Rewrite RewriteEnv-askRewriteEnv = TcPluginRewriteM ( \ _ rewriteEnv -> pure rewriteEnv )---- | A 'MonadTcPlugin' is essentially a reader monad over GHC's 'GHC.Tc.TcM' monad.------ This means we have both a @lift@ and an @unlift@ operation,--- similar to @MonadUnliftIO@ or @MonadBaseControl@.------ See for instance 'unsafeLiftThroughTcM', which is an example of function that--- one would not be able to write using only a @lift@ operation.------ 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.-class ( Monad m, ( forall x y. Coercible x y => Coercible (m x) (m y) ) ) => MonadTcPlugin (m :: Type -> Type) where-- {-# MINIMAL liftTcPluginM, unsafeWithRunInTcM #-}-- -- N.B.: these methods are not re-exported from the main module.-- -- | Lift a computation from GHC's 'GHC.TcPluginM' monad.- liftTcPluginM :: GHC.TcPluginM a -> m a-- -- | Lift a computation from the 'GHC.Tc.TcM' monad.- unsafeLiftTcM :: GHC.TcM a -> m a- unsafeLiftTcM = liftTcPluginM . GHC.unsafeTcPluginTcM-- -- | Unlift a computation from the 'GHC.Tc.TcM' monad.- --- -- If this type signature seems confusing, I recommend reading Alexis King's- -- excellent blog post on @MonadBaseControl@:- --- -- <https://lexi-lambda.github.io/blog/2019/09/07/demystifying-monadbasecontrol/ Demystifying MonadBaseControl>- unsafeWithRunInTcM :: ( ( forall a. m a -> GHC.TcM a ) -> GHC.TcM b ) -> m b--instance MonadTcPlugin ( TcPluginM Init ) where- liftTcPluginM = TcPluginInitM- unsafeWithRunInTcM runInTcM- = unsafeLiftTcM $ runInTcM-#ifdef HAS_REWRITING- ( GHC.runTcPluginM . tcPluginInitM )-#else- ( ( `GHC.runTcPluginM` ( error "tcPluginInit: cannot access EvBindsVar" ) ) . tcPluginInitM )-#endif-instance MonadTcPlugin ( TcPluginM Solve ) where- liftTcPluginM = TcPluginSolveM-#ifdef HAS_DERIVEDS- . ( \ ma _defs _evBinds _deriveds -> ma )-#else- . ( \ ma _defs _evBinds -> ma )-#endif- unsafeWithRunInTcM runInTcM- = TcPluginSolveM- \ builtinDefs- evBinds-#ifdef HAS_DERIVEDS- deriveds-#endif- ->- GHC.unsafeTcPluginTcM $ runInTcM-#ifdef HAS_REWRITING- -- (no deriveds)- ( GHC.runTcPluginM- . ( \ f -> f builtinDefs evBinds )- . tcPluginSolveM )-#else- ( ( `GHC.runTcPluginM` evBinds )- . ( \ f -> f builtinDefs evBinds deriveds )- . tcPluginSolveM- )-#endif-instance MonadTcPlugin ( TcPluginM Rewrite ) where- liftTcPluginM = TcPluginRewriteM . ( \ ma _ _ -> ma )- unsafeWithRunInTcM runInTcM- = TcPluginRewriteM \ builtinDefs rewriteEnv ->- GHC.unsafeTcPluginTcM $ runInTcM-#ifdef HAS_REWRITING- ( GHC.runTcPluginM-#else- ( ( `GHC.runTcPluginM` ( error "tcPluginRewrite: cannot access EvBindsVar" ) )-#endif- . ( \ f -> f builtinDefs rewriteEnv )- . tcPluginRewriteM )-instance MonadTcPlugin ( TcPluginM Stop ) where- liftTcPluginM = TcPluginStopM- unsafeWithRunInTcM runInTcM- = unsafeLiftTcM $ runInTcM-#ifdef HAS_REWRITING- ( GHC.runTcPluginM . tcPluginStopM )-#else- ( ( `GHC.runTcPluginM` ( error "tcPluginStop: cannot access EvBindsVar" ) ) . tcPluginStopM )-#endif---- | Take a function whose argument and result types are both within the 'GHC.Tc.TcM' monad,--- and return a function that works within a type-checking plugin monad.------ Please report a bug if you find yourself needing to use this function.-unsafeLiftThroughTcM :: MonadTcPlugin m => ( GHC.TcM a -> GHC.TcM b ) -> m a -> m b-unsafeLiftThroughTcM f ma = unsafeWithRunInTcM \ runInTcM -> f ( runInTcM ma )---- | Use this function to create a type-checker plugin to pass to GHC.-mkTcPlugin- :: TcPlugin -- ^ type-checking plugin written with this library- -> GHC.TcPlugin -- ^ type-checking plugin for GHC-mkTcPlugin ( TcPlugin- { tcPluginInit = tcPluginInit :: TcPluginM Init userDefs- , tcPluginSolve- , tcPluginRewrite- , tcPluginStop- }- ) =- GHC.TcPlugin- { GHC.tcPluginInit = adaptUserInit tcPluginInit-#ifdef HAS_REWRITING- , GHC.tcPluginSolve = adaptUserSolve tcPluginSolve- , GHC.tcPluginRewrite = adaptUserRewrite tcPluginRewrite-#else- , GHC.tcPluginSolve = adaptUserSolveAndRewrite- tcPluginSolve tcPluginRewrite-#endif- , GHC.tcPluginStop = adaptUserStop tcPluginStop- }- where- adaptUserInit :: TcPluginM Init userDefs -> GHC.TcPluginM ( TcPluginDefs userDefs )- adaptUserInit userInit = do- tcPluginBuiltinDefs <- initBuiltinDefs- tcPluginUserDefs <- tcPluginInitM userInit- pure ( TcPluginDefs { tcPluginBuiltinDefs, tcPluginUserDefs })--#ifdef HAS_REWRITING- -- (no deriveds)- adaptUserSolve :: ( userDefs -> TcPluginSolver )- -> TcPluginDefs userDefs- -> GHC.TcPluginSolver- adaptUserSolve userSolve ( TcPluginDefs { tcPluginUserDefs, tcPluginBuiltinDefs } )- = \ evBindsVar givens wanteds -> do- tcPluginSolveM ( userSolve tcPluginUserDefs givens wanteds )- tcPluginBuiltinDefs evBindsVar- adaptUserRewrite :: ( userDefs -> GHC.UniqFM GHC.TyCon TcPluginRewriter )- -> TcPluginDefs userDefs -> GHC.UniqFM GHC.TyCon GHC.TcPluginRewriter- adaptUserRewrite userRewrite ( TcPluginDefs { tcPluginUserDefs, tcPluginBuiltinDefs })- = fmap- ( \ userRewriter rewriteEnv givens tys ->- tcPluginRewriteM ( userRewriter givens tys ) tcPluginBuiltinDefs rewriteEnv- )- ( userRewrite tcPluginUserDefs )-#else- adaptUserSolveAndRewrite- :: ( userDefs -> TcPluginSolver )- -> ( userDefs -> GHC.UniqFM-#if MIN_VERSION_ghc(9,0,0)- GHC.TyCon-#endif- TcPluginRewriter- )- -> TcPluginDefs userDefs- -> GHC.TcPluginSolver- adaptUserSolveAndRewrite userSolve userRewrite ( TcPluginDefs { tcPluginUserDefs, tcPluginBuiltinDefs } )- = \ givens deriveds wanteds -> do- evBindsVar <- GHC.getEvBindsTcPluginM- shimRewriter- givens deriveds wanteds- ( fmap- ( \ userRewriter rewriteEnv gs tys ->- tcPluginRewriteM ( userRewriter gs tys )- tcPluginBuiltinDefs rewriteEnv- )- ( userRewrite tcPluginUserDefs )- )- ( \ gs ds ws ->- tcPluginSolveM ( userSolve tcPluginUserDefs gs ws )- tcPluginBuiltinDefs evBindsVar ds- )-#endif-- adaptUserStop :: ( userDefs -> TcPluginM Stop () ) -> TcPluginDefs userDefs -> GHC.TcPluginM ()- adaptUserStop userStop ( TcPluginDefs { tcPluginUserDefs } ) =- tcPluginStopM $ userStop tcPluginUserDefs---- | Monads for type-checking plugins which are able to emit new constraints--- and throw errors.------ These operations are supported by the monads that 'tcPluginSolve'--- and 'tcPluginRewrite' use; it is not possible to emit work or--- throw type errors in 'tcPluginInit' or 'tcPluginStop'.------ See 'mkTcPluginErrorTy' and 'GHC.TcPlugin.API.emitWork' for functions--- which require this typeclass.-class MonadTcPlugin m => MonadTcPluginWork m where- {-# MINIMAL #-} -- to avoid the methods appearing in the haddocks- askBuiltins :: m BuiltinDefs- askBuiltins = error "askBuiltins: no default implementation"-instance MonadTcPluginWork ( TcPluginM Solve ) where- askBuiltins = TcPluginSolveM- \ builtinDefs- _evBinds-#ifdef HAS_DERIVEDS- _deriveds-#endif- -> pure builtinDefs-instance MonadTcPluginWork ( TcPluginM Rewrite ) where- askBuiltins = TcPluginRewriteM \ builtinDefs _evBinds -> pure builtinDefs--instance TypeError ( 'Text "Cannot emit new work in 'tcPluginInit'." )- => MonadTcPluginWork ( TcPluginM Init ) where- askBuiltins = error "Cannot emit new work in 'tcPluginInit'."-instance TypeError ( 'Text "Cannot emit new work in 'tcPluginStop'." )- => MonadTcPluginWork ( TcPluginM Stop ) where- askBuiltins = error "Cannot emit new work in 'tcPluginStop'."---- | Use this type like 'GHC.TypeLits.ErrorMessage' to write an error message.--- This error message can then be thrown at the type-level by the plugin,--- by emitting a wanted constraint whose predicate is obtained from 'mkTcPluginErrorTy'.------ A 'GHC.Tc.Types.Constraint.CtLoc' will still need to be provided in order to inform GHC of the--- origin of the error (e.g.: which part of the source code should be--- highlighted?). See 'GHC.TcPlugin.API.setCtLocM'.-data TcPluginErrorMessage- = Txt !String- -- ^ Show the text as is.- | PrintType !GHC.Type- -- ^ Pretty print the given type.- | (:|:) !TcPluginErrorMessage !TcPluginErrorMessage- -- ^ Put two messages side by side.- | (:-:) !TcPluginErrorMessage !TcPluginErrorMessage- -- ^ Stack two messages vertically.-infixl 5 :|:-infixl 6 :-:---- | Create an error type with the desired error message.------ The result can be paired with a 'GHC.Tc.Types.Constraint.CtLoc' in order to throw a type error,--- for instance by using 'GHC.TcPlugin.API.newWanted'.-mkTcPluginErrorTy :: MonadTcPluginWork m => TcPluginErrorMessage -> m GHC.PredType-mkTcPluginErrorTy msg = do- builtinDefs@( BuiltinDefs { typeErrorTyCon } ) <- askBuiltins- let- errorMsgTy :: GHC.PredType- errorMsgTy = interpretErrorMessage builtinDefs msg- pure $ GHC.mkTyConApp typeErrorTyCon [ GHC.constraintKind, errorMsgTy ]--instance ( Monad (TcPluginM s), MonadTcPlugin (TcPluginM s) )- => MonadThings (TcPluginM s) where- lookupThing = unsafeLiftTcM . lookupThing------------------------------------------------------------------------------------- Private types and functions.--- Not exposed at all, even from the internal module.--data BuiltinDefs =- BuiltinDefs- { typeErrorTyCon :: !GHC.TyCon- , textTyCon :: !GHC.TyCon- , showTypeTyCon :: !GHC.TyCon- , concatTyCon :: !GHC.TyCon- , vcatTyCon :: !GHC.TyCon- }--data TcPluginDefs s- = TcPluginDefs- { tcPluginBuiltinDefs :: !BuiltinDefs- , tcPluginUserDefs :: !s- }--initBuiltinDefs :: GHC.TcPluginM BuiltinDefs-initBuiltinDefs = do- typeErrorTyCon <- GHC.tcLookupTyCon GHC.TypeLits.errorMessageTypeErrorFamName- textTyCon <- GHC.promoteDataCon <$> GHC.tcLookupDataCon GHC.TypeLits.typeErrorTextDataConName- showTypeTyCon <- GHC.promoteDataCon <$> GHC.tcLookupDataCon GHC.TypeLits.typeErrorShowTypeDataConName- concatTyCon <- GHC.promoteDataCon <$> GHC.tcLookupDataCon GHC.TypeLits.typeErrorAppendDataConName- vcatTyCon <- GHC.promoteDataCon <$> GHC.tcLookupDataCon GHC.TypeLits.typeErrorVAppendDataConName- pure ( BuiltinDefs { .. } )--interpretErrorMessage :: BuiltinDefs -> TcPluginErrorMessage -> GHC.PredType-interpretErrorMessage ( BuiltinDefs { .. } ) = go- where- go :: TcPluginErrorMessage -> GHC.PredType- go ( Txt str ) =- GHC.mkTyConApp textTyCon [ GHC.LitTy . GHC.StrTyLit . GHC.fsLit $ str ]- go ( PrintType ty ) =- GHC.mkTyConApp showTypeTyCon [ GHC.tcTypeKind ty, ty ]- -- The kind gets ignored by GHC when printing the error message (see GHC.Core.Type.pprUserTypeErrorTy).- -- However, including the wrong kind can lead to ASSERT failures, so we compute the kind and pass it.- go ( msg1 :|: msg2 ) =- GHC.mkTyConApp concatTyCon [ go msg1, go msg2 ]- go ( msg1 :-: msg2 ) =- GHC.mkTyConApp vcatTyCon [ go msg1, go msg2 ]+{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + +{-| +Module: GHC.TcPlugin.API.Internal + +This module provides operations to directly lift and unlift computations in +GHC's 'GHC.Tc.TcM' monad to the various type-checking plugin monads, in the form +of the functions + + > unsafeLiftTcM :: TcM a -> m a + + > unsafeWithRunInTcM :: ( ( forall a. m a -> TcM a ) -> TcM b ) -> m b + +Here 'GHC.Tc.TcM' is GHC's internal type-checker monad. + +It also exposes extra environment available in the solving/rewriting stages: + + > askRewriteEnv :: TcPluginM Rewrite RewriteEnv + + > askEvBinds :: TcPluginM Solve EvBindsVar + +It is hoped that none of these internal operations are necessary, and that users +can fulfill their needs without importing this internal module. + +Please file a bug on the issue tracker if you have encountered a situation +which requires the import of this module. + +-} + +module GHC.TcPlugin.API.Internal + ( -- * Internal functions and types + MonadTcPlugin(..), MonadTcPluginWork + , unsafeLiftThroughTcM + -- * Re-exported functions and types + , TcPlugin(..), TcPluginStage(..) + , TcPluginSolver + , TcPluginM(..) + , TcPluginErrorMessage(..) + , TcPluginRewriter + , MonadThings(..) + , askRewriteEnv + , askDeriveds + , askEvBinds + , mkTcPlugin + , mkTcPluginErrorTy + ) + where + +-- base +import Data.Coerce + ( Coercible ) +import Data.Kind + ( Type ) +import GHC.TypeLits + ( TypeError, ErrorMessage(..) ) + +-- transformers +import Control.Monad.IO.Class + ( MonadIO ( liftIO ) ) +import Control.Monad.Trans.Reader + ( ReaderT(..) ) + +-- ghc +import qualified GHC.Builtin.Names + as GHC.TypeLits + ( errorMessageTypeErrorFamName + , typeErrorTextDataConName + , typeErrorAppendDataConName + , typeErrorVAppendDataConName + , typeErrorShowTypeDataConName + ) +import qualified GHC.Builtin.Types + as GHC + ( constraintKind ) +import qualified GHC.Core.DataCon + as GHC + ( promoteDataCon ) +import qualified GHC.Core.TyCon + as GHC + ( TyCon ) +import qualified GHC.Core.TyCo.Rep + as GHC + ( PredType, Type(..), TyLit(..) ) +import qualified GHC.Core.Type + as GHC + ( mkTyConApp, typeKind ) +import qualified GHC.Data.FastString + as GHC + ( fsLit ) +import qualified GHC.Tc.Plugin + as GHC + ( tcLookupDataCon, tcLookupTyCon ) +import qualified GHC.Tc.Types + as GHC + ( TcM, TcPlugin(..), TcPluginM + , TcPluginSolver +#if !MIN_VERSION_ghc(9,1,0) + , TcPluginResult(..) +#endif +#ifdef HAS_REWRITING + , TcPluginRewriter +#else + , getEvBindsTcPluginM +#endif + , runTcPluginM, unsafeTcPluginTcM + ) +#ifdef HAS_REWRITING +import GHC.Tc.Types + ( TcPluginSolveResult + , TcPluginRewriteResult + , RewriteEnv + ) +#endif +import qualified GHC.Tc.Types.Constraint + as GHC + ( Ct ) +import qualified GHC.Tc.Types.Evidence + as GHC + ( EvBindsVar ) +import qualified GHC.Types.Unique.FM + as GHC + ( UniqFM ) +#if MIN_VERSION_ghc(9,1,0) +import GHC.Types.TyThing + ( MonadThings(..) ) +#else +import GHC.Driver.Types + ( MonadThings(..) ) +import GHC.Tc.Types.Constraint + ( ctEvidence, ctEvId, isDerived ) +import GHC.Types.Var.Env + ( lookupVarEnv, mkVarEnv ) +import GHC.Utils.Outputable +import GHC.Tc.Plugin + ( tcPluginTrace ) +#endif + +-- ghc-tcplugin-api +#ifndef HAS_REWRITING +import GHC.TcPlugin.API.Internal.Shim + ( TcPluginSolveResult, TcPluginRewriteResult(..) + , RewriteEnv + , shimRewriter +#if !MIN_VERSION_ghc(9,1,0) + , unflattenCts +#endif + ) +#endif + +-------------------------------------------------------------------------------- +-- Public types and functions. + +-- | Stage of a type-checking plugin, used as a data kind. +data TcPluginStage + -- | Plugin initialisation + = Init + -- | Solve constraints + | Solve + -- | Rewrite type-families + | Rewrite + -- | End of typechecking + | PostTc + +-- | The @solve@ function of a type-checking plugin takes in Given and Wanted +-- constraints, and should return a 'GHC.Tc.Types.TcPluginSolveResult' +-- indicating which Wanted constraints it could solve, or whether any are +-- insoluble. +type TcPluginSolver + = [GHC.Ct] -- ^ Givens + -> [GHC.Ct] -- ^ Wanteds + -> TcPluginM Solve TcPluginSolveResult + +-- | For rewriting type family applications, a type-checking plugin provides +-- a function of this type for each type family 'GHC.Core.TyCon.TyCon'. +-- +-- The function is provided with the current set of Given constraints, together +-- with the arguments to the type family. +-- The type family application will always be fully saturated. +type TcPluginRewriter + = [GHC.Ct] -- ^ Givens + -> [GHC.Type] -- ^ Type family arguments (saturated) + -> TcPluginM Rewrite TcPluginRewriteResult + +-- | A record containing all the stages necessary for the +-- operation of a type-checking plugin, as defined in this API. +-- +-- __Note__: this is not the same record as GHC's built-in +-- 'GHC.Tc.Types.TcPlugin' record. Use 'mkTcPlugin' for the conversion. +-- +-- To create a type-checking plugin, define something of this type +-- and then call 'mkTcPlugin' on the result. +-- This will return something that can be passed to 'GHC.Plugins.Plugin': +-- +-- > plugin :: GHC.Plugins.Plugin +-- > plugin = +-- > GHC.Plugins.defaultPlugin +-- > { GHC.Plugins.tcPlugin = +-- > \ args -> Just $ +-- > GHC.TcPlugin.API.mkTcPlugin ( myTcPlugin args ) +-- > } +-- > +-- > myTcPlugin :: [String] -> GHC.TcPlugin.API.TcPlugin +-- > myTcPlugin args = ... +data TcPlugin = forall s. TcPlugin + { tcPluginInit :: TcPluginM Init s + -- ^ Initialize plugin (once per module), when starting the type-checker. + + , tcPluginSolve :: s -> TcPluginSolver + -- ^ Solve some constraints. + -- + -- This function will be invoked at two points in the constraint solving + -- process: once to simplify Given constraints, and once to solve + -- Wanted constraints. In the first case (and only in the first case), + -- no Wanted constraints will be passed to the plugin. + -- + -- The plugin can either return a contradiction, + -- or specify that it has solved some constraints (with evidence), + -- and possibly emit additional constraints. These returned constraints + -- must be Givens in the first case, and Wanteds in the second. + -- + -- Use @ \\ _ _ _ _ -> pure $ TcPluginOk [] [] @ if your plugin + + , tcPluginRewrite + :: s -> GHC.UniqFM +#if MIN_VERSION_ghc(9,0,0) + GHC.TyCon +#endif + TcPluginRewriter + -- ^ Rewrite saturated type family applications. + -- + -- The plugin is expected to supply a mapping from type family names to + -- rewriting functions. For each type family 'GHC.Core.TyCon.TyCon', + -- the plugin should provide a function which takes in the given constraints + -- and arguments of a saturated type family application, and return + -- a possible rewriting. + -- See 'TcPluginRewriter' for the expected shape of such a function. + -- + -- Use @ const emptyUFM @ if your plugin does not provide this functionality. + + , tcPluginPostTc :: s -> TcPluginM PostTc () + -- ^ Action to run at the end of typechecking a module, e.g. to intercept + -- the final 'TcGblEnv'/'TcLclEnv' at the end of typechecking, possibly + -- modifying mutable fields. + -- + -- Should not terminate the plugin, as the plugin may continue to be invoked + -- when desugaring the module (as the pattern-match checker may invoke the + -- constraint solver). + + , tcPluginShutdown :: s -> IO () + -- ^ Clean up after the plugin, when GHC is done processing the given + -- module (e.g. after desugaring). + } + +-- | The monad used for a type-checker plugin, parametrised by +-- the 'TcPluginStage' of the plugin. +data family TcPluginM (s :: TcPluginStage) :: Type -> Type +newtype instance TcPluginM Init a = + TcPluginInitM { tcPluginInitM :: GHC.TcPluginM a } + deriving newtype ( Functor, Applicative, Monad ) +#ifdef HAS_DERIVEDS +newtype instance TcPluginM Solve a = + TcPluginSolveM { tcPluginSolveM :: BuiltinDefs -> GHC.EvBindsVar -> [GHC.Ct] -> GHC.TcPluginM a } + deriving ( Functor, Applicative, Monad ) + via ( ReaderT BuiltinDefs ( ReaderT GHC.EvBindsVar ( ReaderT [GHC.Ct] GHC.TcPluginM ) ) ) +#else +newtype instance TcPluginM Solve a = + TcPluginSolveM { tcPluginSolveM :: BuiltinDefs -> GHC.EvBindsVar -> GHC.TcPluginM a } + deriving ( Functor, Applicative, Monad ) + via ( ReaderT BuiltinDefs ( ReaderT GHC.EvBindsVar GHC.TcPluginM ) ) +#endif +newtype instance TcPluginM Rewrite a = + TcPluginRewriteM { tcPluginRewriteM :: BuiltinDefs -> RewriteEnv -> GHC.TcPluginM a } + deriving ( Functor, Applicative, Monad ) + via ( ReaderT BuiltinDefs ( ReaderT RewriteEnv GHC.TcPluginM ) ) +newtype instance TcPluginM PostTc a = + TcPluginPostTcM { tcPluginPostTcM :: GHC.TcPluginM a } + deriving newtype ( Functor, Applicative, Monad ) + +-- | Ask for the evidence currently gathered by the type-checker. +-- +-- Only available in the solver part of the type-checking plugin. +askEvBinds :: TcPluginM Solve GHC.EvBindsVar +askEvBinds = TcPluginSolveM + \ _defs + evBinds +#ifdef HAS_DERIVEDS + _deriveds +#endif + -> pure evBinds + +-- | Ask for the Derived constraints that the solver was provided with. +-- +-- Always returns the empty list on GHC 9.4 or above. +askDeriveds :: TcPluginM Solve [GHC.Ct] +askDeriveds = +#ifdef HAS_DERIVEDS + TcPluginSolveM \ _defs _evBinds deriveds -> pure deriveds +#else + pure [] +#endif + +-- | Ask for the current rewriting environment. +-- +-- Only available in the rewriter part of the type-checking plugin. +askRewriteEnv :: TcPluginM Rewrite RewriteEnv +askRewriteEnv = TcPluginRewriteM ( \ _ rewriteEnv -> pure rewriteEnv ) + +-- | A 'MonadTcPlugin' is essentially a reader monad over GHC's 'GHC.Tc.TcM' monad. +-- +-- This means we have both a @lift@ and an @unlift@ operation, +-- similar to @MonadUnliftIO@ or @MonadBaseControl@. +-- +-- See for instance 'unsafeLiftThroughTcM', which is an example of function that +-- one would not be able to write using only a @lift@ operation. +-- +-- 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. +class ( Monad m, ( forall x y. Coercible x y => Coercible (m x) (m y) ) ) => MonadTcPlugin (m :: Type -> Type) where + + {-# MINIMAL liftTcPluginM, unsafeWithRunInTcM #-} + + -- N.B.: these methods are not re-exported from the main module. + + -- | Lift a computation from GHC's 'GHC.TcPluginM' monad. + liftTcPluginM :: GHC.TcPluginM a -> m a + + -- | Lift a computation from the 'GHC.Tc.TcM' monad. + unsafeLiftTcM :: GHC.TcM a -> m a + unsafeLiftTcM = liftTcPluginM . GHC.unsafeTcPluginTcM + + -- | Unlift a computation from the 'GHC.Tc.TcM' monad. + -- + -- If this type signature seems confusing, I recommend reading Alexis King's + -- excellent blog post on @MonadBaseControl@: + -- + -- <https://lexi-lambda.github.io/blog/2019/09/07/demystifying-monadbasecontrol/ Demystifying MonadBaseControl> + unsafeWithRunInTcM :: ( ( forall a. m a -> GHC.TcM a ) -> GHC.TcM b ) -> m b + +instance MonadTcPlugin ( TcPluginM Init ) where + liftTcPluginM = TcPluginInitM + unsafeWithRunInTcM runInTcM + = unsafeLiftTcM $ runInTcM +#ifdef HAS_REWRITING + ( GHC.runTcPluginM . tcPluginInitM ) +#else + ( ( `GHC.runTcPluginM` ( error "tcPluginInit: cannot access EvBindsVar" ) ) . tcPluginInitM ) +#endif +instance MonadTcPlugin ( TcPluginM Solve ) where + liftTcPluginM = TcPluginSolveM +#ifdef HAS_DERIVEDS + . ( \ ma _defs _evBinds _deriveds -> ma ) +#else + . ( \ ma _defs _evBinds -> ma ) +#endif + unsafeWithRunInTcM runInTcM + = TcPluginSolveM + \ builtinDefs + evBinds +#ifdef HAS_DERIVEDS + deriveds +#endif + -> + GHC.unsafeTcPluginTcM $ runInTcM +#ifdef HAS_REWRITING + -- (no deriveds) + ( GHC.runTcPluginM + . ( \ f -> f builtinDefs evBinds ) + . tcPluginSolveM ) +#else + ( ( `GHC.runTcPluginM` evBinds ) + . ( \ f -> f builtinDefs evBinds deriveds ) + . tcPluginSolveM + ) +#endif +instance MonadTcPlugin ( TcPluginM Rewrite ) where + liftTcPluginM = TcPluginRewriteM . ( \ ma _ _ -> ma ) + unsafeWithRunInTcM runInTcM + = TcPluginRewriteM \ builtinDefs rewriteEnv -> + GHC.unsafeTcPluginTcM $ runInTcM +#ifdef HAS_REWRITING + ( GHC.runTcPluginM +#else + ( ( `GHC.runTcPluginM` ( error "tcPluginRewrite: cannot access EvBindsVar" ) ) +#endif + . ( \ f -> f builtinDefs rewriteEnv ) + . tcPluginRewriteM ) +instance MonadTcPlugin ( TcPluginM PostTc ) where + liftTcPluginM = TcPluginPostTcM + unsafeWithRunInTcM runInTcM + = unsafeLiftTcM $ runInTcM +#ifdef HAS_REWRITING + ( GHC.runTcPluginM . tcPluginPostTcM ) +#else + ( ( `GHC.runTcPluginM` ( error "tcPluginPostTc: cannot access EvBindsVar" ) ) . tcPluginPostTcM ) +#endif + +-- | Take a function whose argument and result types are both within the 'GHC.Tc.TcM' monad, +-- and return a function that works within a type-checking plugin monad. +-- +-- Please report a bug if you find yourself needing to use this function. +unsafeLiftThroughTcM :: MonadTcPlugin m => ( GHC.TcM a -> GHC.TcM b ) -> m a -> m b +unsafeLiftThroughTcM f ma = unsafeWithRunInTcM \ runInTcM -> f ( runInTcM ma ) + +-- | Use this function to create a type-checker plugin to pass to GHC. +mkTcPlugin + :: TcPlugin -- ^ type-checking plugin written with this library + -> GHC.TcPlugin -- ^ type-checking plugin for GHC +mkTcPlugin ( TcPlugin + { tcPluginInit = tcPluginInit :: TcPluginM Init userDefs + , tcPluginSolve + , tcPluginRewrite + , tcPluginPostTc + , tcPluginShutdown + } + ) = + GHC.TcPlugin + { GHC.tcPluginInit = adaptUserInit tcPluginInit +#ifdef HAS_REWRITING + , GHC.tcPluginSolve = adaptUserSolve tcPluginSolve + , GHC.tcPluginRewrite = adaptUserRewrite tcPluginRewrite +#else + , GHC.tcPluginSolve = adaptUserSolveAndRewrite + tcPluginSolve tcPluginRewrite +#endif +#if MIN_VERSION_ghc(10,0,0) + , GHC.tcPluginPostTc = adaptUserPostTc tcPluginPostTc + , GHC.tcPluginShutdown = adaptUserShutdown tcPluginShutdown +#else + , GHC.tcPluginStop = adaptUserStop + tcPluginPostTc tcPluginShutdown +#endif + } + where + adaptUserInit :: TcPluginM Init userDefs -> GHC.TcPluginM ( TcPluginDefs userDefs ) + adaptUserInit userInit = do + tcPluginBuiltinDefs <- initBuiltinDefs + tcPluginUserDefs <- tcPluginInitM userInit + pure ( TcPluginDefs { tcPluginBuiltinDefs, tcPluginUserDefs }) + +#ifdef HAS_REWRITING + -- (no deriveds) + adaptUserSolve :: ( userDefs -> TcPluginSolver ) + -> TcPluginDefs userDefs + -> GHC.TcPluginSolver + adaptUserSolve userSolve ( TcPluginDefs { tcPluginUserDefs, tcPluginBuiltinDefs } ) + = \ evBindsVar givens wanteds -> do + tcPluginSolveM ( userSolve tcPluginUserDefs givens wanteds ) + tcPluginBuiltinDefs evBindsVar + adaptUserRewrite :: ( userDefs -> GHC.UniqFM GHC.TyCon TcPluginRewriter ) + -> TcPluginDefs userDefs -> GHC.UniqFM GHC.TyCon GHC.TcPluginRewriter + adaptUserRewrite userRewrite ( TcPluginDefs { tcPluginUserDefs, tcPluginBuiltinDefs }) + = fmap + ( \ userRewriter rewriteEnv givens tys -> + tcPluginRewriteM ( userRewriter givens tys ) tcPluginBuiltinDefs rewriteEnv + ) + ( userRewrite tcPluginUserDefs ) +#else + adaptUserSolveAndRewrite + :: ( userDefs -> TcPluginSolver ) + -> ( userDefs -> GHC.UniqFM +#if MIN_VERSION_ghc(9,0,0) + GHC.TyCon +#endif + TcPluginRewriter + ) + -> TcPluginDefs userDefs + -> GHC.TcPluginSolver + adaptUserSolveAndRewrite userSolve userRewrite ( TcPluginDefs { tcPluginUserDefs, tcPluginBuiltinDefs } ) + = \ givens0 deriveds0 wanteds0 -> do +#if MIN_VERSION_ghc(9,1,0) + let givens = givens0 + deriveds = deriveds0 + wanteds = wanteds0 +#else + let ( givens, deriveds, wanteds ) = unflattenCts givens0 deriveds0 wanteds0 + tcPluginTrace "ghc-tcplugin-api: unflattening" $ + vcat [ text "givens:" <+> ppr givens0 + , text "deriveds:" <+> ppr deriveds0 + , text "wanteds:" <+> ppr wanteds0 + , text (replicate 80 '=') + , text "givens:" <+> ppr givens + , text "deriveds:" <+> ppr deriveds + , text "wanteds:" <+> ppr wanteds + ] +#endif + evBindsVar <- GHC.getEvBindsTcPluginM + res <- + shimRewriter + givens deriveds wanteds + ( fmap + ( \ userRewriter rewriteEnv gs tys -> + tcPluginRewriteM ( userRewriter gs tys ) + tcPluginBuiltinDefs rewriteEnv + ) + ( userRewrite tcPluginUserDefs ) + ) + ( \ gs ds ws -> + tcPluginSolveM ( userSolve tcPluginUserDefs gs ws ) + tcPluginBuiltinDefs evBindsVar ds + ) +#if MIN_VERSION_ghc(9,1,0) + return res +#else + let origCts = + mkVarEnv + [ ( ctEvId ct, ct ) + | ct <- givens0 ++ wanteds0 ] + case res of + GHC.TcPluginOk solved new -> do + -- If we are solving a constraint that has been flattened, make + -- sure to solve the original constraint instead of the flattened + -- constraint, otherwise GHC gets very confused. + let + lookupOrigCt ct + | isDerived (ctEvidence ct) + = ct + | Just ct' <- lookupVarEnv origCts ( ctEvId ct ) + = ct' + | otherwise + = ct + solved' = map ( \ ( ev, ct ) -> ( ev, lookupOrigCt ct ) ) solved + return $ GHC.TcPluginOk solved' new + GHC.TcPluginContradiction {} -> + return res +#endif +#endif + +#if MIN_VERSION_ghc(10,0,0) + adaptUserPostTc :: ( userDefs -> TcPluginM PostTc () ) -> TcPluginDefs userDefs -> GHC.TcPluginM () + adaptUserPostTc userPostTc ( TcPluginDefs { tcPluginUserDefs } ) = + tcPluginPostTcM $ userPostTc tcPluginUserDefs + adaptUserShutdown :: ( userDefs -> IO () ) -> TcPluginDefs userDefs -> IO () + adaptUserShutdown userShutdown ( TcPluginDefs { tcPluginUserDefs } ) = + userShutdown tcPluginUserDefs +#else + -- Prior to GHC 10.0, run the "post-tc" and "shutdown" actions in sequence, + -- at the end of typechecking. Typechecker plugins do not persist to desugaring. + adaptUserStop :: ( userDefs -> TcPluginM PostTc () ) -> ( userDefs -> IO () ) -> TcPluginDefs userDefs -> GHC.TcPluginM () + adaptUserStop userPostTc userShutdown ( TcPluginDefs { tcPluginUserDefs } ) = do + tcPluginPostTcM $ userPostTc tcPluginUserDefs + GHC.unsafeTcPluginTcM . liftIO $ userShutdown tcPluginUserDefs +#endif + + +-- | @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. +-- +-- These operations are supported by the monads that 'tcPluginSolve' +-- and 'tcPluginRewrite' use; it is not possible to emit work or +-- throw type errors in 'tcPluginInit' or 'tcPluginPostTc'. +-- +-- See 'mkTcPluginErrorTy' and 'GHC.TcPlugin.API.emitWork' for functions +-- which require this typeclass. +class MonadTcPlugin m => MonadTcPluginWork m where + {-# MINIMAL #-} -- to avoid the methods appearing in the haddocks + askBuiltins :: m BuiltinDefs + askBuiltins = error "askBuiltins: no default implementation" +instance MonadTcPluginWork ( TcPluginM Solve ) where + askBuiltins = TcPluginSolveM + \ builtinDefs + _evBinds +#ifdef HAS_DERIVEDS + _deriveds +#endif + -> pure builtinDefs +instance MonadTcPluginWork ( TcPluginM Rewrite ) where + askBuiltins = TcPluginRewriteM \ builtinDefs _evBinds -> pure builtinDefs + +instance TypeError ( 'Text "Cannot emit new work in 'tcPluginInit'." ) + => MonadTcPluginWork ( TcPluginM Init ) where + askBuiltins = error "Cannot emit new work in 'tcPluginInit'." +instance TypeError ( 'Text "Cannot emit new work in 'tcPluginPostTc'." ) + => MonadTcPluginWork ( TcPluginM PostTc ) where + askBuiltins = error "Cannot emit new work in 'tcPluginPostTc'." + +-- | Use this type like 'GHC.TypeLits.ErrorMessage' to write an error message. +-- This error message can then be thrown at the type-level by the plugin, +-- by emitting a wanted constraint whose predicate is obtained from 'mkTcPluginErrorTy'. +-- +-- A 'GHC.Tc.Types.Constraint.CtLoc' will still need to be provided in order to inform GHC of the +-- origin of the error (e.g.: which part of the source code should be +-- highlighted?). See 'GHC.TcPlugin.API.setCtLocM'. +data TcPluginErrorMessage + = Txt !String + -- ^ Show the text as is. + | PrintType !GHC.Type + -- ^ Pretty print the given type. + | (:|:) !TcPluginErrorMessage !TcPluginErrorMessage + -- ^ Put two messages side by side. + | (:-:) !TcPluginErrorMessage !TcPluginErrorMessage + -- ^ Stack two messages vertically. +infixl 5 :|: +infixl 6 :-: + +-- | Create an error type with the desired error message. +-- +-- The result can be paired with a 'GHC.Tc.Types.Constraint.CtLoc' in order to throw a type error, +-- for instance by using 'GHC.TcPlugin.API.newWanted'. +mkTcPluginErrorTy :: MonadTcPluginWork m => TcPluginErrorMessage -> m GHC.PredType +mkTcPluginErrorTy msg = do + builtinDefs@( BuiltinDefs { typeErrorTyCon } ) <- askBuiltins + let + errorMsgTy :: GHC.PredType + errorMsgTy = interpretErrorMessage builtinDefs msg + pure $ GHC.mkTyConApp typeErrorTyCon [ GHC.constraintKind, errorMsgTy ] + +instance ( Monad ( TcPluginM s ), MonadTcPlugin ( TcPluginM s ) ) + => MonadThings ( TcPluginM s ) where + lookupThing = unsafeLiftTcM . lookupThing + +-------------------------------------------------------------------------------- +-- Private types and functions. +-- Not exposed at all, even from the internal module. + +data BuiltinDefs = + BuiltinDefs + { typeErrorTyCon :: !GHC.TyCon + , textTyCon :: !GHC.TyCon + , showTypeTyCon :: !GHC.TyCon + , concatTyCon :: !GHC.TyCon + , vcatTyCon :: !GHC.TyCon + } + +data TcPluginDefs s + = TcPluginDefs + { tcPluginBuiltinDefs :: !BuiltinDefs + , tcPluginUserDefs :: !s + } + +initBuiltinDefs :: GHC.TcPluginM BuiltinDefs +initBuiltinDefs = do + typeErrorTyCon <- GHC.tcLookupTyCon GHC.TypeLits.errorMessageTypeErrorFamName + textTyCon <- GHC.promoteDataCon <$> GHC.tcLookupDataCon GHC.TypeLits.typeErrorTextDataConName + showTypeTyCon <- GHC.promoteDataCon <$> GHC.tcLookupDataCon GHC.TypeLits.typeErrorShowTypeDataConName + concatTyCon <- GHC.promoteDataCon <$> GHC.tcLookupDataCon GHC.TypeLits.typeErrorAppendDataConName + vcatTyCon <- GHC.promoteDataCon <$> GHC.tcLookupDataCon GHC.TypeLits.typeErrorVAppendDataConName + pure ( BuiltinDefs { .. } ) + +interpretErrorMessage :: BuiltinDefs -> TcPluginErrorMessage -> GHC.PredType +interpretErrorMessage ( BuiltinDefs { .. } ) = go + where + go :: TcPluginErrorMessage -> GHC.PredType + go ( Txt str ) = + GHC.mkTyConApp textTyCon [ GHC.LitTy . GHC.StrTyLit . GHC.fsLit $ str ] + go ( PrintType ty ) = + GHC.mkTyConApp showTypeTyCon [ GHC.typeKind ty, ty ] + -- The kind gets ignored by GHC when printing the error message (see GHC.Core.Type.pprUserTypeErrorTy). + -- However, including the wrong kind can lead to ASSERT failures, so we compute the kind and pass it. + go ( msg1 :|: msg2 ) = + GHC.mkTyConApp concatTyCon [ go msg1, go msg2 ] + go ( msg1 :-: msg2 ) = + GHC.mkTyConApp vcatTyCon [ go msg1, go msg2 ]
src/GHC/TcPlugin/API/Internal/Shim.hs view
@@ -1,975 +1,1098 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DerivingVia #-}-{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE ViewPatterns #-}--{-|-Module: GHC.TcPlugin.API.Internal.Shim--This module defines a compatibility shim which allows-the library to support a limited form of type-family rewriting-in typechecking plugins on GHC 9.0 and 9.2.--}--module GHC.TcPlugin.API.Internal.Shim- ( Reduction(..), mkReduction- , TcPluginSolveResult(TcPluginContradiction, TcPluginOk, ..), TcPluginRewriteResult(..)- , RewriteEnv(..)- , shimRewriter- )- where---- base-import Prelude- hiding ( Floating(cos), iterate )-import Control.Monad- ( forM, unless, when )-import Data.Foldable- ( traverse_-#if !MIN_VERSION_ghc(9,2,0)- , foldlM-#endif- )-#if MIN_VERSION_ghc(9,2,0)-import Data.List.NonEmpty- ( NonEmpty((:|)) )-#endif-import Data.Maybe- ( fromMaybe )---- transformers-import Control.Monad.Trans.Reader- ( ReaderT(..) )-import Control.Monad.Trans.State.Strict- ( StateT(..) )---- ghc-import GHC.Core.Coercion- ( coercionRole- , mkReflCo, mkSymCo- , mkAppCos, mkNomReflCo, mkSubCo- , mkTyConAppCo, tyConRolesX- , tyConRolesRepresentational- )-import GHC.Core.Predicate- ( EqRel(..), eqRelRole )-import GHC.Core.TyCo.Rep- ( Type(..), Kind, Coercion(..), MCoercion(..), TyCoBinder(..)- , isNamedBinder, mkTyVarTy- )-import GHC.Core.TyCon- ( TyCon(..), TyConBinder, TyConBndrVis(..)-#if MIN_VERSION_ghc(9,2,0)- , isForgetfulSynTyCon-#endif- , isFamFreeTyCon, isTypeSynonymTyCon- , isTypeFamilyTyCon- , tyConBinders, tyConResKind- , tyConArity- )-import GHC.Core.Type- ( TyVar- , tcView , mkTyConApp-#if MIN_VERSION_ghc(9,0,0)- , mkScaled, tymult-#endif- , coreView, tyVarKind- )-#if MIN_VERSION_ghc(9,2,0)-import GHC.Data.Maybe- ( firstJustsM )-#endif-import GHC.Tc.Plugin- ( newWanted, newDerived )-import GHC.Tc.Solver.Monad- ( TcS- , zonkCo, zonkTcType- , isFilledMetaTyVar_maybe- , getInertEqs- , checkReductionDepth- , matchFam- , runTcPluginTcS, runTcSWithEvBinds- , traceTcS- , setWantedEvTerm-#if MIN_VERSION_ghc(9,2,0)- , lookupFamAppCache, lookupFamAppInert, extendFamAppCache- , pattern EqualCtList-#else- , lookupFlatCache, extendFlatCache-#endif- )-import GHC.Tc.Types- ( TcPluginM- , unsafeTcPluginTcM, getEvBindsTcPluginM- )-import qualified GHC.Tc.Types as GHC- ( TcPluginResult(..) )-import GHC.Tc.Types.Constraint- ( Ct(..), CtEvidence(..)- , CtLoc, CtFlavour(..), CtFlavourRole, ShadowInfo(..)-#if MIN_VERSION_ghc(9,2,0)- , CanEqLHS(..)-#endif- , ctLoc, ctFlavour, ctEvidence, ctEqRel, ctEvPred- , ctEvExpr, ctEvCoercion, ctEvFlavour- , bumpCtLocDepth, eqCanRewriteFR, mkNonCanonical- )-import GHC.Tc.Types.Evidence- ( EvTerm(..), Role(..)- , evCast, mkTcTransCo , mkTcTyConAppCo- )-import GHC.Tc.Utils.TcType- ( TcTyCoVarSet-#if MIN_VERSION_ghc(9,2,0)- , tcSplitForAllTyVarBinders-#else- , tcSplitForAllVarBndrs-#endif- , tcSplitTyConApp_maybe- , tcTypeKind- , tyCoVarsOfType- )-import GHC.Types.Unique.FM- ( UniqFM, lookupUFM, isNullUFM )-import GHC.Types.Var- ( TcTyVar, VarBndr(..)-#if !MIN_VERSION_ghc(9,2,0)- , TyVarBinder-#endif- , updateTyVarKindM- )-import GHC.Types.Var.Env- ( lookupDVarEnv )-import GHC.Types.Var.Set- ( emptyVarSet )-import GHC.Utils.Misc- ( dropList )-import GHC.Utils.Monad- ( zipWith3M )-import GHC.Utils.Outputable- ( Outputable(..), SDoc, empty )---- ghc-tcplugin-api-import GHC.TcPlugin.API.Internal.Shim.Reduction-------------------------------------------------------------------------------------- | The type-family rewriting environment.-data RewriteEnv- = FE { fe_loc :: !CtLoc- , fe_flavour :: !CtFlavour- , fe_eq_rel :: !EqRel- }---- | Result of running a solver plugin.-data TcPluginSolveResult- = TcPluginSolveResult- { -- | Insoluble constraints found by the plugin.- --- -- These constraints will be added to the inert set,- -- and reported as insoluble to the user.- tcPluginInsolubleCts :: [Ct]- -- | Solved constraints, together with their evidence.- --- -- These are removed from the inert set, and the- -- evidence for them is recorded.- , tcPluginSolvedCts :: [(EvTerm, Ct)]- -- | New constraints that the plugin wishes to emit.- --- -- These will be added to the work list.- , tcPluginNewCts :: [Ct]- }---- | The plugin found a contradiction.--- The returned constraints are removed from the inert set,--- and recorded as insoluble.------ The returned list of constraints should never be empty.-pattern TcPluginContradiction :: [Ct] -> TcPluginSolveResult-pattern TcPluginContradiction insols- = TcPluginSolveResult- { tcPluginInsolubleCts = insols- , tcPluginSolvedCts = []- , tcPluginNewCts = [] }---- | The plugin has not found any contradictions,------ The first field is for constraints that were solved.--- The second field contains new work, that should be processed by--- the constraint solver.-pattern TcPluginOk :: [(EvTerm, Ct)] -> [Ct] -> TcPluginSolveResult-pattern TcPluginOk solved new- = TcPluginSolveResult- { tcPluginInsolubleCts = []- , tcPluginSolvedCts = solved- , tcPluginNewCts = new }---- The 'TcPluginSolveResult' datatype changed in GHC 9.4,--- allowing users to return solved and new constraints even in case of--- a contradiction.------ This function simply drops the solved and new constraints on older versions,--- although it does at least still bind the evidence in case of solved Wanteds.-adaptSolveResult :: Bool -> TcPluginSolveResult -> TcPluginM GHC.TcPluginResult-adaptSolveResult doingGivens- ( TcPluginSolveResult- { tcPluginInsolubleCts = insols- , tcPluginSolvedCts = solved- , tcPluginNewCts = new- }- )- | null insols- = pure $ GHC.TcPluginOk solved new- | null solved && null new- = pure $ GHC.TcPluginContradiction insols- | otherwise- = do- evBinds <- getEvBindsTcPluginM- unsafeTcPluginTcM . runTcSWithEvBinds evBinds $ do- unless doingGivens $ traverse_ ( uncurry setEv ) solved- --updInertCans (removeInertCts $ fmap snd solved) -- These don't do anything, as the inert set and work list- --emitWork new -- are confined to this run of the plugin.- pure $ GHC.TcPluginContradiction insols- where- setEv :: EvTerm -> Ct -> TcS ()- setEv ev ( ctEvidence -> CtWanted { ctev_dest = dest } )- = setWantedEvTerm dest ev- setEv _ _- = pure ()--data TcPluginRewriteResult- =- -- | The plugin does not rewrite the type family application.- TcPluginNoRewrite-- -- | The plugin rewrites the type family application- -- providing a rewriting together with evidence.- --- -- The plugin can also emit additional wanted constraints.- | TcPluginRewriteTo- { tcPluginReduction :: !Reduction- , tcRewriterWanteds :: [Ct]- }--type Rewriter = RewriteEnv -> [Ct] -> [Type] -> TcPluginM TcPluginRewriteResult--type Rewriters =- UniqFM-#if MIN_VERSION_ghc(9,0,0)- TyCon-#endif- Rewriter---- | Emulate type-family rewriting functionality in a constraint solving plugin,--- by traversing through all the constraints and rewriting any type-family applications--- inside them.-shimRewriter :: [Ct] -> [Ct] -> [Ct]- -> Rewriters- -> ( [Ct] -> [Ct] -> [Ct] -> TcPluginM TcPluginSolveResult )- -> TcPluginM GHC.TcPluginResult-shimRewriter givens deriveds wanteds rws solver- | isNullUFM rws- = adaptSolveResult (null wanteds) =<< solver givens deriveds wanteds- | otherwise- = do- TcPluginSolveResult- { tcPluginInsolubleCts = contras- , tcPluginSolvedCts = solved- , tcPluginNewCts = new- } <- solver givens deriveds wanteds- ( rewrittenDeriveds, solvedDeriveds, newCts1 ) <- traverseCts ( reduceCt rws givens ) deriveds- ( rewrittenWanteds , solvedWanteds , newCts2 ) <- traverseCts ( reduceCt rws givens ) wanteds- adaptSolveResult (null wanteds) $- TcPluginSolveResult- { tcPluginInsolubleCts = contras- , tcPluginSolvedCts = solved ++ solvedDeriveds ++ solvedWanteds- , tcPluginNewCts = new ++ newCts1 ++ rewrittenDeriveds ++ newCts2 ++ rewrittenWanteds- }--reduceCt :: Rewriters- -> [Ct]- -> Ct- -> TcPluginM ( Maybe ( Ct, (EvTerm, Ct) ), [Ct] )-reduceCt rws givens ct = do- let- predTy :: Type- predTy = ctEvPred ( ctEvidence ct )- rwEnv :: RewriteEnv- rwEnv = FE ( ctLoc ct ) ( ctFlavour ct ) ( ctEqRel ct )- shimRewriteEnv :: ShimRewriteEnv- shimRewriteEnv = ShimRewriteEnv rws rwEnv givens- ( res, newCts ) <- runRewritePluginM shimRewriteEnv ( rewrite_one predTy )- case res of- Nothing -> pure ( Nothing, newCts )- Just ( Reduction co predTy' ) -> do- ctEv' <- case ctFlavour ct of- Given -> error "ghc-tcplugin-api: unexpected Given in reduceCt"- Wanted {} -> newWanted ( ctLoc ct ) predTy'- Derived -> newDerived ( ctLoc ct ) predTy'- let- role :: Role- role = coercionRole co- cast_co :: Coercion- cast_co = mkSymCo $ case role of- Nominal -> mkSubCo co- _ -> co- pure ( Just- ( mkNonCanonical ctEv'- , ( evCast ( ctEvExpr ctEv' ) cast_co, ct )- )- , newCts- )--traverseCts :: Monad m- => ( a -> m ( Maybe (b, c), [d] ) )- -> [a]- -> m ( [b], [c], [d] )-traverseCts _ [] = pure ( [], [], [] )-traverseCts f (a : as) = do- ( mb_bc, ds ) <- f a- ( bs, cs, dss ) <- traverseCts f as- case mb_bc of- Nothing -> pure ( bs, cs, ds ++ dss )- Just (b,c) -> pure ( b : bs, c : cs, ds ++ dss )------------------------------------------------------------------------------------- The following is (mostly) copied from GHC 9.4's GHC.Tc.Solver.Rewrite module.--rewrite_one :: Type -> RewriteM Reduction-rewrite_one ty- | Just ty' <- rewriterView ty -- See Note [Rewriting synonyms]- = rewrite_one ty'--rewrite_one xi@(LitTy {})- = do { role <- getRole- ; return $ mkReflRedn role xi }--rewrite_one (TyVarTy tv)- = rewriteTyVar tv--rewrite_one (AppTy ty1 ty2)- = rewrite_app_tys ty1 [ty2]--rewrite_one (TyConApp tc tys)- | isTypeFamilyTyCon tc- = rewrite_fam_app tc tys-- | otherwise- = rewrite_ty_con_app tc tys--rewrite_one- (FunTy-#if MIN_VERSION_ghc(8,10,0)- vis-#endif-#if MIN_VERSION_ghc(9,0,0)- mult-#endif- ty1- ty2- )- = do { arg_redn <- rewrite_one ty1- ; res_redn <- rewrite_one ty2-#if MIN_VERSION_ghc(9,0,0)- ; w_redn <- setEqRel NomEq $ rewrite_one mult-#endif- ; role <- getRole- ; return $- mkFunRedn- role-#if MIN_VERSION_ghc(8,10,0)- vis-#endif-#if MIN_VERSION_ghc(9,0,0)- w_redn-#endif- arg_redn- res_redn- }--rewrite_one ty@(ForAllTy {})- = do { let (bndrs, rho) = tcSplitForAllTyVarBinders ty- ; redn <- rewrite_one rho- ; return $ mkHomoForAllRedn bndrs redn }--rewrite_one (CastTy ty g)- = do { redn <- rewrite_one ty- ; g' <- rewrite_co g- ; role <- getRole- ; return $ mkCastRedn1 role ty g' redn }--rewrite_one (CoercionTy co)- = do { co' <- rewrite_co co- ; role <- getRole- ; return $ mkReflCoRedn role co' }--rewrite_reduction :: Reduction -> RewriteM Reduction-rewrite_reduction (Reduction co xi) = do- redn <- bumpDepth $ rewrite_one xi- pure $ co `mkTransRedn` redn--rewrite_app_tys :: Type -> [Type] -> RewriteM Reduction-rewrite_app_tys (AppTy ty1 ty2) tys = rewrite_app_tys ty1 (ty2:tys)-rewrite_app_tys fun_ty arg_tys- = do { redn <- rewrite_one fun_ty- ; rewrite_app_ty_args redn arg_tys }--rewrite_app_ty_args :: Reduction -> [Type] -> RewriteM Reduction-rewrite_app_ty_args redn []- = return redn-rewrite_app_ty_args fun_redn@(Reduction fun_co fun_xi) arg_tys- = do { het_redn <- case tcSplitTyConApp_maybe fun_xi of- Just (tc, xis) ->- do { let tc_roles = tyConRolesRepresentational tc- arg_roles = dropList xis tc_roles- ; ArgsReductions (Reductions arg_cos arg_xis) kind_co- <- rewrite_vector (tcTypeKind fun_xi) arg_roles arg_tys-- ; eq_rel <- getEqRel- ; let app_xi = mkTyConApp tc (xis ++ arg_xis)- app_co = case eq_rel of- NomEq -> mkAppCos fun_co arg_cos- ReprEq -> mkAppCos fun_co (map mkNomReflCo arg_tys)- `mkTcTransCo`- mkTcTyConAppCo Representational tc- (zipWith mkReflCo tc_roles xis ++ arg_cos)-- ; return $- mkHetReduction- (mkReduction app_co app_xi )- kind_co }- Nothing ->- do { ArgsReductions redns kind_co- <- rewrite_vector (tcTypeKind fun_xi) (repeat Nominal) arg_tys- ; return $ mkHetReduction (mkAppRedns fun_redn redns) kind_co }-- ; role <- getRole- ; return (homogeniseHetRedn role het_redn) }--{-# INLINE rewrite_args_tc #-}-rewrite_args_tc :: TyCon -> Maybe [Role] -> [Type] -> RewriteM ArgsReductions-rewrite_args_tc tc = rewrite_args all_bndrs any_named_bndrs inner_ki emptyVarSet- -- NB: TyCon kinds are always closed- where- -- There are many bang patterns in here. It's been observed that they- -- greatly improve performance of an optimized build.- -- The T9872 test cases are good witnesses of this fact.-- (bndrs, named)- = ty_con_binders_ty_binders' (tyConBinders tc)- -- it's possible that the result kind has arrows (for, e.g., a type family)- -- so we must split it- (inner_bndrs, inner_ki, inner_named) = split_pi_tys' (tyConResKind tc)- !all_bndrs = bndrs `chkAppend` inner_bndrs- !any_named_bndrs = named || inner_named- -- NB: Those bangs there drop allocations in T9872{a,c,d} by 8%.--rewrite_fam_app :: TyCon -> [Type] -> RewriteM Reduction-rewrite_fam_app tc tys = do- let (tys1, tys_rest) = splitAt (tyConArity tc) tys- redn <- rewrite_exact_fam_app tc tys1- rewrite_app_ty_args redn tys_rest--rewrite_exact_fam_app :: TyCon -> [Type] -> RewriteM Reduction-rewrite_exact_fam_app tc tys = do- checkStackDepth $ mkTyConApp tc tys- rws <- getRewriters- let- mbRewriter :: Maybe Rewriter- mbRewriter = lookupUFM rws tc- result1 <- try_to_reduce tc tys mbRewriter- case result1 of- Just redn -> finish False redn- _ -> do- eq_rel <- getEqRel- ArgsReductions (Reductions cos xis) kind_co <-- if eq_rel == NomEq- then rewrite_args_tc tc Nothing tys- else setEqRel NomEq $- rewrite_args_tc tc Nothing tys- let- role = eqRelRole eq_rel- args_co = mkTyConAppCo role tc cos- homogenise :: Reduction -> Reduction- homogenise redn- = homogeniseHetRedn role- $ mkHetReduction- (args_co `mkTransRedn` redn)- kind_co- give_up :: Reduction- give_up = homogenise $ mkReflRedn role (mkTyConApp tc xis)-- result2 <- liftTcS $ lookupFamAppInert tc xis- flavour <- getFlavour- case result2 of- Just (co, xi, fr@(_, inert_eq_rel))- | fr `eqCanRewriteFR` (flavour, eq_rel)- , let- redn :: Reduction- redn = Reduction (mkSymCoOnGHC92 co) xi- -> finish True (homogenise $ downgradeRedn role' inert_role redn)- where- inert_role = eqRelRole inert_eq_rel- role' = eqRelRole eq_rel- _ -> do- result3 <- try_to_reduce tc xis mbRewriter- case result3 of- Just redn -> finish True (homogenise redn)- _ -> return give_up- where- finish :: Bool -> Reduction -> RewriteM Reduction- finish use_cache (Reduction co xi) = do- Reduction fully_co fully <- bumpDepth $ rewrite_one xi- let final_redn@(Reduction final_co final_xi) = Reduction (co `mkTcTransCo` fully_co) fully- eq_rel <- getEqRel- flavour <- getFlavour- when (use_cache && eq_rel == NomEq && flavour /= Derived) $- liftTcS $- extendFamAppCache tc tys- ( mkSymCoOnGHC92 final_co, final_xi )-#if !MIN_VERSION_ghc(9,2,0)- flavour-#endif- return final_redn- {-# INLINE finish #-}---- On GHC 9.2, lookupFamAppCache and matchFam--- use a coercion that goes from right to left.--- On GHC 9.0 (and GHC 9.4 and above), the coercions--- always go from left to right.--- (Recall: this module is only used for GHC 9.2 and below.)-mkSymCoOnGHC92 :: Coercion -> Coercion-mkSymCoOnGHC92 co =-#if MIN_VERSION_ghc(9,2,0)- mkSymCo co-#else- co-#endif---- Returned coercion is output ~r input, where r is the role in the RewriteM monad--- See Note [How to normalise a family application]-try_to_reduce :: TyCon -> [Type] -> Maybe Rewriter- -> RewriteM (Maybe Reduction)-try_to_reduce tc tys mb_rewriter = do- result <-- firstJustsM- [ runTcPluginRewriter mb_rewriter tys- , liftTcS $ mkRed <$> lookupFamAppCache tc tys- , liftTcS $ mkRed <$> matchFam tc tys ]- forM result downgrade- where- mkRed :: Maybe (Coercion, Type) -> Maybe Reduction- mkRed = fmap $ \ (co, ty) -> Reduction (mkSymCoOnGHC92 co) ty- downgrade :: Reduction -> RewriteM Reduction- downgrade redn@(Reduction co xi) = do- eq_rel <- getEqRel- case eq_rel of- NomEq -> return redn- ReprEq -> return $ Reduction (mkSubCo co) xi--runTcPluginRewriter :: Maybe Rewriter- -> [Type]- -> RewriteM (Maybe Reduction)-runTcPluginRewriter mbRewriter tys =- case mbRewriter of- Nothing -> return Nothing- Just rewriter -> do- traceRewriteM "runTcPluginRewriter { " empty- res <- runRewriter rewriter- traceRewriteM "runTcPluginRewriter }" ( ppr res )- pure res- where- runRewriter :: Rewriter -> RewriteM (Maybe Reduction)- runRewriter rewriter = do- rewriteResult <- RewriteM \ env s -> do- res <- runTcPluginTcS ( rewriter ( rewriteEnv env ) ( rewriteGivens env ) tys )- pure ( res, s )- case rewriteResult of- TcPluginRewriteTo- { tcPluginReduction = redn- , tcRewriterWanteds = wanteds- } -> addRewriting ( Just redn ) wanteds- TcPluginNoRewrite { }- -> addRewriting Nothing []--rewrite_ty_con_app :: TyCon -> [Type] -> RewriteM Reduction-rewrite_ty_con_app tc tys- = do { role <- getRole- ; let m_roles | Nominal <- role = Nothing- | otherwise = Just $ tyConRolesX role tc- ; ArgsReductions redns kind_co <- rewrite_args_tc tc m_roles tys- ; let tyconapp_redn- = mkHetReduction- (mkTyConAppRedn role tc redns)- kind_co- ; return $ homogeniseHetRedn role tyconapp_redn }--rewrite_co :: Coercion -> RewriteM Coercion-rewrite_co co = liftTcS $ zonkCo co--rewriterView :: Type -> Maybe Type-rewriterView ty@(TyConApp tc _)- | ( isTypeSynonymTyCon tc && not (isFamFreeTyCon tc) )-#if MIN_VERSION_ghc(9,2,0)- || isForgetfulSynTyCon tc-#endif- = tcView ty-rewriterView _other = Nothing--rewriteTyVar :: TyVar -> RewriteM Reduction-rewriteTyVar tv = do- mb_yes <- rewrite_tyvar1 tv- case mb_yes of- RTRFollowed redn -> rewrite_reduction redn- RTRNotFollowed -> do- tv' <- liftTcS $ updateTyVarKindM zonkTcType tv- role <- getRole- let ty' = mkTyVarTy tv'- pure $ mkReflRedn role ty'--data RewriteTvResult- = RTRNotFollowed- | RTRFollowed !Reduction--rewrite_tyvar1 :: TcTyVar -> RewriteM RewriteTvResult-rewrite_tyvar1 tv = do- mb_ty <- liftTcS $ isFilledMetaTyVar_maybe tv- case mb_ty of- Just ty -> do- role <- getRole- return $ RTRFollowed $ mkReflRedn role ty- Nothing -> do- fr <- getFlavourRole- rewrite_tyvar2 tv fr--rewrite_tyvar2 :: TcTyVar -> CtFlavourRole -> RewriteM RewriteTvResult-rewrite_tyvar2 tv fr@(_, eq_rel) = do- ieqs <- liftTcS $ getInertEqs- case lookupDVarEnv ieqs tv of-#if MIN_VERSION_ghc(9,2,0)- Just (EqualCtList (ct :| _))- | CEqCan { cc_ev = ctev, cc_lhs = TyVarLHS {}- , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct-#else- Just (ct : _)- | CTyEqCan { cc_ev = ctev- , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct-#endif- , let ct_fr = (ctEvFlavour ctev, ct_eq_rel)- , ct_fr `eqCanRewriteFR` fr- -> do- let rewriting_co1 = ctEvCoercion ctev- rewriting_co = case (ct_eq_rel, eq_rel) of- (ReprEq, _rel) -> rewriting_co1- (NomEq, NomEq) -> rewriting_co1- (NomEq, ReprEq) -> mkSubCo rewriting_co1- return $ RTRFollowed $ mkReduction rewriting_co rhs_ty - _other -> return RTRNotFollowed--rewrite_vector :: Kind- -> [Role]- -> [Type]- -> RewriteM ArgsReductions-rewrite_vector ki roles tys- = do { eq_rel <- getEqRel- ; let mb_roles = case eq_rel of { NomEq -> Nothing; ReprEq -> Just roles }- ; rewrite_args bndrs any_named_bndrs inner_ki fvs mb_roles tys- }- where- (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki- fvs = tyCoVarsOfType ki-{-# INLINE rewrite_vector #-}--split_pi_tys' :: Type -> ([TyCoBinder], Type, Bool)-split_pi_tys' ty = split ty ty- where- split _ (ForAllTy b res) =- let !(bs, ty', _) = split res res- in (Named b : bs, ty', True)- split _- (FunTy-#if MIN_VERSION_ghc(8,10,0)- af-#endif-#if MIN_VERSION_ghc(9,0,0)- w-#endif- 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- arg-#endif- : bs- , ty', named- )- split orig_ty ty' | Just ty'' <- coreView ty' = split orig_ty ty''- split orig_ty _ = ([], orig_ty, False)-{-# INLINE split_pi_tys' #-}--ty_con_binders_ty_binders' :: [TyConBinder] -> ([TyCoBinder], Bool)-ty_con_binders_ty_binders' = foldr go ([], False)- where- go (Bndr tv (NamedTCB vis)) (bndrs, _)- = (Named (Bndr tv vis) : bndrs, True)- 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-#endif- (tyVarKind tv)- )- : bndrs- , n)- {-# INLINE go #-}-{-# INLINE ty_con_binders_ty_binders' #-}--{-# INLINE rewrite_args #-}-rewrite_args :: [TyCoBinder] -> Bool- -> Kind -> TcTyCoVarSet- -> Maybe [Role] -> [Type]- -> RewriteM ArgsReductions-rewrite_args orig_binders- any_named_bndrs- orig_inner_ki- orig_fvs- orig_m_roles- orig_tys- = case (orig_m_roles, any_named_bndrs) of- (Nothing, False) -> rewrite_args_fast orig_tys- _ -> rewrite_args_slow orig_binders orig_inner_ki orig_fvs orig_roles orig_tys- where orig_roles = fromMaybe (repeat Nominal) orig_m_roles--{-# INLINE rewrite_args_fast #-}-rewrite_args_fast :: [Type] -> RewriteM ArgsReductions-rewrite_args_fast orig_tys- = fmap finish (iterate orig_tys)- where-- iterate :: [Type] -> RewriteM Reductions- iterate (ty : tys) = do- Reduction co xi <- rewrite_one ty- Reductions cos xis <- iterate tys- pure $ Reductions (co : cos) (xi : xis)- iterate [] = pure $ Reductions [] []-- {-# INLINE finish #-}- finish :: Reductions -> ArgsReductions- finish redns = ArgsReductions redns MRefl--{-# INLINE rewrite_args_slow #-}-rewrite_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet- -> [Role] -> [Type]- -> RewriteM ArgsReductions-rewrite_args_slow binders inner_ki fvs roles tys- = do { rewritten_args <- zipWith3M fl (map isNamedBinder binders ++ repeat True)- roles tys- ; return $ simplifyArgsWorker binders inner_ki fvs roles rewritten_args }- where- {-# INLINE fl #-}- fl :: Bool -- must we ensure to produce a real coercion here?- -- see comment at top of function- -> Role -> Type -> RewriteM Reduction- fl True r ty = noBogusCoercions $ fl1 r ty- fl False r ty = fl1 r ty-- {-# INLINE fl1 #-}- fl1 :: Role -> Type -> RewriteM Reduction- fl1 Nominal ty- = setEqRel NomEq $- rewrite_one ty-- fl1 Representational ty- = setEqRel ReprEq $- rewrite_one ty-- fl1 Phantom ty- = do { ty' <- liftTcS $ zonkTcType ty- ; return $ mkReflRedn Phantom ty' }--noBogusCoercions :: RewriteM a -> RewriteM a-noBogusCoercions thing_inside- = RewriteM \ env s ->- let !renv = rewriteEnv env- !renv' = case fe_flavour renv of- Derived -> renv { fe_flavour = Wanted WDeriv }- _ -> renv- !env' = env { rewriteEnv = renv' }- in- runRewriteM thing_inside env' s--chkAppend :: [a] -> [a] -> [a]-chkAppend xs ys- | null ys = xs- | otherwise = xs ++ ys------------------------------------------------------------------------------------data ReduceQ = NoReduction | DidReduce-instance Semigroup ReduceQ where- NoReduction <> NoReduction = NoReduction- _ <> _ = DidReduce-instance Monoid ReduceQ where- mempty = NoReduction--data RewriteState =- RewriteState- { rewrittenCts :: ![ Ct ]- , reductionOccurred :: !ReduceQ- }--data ShimRewriteEnv- = ShimRewriteEnv- { rewriters :: !Rewriters- , rewriteEnv :: !RewriteEnv- , rewriteGivens :: ![ Ct ]- }--newtype RewriteM a- = RewriteM- { runRewriteM- :: ShimRewriteEnv- -> RewriteState- -> TcS ( a, RewriteState )- }- deriving ( Functor, Applicative, Monad )- via ( ReaderT ShimRewriteEnv- ( StateT RewriteState TcS )- )--runRewritePluginM :: ShimRewriteEnv- -> RewriteM a- -> TcPluginM ( Maybe a, [Ct] )-runRewritePluginM env ( RewriteM { runRewriteM = run } ) = do-- evBindsVar <- getEvBindsTcPluginM- ( a, RewriteState { rewrittenCts, reductionOccurred } )- <- unsafeTcPluginTcM- $ runTcSWithEvBinds evBindsVar- $ run env ( RewriteState [] NoReduction )- let- mb_a = case reductionOccurred of- NoReduction -> Nothing- DidReduce -> Just a- pure ( mb_a, rewrittenCts )--addRewriting :: Maybe Reduction -> [Ct] -> RewriteM ( Maybe Reduction )-addRewriting mbRedn newCts = RewriteM \ _ ( RewriteState cts s ) ->- let- s' :: ReduceQ- s'- | Just _ <- mbRedn- = DidReduce- | otherwise- = s- in pure ( mbRedn , RewriteState ( cts <> newCts ) s' )--getRewriters :: RewriteM Rewriters-getRewriters = RewriteM \ env s -> pure ( rewriters env, s )--getRewriteEnvField :: (RewriteEnv -> a) -> RewriteM a-getRewriteEnvField accessor = RewriteM \ env s ->- pure ( accessor ( rewriteEnv env ), s )--getEqRel :: RewriteM EqRel-getEqRel = getRewriteEnvField fe_eq_rel--getRole :: RewriteM Role-getRole = eqRelRole <$> getEqRel--getFlavour :: RewriteM CtFlavour-getFlavour = getRewriteEnvField fe_flavour--getFlavourRole :: RewriteM CtFlavourRole-getFlavourRole = do- flavour <- getFlavour- eq_rel <- getEqRel- return (flavour, eq_rel)--setEqRel :: EqRel -> RewriteM a -> RewriteM a-setEqRel new_eq_rel thing_inside = RewriteM \ env s ->- if new_eq_rel == fe_eq_rel ( rewriteEnv env )- then runRewriteM thing_inside env s- else runRewriteM thing_inside ( setEqRel' env ) s- where- setEqRel' :: ShimRewriteEnv -> ShimRewriteEnv- setEqRel' env = env { rewriteEnv = ( rewriteEnv env ) { fe_eq_rel = new_eq_rel } }-{-# INLINE setEqRel #-}--liftTcS :: TcS a -> RewriteM a-liftTcS thing_inside = RewriteM \ _env s -> do- a <- thing_inside- pure ( a, s )--traceRewriteM :: String -> SDoc -> RewriteM ()-traceRewriteM herald doc = liftTcS $ traceTcS herald doc-{-# INLINE traceRewriteM #-}--getLoc :: RewriteM CtLoc-getLoc = getRewriteEnvField fe_loc--checkStackDepth :: Type -> RewriteM ()-checkStackDepth ty = do- loc <- getLoc- liftTcS $ checkReductionDepth loc ty--bumpDepth :: RewriteM a -> RewriteM a-bumpDepth (RewriteM thing_inside) = RewriteM \ env s -> do- let !renv = rewriteEnv env- !renv' = renv { fe_loc = bumpCtLocDepth ( fe_loc renv ) }- !env' = env { rewriteEnv = renv' }- thing_inside env' s--#if !MIN_VERSION_ghc(9,2,0)------------------------------------------------------------------------------------ GHC 9.0 compatibility.--firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a)-firstJustsM = foldlM go Nothing where- go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a)- go Nothing action = action- go result@(Just _) _action = return result--lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe (Coercion, Type))-lookupFamAppCache fam_tc tys = do- res <- lookupFlatCache fam_tc tys- pure $ case res of- Nothing -> Nothing- Just ( co, ty, _ ) -> Just ( co, ty )--extendFamAppCache :: TyCon -> [Type] -> (Coercion, Type) -> CtFlavour -> TcS ()-extendFamAppCache tc xi_args (co, ty) f = extendFlatCache tc xi_args (co, ty, f)--lookupFamAppInert :: TyCon -> [Type] -> TcS (Maybe (Coercion, Type, CtFlavourRole))-lookupFamAppInert tc tys = do- res <- lookupFlatCache tc tys- pure $ case res of- Nothing -> Nothing- Just ( co, ty, f ) -> Just ( co, ty, (f, NomEq) )--tcSplitForAllTyVarBinders :: Type -> ([TyVarBinder], Type)-tcSplitForAllTyVarBinders = tcSplitForAllVarBndrs--#endif+{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE BlockArguments #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE ViewPatterns #-} + +{-| +Module: GHC.TcPlugin.API.Internal.Shim + +This module defines a compatibility shim which allows +the library to support a limited form of type-family rewriting +in typechecking plugins on GHC 9.0 and 9.2. +-} + +module GHC.TcPlugin.API.Internal.Shim + ( Reduction(..), mkReduction + , TcPluginSolveResult(TcPluginContradiction, TcPluginOk, ..), TcPluginRewriteResult(..) + , RewriteEnv(..) + , shimRewriter +#if !MIN_VERSION_ghc(9,1,0) + , unflattenCts +#endif + ) + where + +-- base +import Prelude + hiding ( Floating(cos), iterate ) +import Control.Monad + ( forM, unless, when ) +import Data.Foldable + ( traverse_ +#if !MIN_VERSION_ghc(9,1,0) + , foldlM +#endif + ) +#if MIN_VERSION_ghc(9,1,0) +import Data.List.NonEmpty + ( NonEmpty((:|)) ) +#endif +import Data.Maybe + ( fromMaybe ) + +-- transformers +import Control.Monad.Trans.Reader + ( ReaderT(..) ) +import Control.Monad.Trans.State.Strict + ( StateT(..) ) + +-- ghc +import GHC.Core.Coercion + ( coercionRole + , mkReflCo, mkSymCo + , mkAppCos, mkNomReflCo, mkSubCo + , mkTyConAppCo, tyConRolesX + , tyConRolesRepresentational +#if !MIN_VERSION_ghc(9,1,0) + , CoercionHole(..), setCoHoleCoVar, coHoleCoVar +#endif + ) +import GHC.Core.Predicate + ( EqRel(..), eqRelRole ) +import GHC.Core.TyCo.Rep + ( Type(..), Kind, Coercion(..), MCoercion(..), TyCoBinder(..) + , isNamedBinder, mkTyVarTy + ) +import GHC.Core.TyCon + ( TyCon(..), TyConBinder, TyConBndrVis(..) +#if MIN_VERSION_ghc(9,1,0) + , isForgetfulSynTyCon +#endif + , isFamFreeTyCon, isTypeSynonymTyCon + , isTypeFamilyTyCon + , tyConBinders, tyConResKind + , tyConArity + ) +import GHC.Core.Type + ( TyVar + , tcView , mkTyConApp +#if MIN_VERSION_ghc(9,0,0) + , mkScaled, tymult +#endif + , coreView, tyVarKind + ) +#if MIN_VERSION_ghc(9,1,0) +import GHC.Data.Maybe + ( firstJustsM ) +#endif +import GHC.Tc.Plugin + ( newWanted, newDerived ) +import GHC.Tc.Solver.Monad + ( TcS + , zonkCo, zonkTcType + , isFilledMetaTyVar_maybe + , getInertEqs + , checkReductionDepth + , matchFam + , runTcPluginTcS, runTcSWithEvBinds + , traceTcS + , setWantedEvTerm +#if MIN_VERSION_ghc(9,1,0) + , lookupFamAppCache, lookupFamAppInert, extendFamAppCache + , pattern EqualCtList +#else + , lookupFlatCache, extendFlatCache +#endif + ) +import GHC.Tc.Types + ( TcPluginM + , unsafeTcPluginTcM, getEvBindsTcPluginM + ) +import qualified GHC.Tc.Types as GHC + ( TcPluginResult(..) ) +import GHC.Tc.Types.Constraint + ( Ct(..), CtEvidence(..) + , CtLoc, CtFlavour(..), CtFlavourRole, ShadowInfo(..) +#if MIN_VERSION_ghc(9,1,0) + , CanEqLHS(..) +#else + , QCInst(..), TcEvDest(..) +#endif + , ctLoc, ctFlavour, ctEvidence, ctEqRel, ctEvPred + , ctEvExpr, ctEvCoercion, ctEvFlavour + , bumpCtLocDepth, eqCanRewriteFR, mkNonCanonical + ) +import GHC.Tc.Types.Evidence + ( EvTerm(..), Role(..) + , evCast, mkTcTransCo , mkTcTyConAppCo + ) +import GHC.Tc.Utils.TcType + ( TcTyCoVarSet +#if MIN_VERSION_ghc(9,1,0) + , tcSplitForAllTyVarBinders +#else + , tcSplitForAllVarBndrs + + -- Unflattening + , TCvSubst(..), substTy, substTys, extendTvSubst + , emptyTCvSubst, lookupTyVar +#endif + , tcSplitTyConApp_maybe + , tcTypeKind + , tyCoVarsOfType + ) +import GHC.Types.Unique.FM + ( UniqFM, lookupUFM, isNullUFM ) +import GHC.Types.Var + ( TcTyVar, VarBndr(..) +#if !MIN_VERSION_ghc(9,1,0) + , TyVarBinder + , updateTyVarKind + , setVarType +#endif + , updateTyVarKindM + ) +import GHC.Types.Var.Env + ( lookupDVarEnv ) +import GHC.Types.Var.Set + ( emptyVarSet ) +import GHC.Utils.Misc + ( dropList ) +import GHC.Utils.Monad + ( zipWith3M ) +import GHC.Utils.Outputable + hiding ( (<>) ) + +-- ghc-tcplugin-api +import GHC.TcPlugin.API.Internal.Shim.Reduction + +-------------------------------------------------------------------------------- + +-- | The type-family rewriting environment. +data RewriteEnv + = FE { fe_loc :: !CtLoc + , fe_flavour :: !CtFlavour + , fe_eq_rel :: !EqRel + } + +-- | Result of running a solver plugin. +data TcPluginSolveResult + = TcPluginSolveResult + { -- | Insoluble constraints found by the plugin. + -- + -- These constraints will be added to the inert set, + -- and reported as insoluble to the user. + tcPluginInsolubleCts :: [Ct] + -- | Solved constraints, together with their evidence. + -- + -- These are removed from the inert set, and the + -- evidence for them is recorded. + , tcPluginSolvedCts :: [(EvTerm, Ct)] + -- | New constraints that the plugin wishes to emit. + -- + -- These will be added to the work list. + , tcPluginNewCts :: [Ct] + } + +-- | The plugin found a contradiction. +-- The returned constraints are removed from the inert set, +-- and recorded as insoluble. +-- +-- The returned list of constraints should never be empty. +pattern TcPluginContradiction :: [Ct] -> TcPluginSolveResult +pattern TcPluginContradiction insols + = TcPluginSolveResult + { tcPluginInsolubleCts = insols + , tcPluginSolvedCts = [] + , tcPluginNewCts = [] } + +-- | The plugin has not found any contradictions, +-- +-- The first field is for constraints that were solved. +-- The second field contains new work, that should be processed by +-- the constraint solver. +pattern TcPluginOk :: [(EvTerm, Ct)] -> [Ct] -> TcPluginSolveResult +pattern TcPluginOk solved new + = TcPluginSolveResult + { tcPluginInsolubleCts = [] + , tcPluginSolvedCts = solved + , tcPluginNewCts = new } + +-- The 'TcPluginSolveResult' datatype changed in GHC 9.4, +-- allowing users to return solved and new constraints even in case of +-- a contradiction. +-- +-- This function simply drops the solved and new constraints on older versions, +-- although it does at least still bind the evidence in case of solved Wanteds. +adaptSolveResult :: Bool -> TcPluginSolveResult -> TcPluginM GHC.TcPluginResult +adaptSolveResult doingGivens + ( TcPluginSolveResult + { tcPluginInsolubleCts = insols + , tcPluginSolvedCts = solved + , tcPluginNewCts = new + } + ) + | null insols + = pure $ GHC.TcPluginOk solved new + | null solved && null new + = pure $ GHC.TcPluginContradiction insols + | otherwise + = do + evBinds <- getEvBindsTcPluginM + unsafeTcPluginTcM . runTcSWithEvBinds evBinds $ do + unless doingGivens $ traverse_ ( uncurry setEv ) solved + --updInertCans (removeInertCts $ fmap snd solved) -- These don't do anything, as the inert set and work list + --emitWork new -- are confined to this run of the plugin. + pure $ GHC.TcPluginContradiction insols + where + setEv :: EvTerm -> Ct -> TcS () + setEv ev ( ctEvidence -> CtWanted { ctev_dest = dest } ) + = setWantedEvTerm dest ev + setEv _ _ + = pure () + +data TcPluginRewriteResult + = + -- | The plugin does not rewrite the type family application. + TcPluginNoRewrite + + -- | The plugin rewrites the type family application + -- providing a rewriting together with evidence. + -- + -- The plugin can also emit additional wanted constraints. + | TcPluginRewriteTo + { tcPluginReduction :: !Reduction + , tcRewriterNewWanteds :: [Ct] + } + +type Rewriter = RewriteEnv -> [Ct] -> [Type] -> TcPluginM TcPluginRewriteResult + +type Rewriters = + UniqFM +#if MIN_VERSION_ghc(9,0,0) + TyCon +#endif + Rewriter + +-- | Emulate type-family rewriting functionality in a constraint solving plugin, +-- by traversing through all the constraints and rewriting any type-family applications +-- inside them. +shimRewriter :: [Ct] -> [Ct] -> [Ct] + -> Rewriters + -> ( [Ct] -> [Ct] -> [Ct] -> TcPluginM TcPluginSolveResult ) + -> TcPluginM GHC.TcPluginResult +shimRewriter givens deriveds wanteds rws solver + | isNullUFM rws + = adaptSolveResult (null wanteds) =<< solver givens deriveds wanteds + | otherwise + = do + TcPluginSolveResult + { tcPluginInsolubleCts = contras + , tcPluginSolvedCts = solved + , tcPluginNewCts = new + } <- solver givens deriveds wanteds + ( rewrittenDeriveds, solvedDeriveds, newCts1 ) <- traverseCts ( reduceCt rws givens ) deriveds + ( rewrittenWanteds , solvedWanteds , newCts2 ) <- traverseCts ( reduceCt rws givens ) wanteds + adaptSolveResult (null wanteds) $ + TcPluginSolveResult + { tcPluginInsolubleCts = contras + , tcPluginSolvedCts = solved ++ solvedDeriveds ++ solvedWanteds + , tcPluginNewCts = new ++ newCts1 ++ rewrittenDeriveds ++ newCts2 ++ rewrittenWanteds + } + +reduceCt :: Rewriters + -> [Ct] + -> Ct + -> TcPluginM ( Maybe ( Ct, (EvTerm, Ct) ), [Ct] ) +reduceCt rws givens ct = do + let + predTy :: Type + predTy = ctEvPred ( ctEvidence ct ) + rwEnv :: RewriteEnv + rwEnv = FE ( ctLoc ct ) ( ctFlavour ct ) ( ctEqRel ct ) + shimRewriteEnv :: ShimRewriteEnv + shimRewriteEnv = ShimRewriteEnv rws rwEnv givens + ( res, newCts ) <- runRewritePluginM shimRewriteEnv ( rewrite_one predTy ) + case res of + Nothing -> pure ( Nothing, newCts ) + Just ( Reduction co predTy' ) -> do + ctEv' <- case ctFlavour ct of + Given -> error "ghc-tcplugin-api: unexpected Given in reduceCt" + Wanted {} -> newWanted ( ctLoc ct ) predTy' + Derived -> newDerived ( ctLoc ct ) predTy' + let + role :: Role + role = coercionRole co + cast_co :: Coercion + cast_co = mkSymCo $ case role of + Nominal -> mkSubCo co + _ -> co + pure ( Just + ( mkNonCanonical ctEv' + , ( evCast ( ctEvExpr ctEv' ) cast_co, ct ) + ) + , newCts + ) + +traverseCts :: Monad m + => ( a -> m ( Maybe (b, c), [d] ) ) + -> [a] + -> m ( [b], [c], [d] ) +traverseCts _ [] = pure ( [], [], [] ) +traverseCts f (a : as) = do + ( mb_bc, ds ) <- f a + ( bs, cs, dss ) <- traverseCts f as + case mb_bc of + Nothing -> pure ( bs, cs, ds ++ dss ) + Just (b,c) -> pure ( b : bs, c : cs, ds ++ dss ) + +-------------------------------------------------------------------------------- +-- The following is (mostly) copied from GHC 9.4's GHC.Tc.Solver.Rewrite module. + +rewrite_one :: Type -> RewriteM Reduction +rewrite_one ty + | Just ty' <- rewriterView ty -- See Note [Rewriting synonyms] + = rewrite_one ty' + +rewrite_one xi@(LitTy {}) + = do { role <- getRole + ; return $ mkReflRedn role xi } + +rewrite_one (TyVarTy tv) + = rewriteTyVar tv + +rewrite_one (AppTy ty1 ty2) + = rewrite_app_tys ty1 [ty2] + +rewrite_one (TyConApp tc tys) + | isTypeFamilyTyCon tc + = rewrite_fam_app tc tys + + | otherwise + = rewrite_ty_con_app tc tys + +rewrite_one + (FunTy +#if MIN_VERSION_ghc(8,10,0) + vis +#endif +#if MIN_VERSION_ghc(9,0,0) + mult +#endif + ty1 + ty2 + ) + = do { arg_redn <- rewrite_one ty1 + ; res_redn <- rewrite_one ty2 +#if MIN_VERSION_ghc(9,0,0) + ; w_redn <- setEqRel NomEq $ rewrite_one mult +#endif + ; role <- getRole + ; return $ + mkFunRedn + role +#if MIN_VERSION_ghc(8,10,0) + vis +#endif +#if MIN_VERSION_ghc(9,0,0) + w_redn +#endif + arg_redn + res_redn + } + +rewrite_one ty@(ForAllTy {}) + = do { let (bndrs, rho) = tcSplitForAllTyVarBinders ty + ; redn <- rewrite_one rho + ; return $ mkHomoForAllRedn bndrs redn } + +rewrite_one (CastTy ty g) + = do { redn <- rewrite_one ty + ; g' <- rewrite_co g + ; role <- getRole + ; return $ mkCastRedn1 role ty g' redn } + +rewrite_one (CoercionTy co) + = do { co' <- rewrite_co co + ; role <- getRole + ; return $ mkReflCoRedn role co' } + +rewrite_reduction :: Reduction -> RewriteM Reduction +rewrite_reduction (Reduction co xi) = do + redn <- bumpDepth $ rewrite_one xi + pure $ co `mkTransRedn` redn + +rewrite_app_tys :: Type -> [Type] -> RewriteM Reduction +rewrite_app_tys (AppTy ty1 ty2) tys = rewrite_app_tys ty1 (ty2:tys) +rewrite_app_tys fun_ty arg_tys + = do { redn <- rewrite_one fun_ty + ; rewrite_app_ty_args redn arg_tys } + +rewrite_app_ty_args :: Reduction -> [Type] -> RewriteM Reduction +rewrite_app_ty_args redn [] + = return redn +rewrite_app_ty_args fun_redn@(Reduction fun_co fun_xi) arg_tys + = do { het_redn <- case tcSplitTyConApp_maybe fun_xi of + Just (tc, xis) -> + do { let tc_roles = tyConRolesRepresentational tc + arg_roles = dropList xis tc_roles + ; ArgsReductions (Reductions arg_cos arg_xis) kind_co + <- rewrite_vector (tcTypeKind fun_xi) arg_roles arg_tys + + ; eq_rel <- getEqRel + ; let app_xi = mkTyConApp tc (xis ++ arg_xis) + app_co = case eq_rel of + NomEq -> mkAppCos fun_co arg_cos + ReprEq -> mkAppCos fun_co (map mkNomReflCo arg_tys) + `mkTcTransCo` + mkTcTyConAppCo Representational tc + (zipWith mkReflCo tc_roles xis ++ arg_cos) + + ; return $ + mkHetReduction + (mkReduction app_co app_xi ) + kind_co } + Nothing -> + do { ArgsReductions redns kind_co + <- rewrite_vector (tcTypeKind fun_xi) (repeat Nominal) arg_tys + ; return $ mkHetReduction (mkAppRedns fun_redn redns) kind_co } + + ; role <- getRole + ; return (homogeniseHetRedn role het_redn) } + +{-# INLINE rewrite_args_tc #-} +rewrite_args_tc :: TyCon -> Maybe [Role] -> [Type] -> RewriteM ArgsReductions +rewrite_args_tc tc = rewrite_args all_bndrs any_named_bndrs inner_ki emptyVarSet + -- NB: TyCon kinds are always closed + where + -- There are many bang patterns in here. It's been observed that they + -- greatly improve performance of an optimized build. + -- The T9872 test cases are good witnesses of this fact. + + (bndrs, named) + = ty_con_binders_ty_binders' (tyConBinders tc) + -- it's possible that the result kind has arrows (for, e.g., a type family) + -- so we must split it + (inner_bndrs, inner_ki, inner_named) = split_pi_tys' (tyConResKind tc) + !all_bndrs = bndrs `chkAppend` inner_bndrs + !any_named_bndrs = named || inner_named + -- NB: Those bangs there drop allocations in T9872{a,c,d} by 8%. + +rewrite_fam_app :: TyCon -> [Type] -> RewriteM Reduction +rewrite_fam_app tc tys = do + let (tys1, tys_rest) = splitAt (tyConArity tc) tys + redn <- rewrite_exact_fam_app tc tys1 + rewrite_app_ty_args redn tys_rest + +rewrite_exact_fam_app :: TyCon -> [Type] -> RewriteM Reduction +rewrite_exact_fam_app tc tys = do + checkStackDepth $ mkTyConApp tc tys + rws <- getRewriters + let + mbRewriter :: Maybe Rewriter + mbRewriter = lookupUFM rws tc + result1 <- try_to_reduce tc tys mbRewriter + case result1 of + Just redn -> finish False redn + _ -> do + eq_rel <- getEqRel + ArgsReductions (Reductions cos xis) kind_co <- + if eq_rel == NomEq + then rewrite_args_tc tc Nothing tys + else setEqRel NomEq $ + rewrite_args_tc tc Nothing tys + let + role = eqRelRole eq_rel + args_co = mkTyConAppCo role tc cos + homogenise :: Reduction -> Reduction + homogenise redn + = homogeniseHetRedn role + $ mkHetReduction + (args_co `mkTransRedn` redn) + kind_co + give_up :: Reduction + give_up = homogenise $ mkReflRedn role (mkTyConApp tc xis) + + result2 <- liftTcS $ lookupFamAppInert tc xis + flavour <- getFlavour + case result2 of + Just (co, xi, fr@(_, inert_eq_rel)) + | fr `eqCanRewriteFR` (flavour, eq_rel) + , let + redn :: Reduction + redn = Reduction (mkSymCoOnGHC92 co) xi + -> finish True (homogenise $ downgradeRedn role' inert_role redn) + where + inert_role = eqRelRole inert_eq_rel + role' = eqRelRole eq_rel + _ -> do + result3 <- try_to_reduce tc xis mbRewriter + case result3 of + Just redn -> finish True (homogenise redn) + _ -> return give_up + where + finish :: Bool -> Reduction -> RewriteM Reduction + finish use_cache (Reduction co xi) = do + Reduction fully_co fully <- bumpDepth $ rewrite_one xi + let final_redn@(Reduction final_co final_xi) = Reduction (co `mkTcTransCo` fully_co) fully + eq_rel <- getEqRel + flavour <- getFlavour + when (use_cache && eq_rel == NomEq && flavour /= Derived) $ + liftTcS $ + extendFamAppCache tc tys + ( mkSymCoOnGHC92 final_co, final_xi ) +#if !MIN_VERSION_ghc(9,1,0) + flavour +#endif + return final_redn + {-# INLINE finish #-} + +-- On GHC 9.2, lookupFamAppCache and matchFam +-- use a coercion that goes from right to left. +-- On GHC 9.0 (and GHC 9.4 and above), the coercions +-- always go from left to right. +-- (Recall: this module is only used for GHC 9.2 and below.) +mkSymCoOnGHC92 :: Coercion -> Coercion +mkSymCoOnGHC92 co = +#if MIN_VERSION_ghc(9,1,0) + mkSymCo co +#else + co +#endif + +-- Returned coercion is output ~r input, where r is the role in the RewriteM monad +-- See Note [How to normalise a family application] +try_to_reduce :: TyCon -> [Type] -> Maybe Rewriter + -> RewriteM (Maybe Reduction) +try_to_reduce tc tys mb_rewriter = do + result <- + firstJustsM + [ runTcPluginRewriter mb_rewriter tys + , liftTcS $ mkRed <$> lookupFamAppCache tc tys + , liftTcS $ mkRed <$> matchFam tc tys ] + forM result downgrade + where + mkRed :: Maybe (Coercion, Type) -> Maybe Reduction + mkRed = fmap $ \ (co, ty) -> Reduction (mkSymCoOnGHC92 co) ty + downgrade :: Reduction -> RewriteM Reduction + downgrade redn@(Reduction co xi) = do + eq_rel <- getEqRel + case eq_rel of + NomEq -> return redn + ReprEq -> return $ Reduction (mkSubCo co) xi + +runTcPluginRewriter :: Maybe Rewriter + -> [Type] + -> RewriteM (Maybe Reduction) +runTcPluginRewriter mbRewriter tys = + case mbRewriter of + Nothing -> return Nothing + Just rewriter -> do + traceRewriteM "runTcPluginRewriter { " empty + res <- runRewriter rewriter + traceRewriteM "runTcPluginRewriter }" ( ppr res ) + pure res + where + runRewriter :: Rewriter -> RewriteM (Maybe Reduction) + runRewriter rewriter = do + rewriteResult <- RewriteM \ env s -> do + res <- runTcPluginTcS ( rewriter ( rewriteEnv env ) ( rewriteGivens env ) tys ) + pure ( res, s ) + case rewriteResult of + TcPluginRewriteTo + { tcPluginReduction = redn + , tcRewriterNewWanteds = wanteds + } -> addRewriting ( Just redn ) wanteds + TcPluginNoRewrite { } + -> addRewriting Nothing [] + +rewrite_ty_con_app :: TyCon -> [Type] -> RewriteM Reduction +rewrite_ty_con_app tc tys + = do { role <- getRole + ; let m_roles | Nominal <- role = Nothing + | otherwise = Just $ tyConRolesX role tc + ; ArgsReductions redns kind_co <- rewrite_args_tc tc m_roles tys + ; let tyconapp_redn + = mkHetReduction + (mkTyConAppRedn role tc redns) + kind_co + ; return $ homogeniseHetRedn role tyconapp_redn } + +rewrite_co :: Coercion -> RewriteM Coercion +rewrite_co co = liftTcS $ zonkCo co + +rewriterView :: Type -> Maybe Type +rewriterView ty@(TyConApp tc _) + | ( isTypeSynonymTyCon tc && not (isFamFreeTyCon tc) ) +#if MIN_VERSION_ghc(9,1,0) + || isForgetfulSynTyCon tc +#endif + = tcView ty +rewriterView _other = Nothing + +rewriteTyVar :: TyVar -> RewriteM Reduction +rewriteTyVar tv = do + mb_yes <- rewrite_tyvar1 tv + case mb_yes of + RTRFollowed redn -> rewrite_reduction redn + RTRNotFollowed -> do + tv' <- liftTcS $ updateTyVarKindM zonkTcType tv + role <- getRole + let ty' = mkTyVarTy tv' + pure $ mkReflRedn role ty' + +data RewriteTvResult + = RTRNotFollowed + | RTRFollowed !Reduction + +rewrite_tyvar1 :: TcTyVar -> RewriteM RewriteTvResult +rewrite_tyvar1 tv = do + mb_ty <- liftTcS $ isFilledMetaTyVar_maybe tv + case mb_ty of + Just ty -> do + role <- getRole + return $ RTRFollowed $ mkReflRedn role ty + Nothing -> do + fr <- getFlavourRole + rewrite_tyvar2 tv fr + +rewrite_tyvar2 :: TcTyVar -> CtFlavourRole -> RewriteM RewriteTvResult +rewrite_tyvar2 tv fr@(_, eq_rel) = do + ieqs <- liftTcS $ getInertEqs + case lookupDVarEnv ieqs tv of +#if MIN_VERSION_ghc(9,1,0) + Just (EqualCtList (ct :| _)) + | CEqCan { cc_ev = ctev, cc_lhs = TyVarLHS {} + , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct +#else + Just (ct : _) + | CTyEqCan { cc_ev = ctev + , cc_rhs = rhs_ty, cc_eq_rel = ct_eq_rel } <- ct +#endif + , let ct_fr = (ctEvFlavour ctev, ct_eq_rel) + , ct_fr `eqCanRewriteFR` fr + -> do + let rewriting_co1 = ctEvCoercion ctev + rewriting_co = case (ct_eq_rel, eq_rel) of + (ReprEq, _rel) -> rewriting_co1 + (NomEq, NomEq) -> rewriting_co1 + (NomEq, ReprEq) -> mkSubCo rewriting_co1 + return $ RTRFollowed $ mkReduction rewriting_co rhs_ty + _other -> return RTRNotFollowed + +rewrite_vector :: Kind + -> [Role] + -> [Type] + -> RewriteM ArgsReductions +rewrite_vector ki roles tys + = do { eq_rel <- getEqRel + ; let mb_roles = case eq_rel of { NomEq -> Nothing; ReprEq -> Just roles } + ; rewrite_args bndrs any_named_bndrs inner_ki fvs mb_roles tys + } + where + (bndrs, inner_ki, any_named_bndrs) = split_pi_tys' ki + fvs = tyCoVarsOfType ki +{-# INLINE rewrite_vector #-} + +split_pi_tys' :: Type -> ([TyCoBinder], Type, Bool) +split_pi_tys' ty = split ty ty + where + split _ (ForAllTy b res) = + let !(bs, ty', _) = split res res + in (Named b : bs, ty', True) + split _ + (FunTy +#if MIN_VERSION_ghc(8,10,0) + af +#endif +#if MIN_VERSION_ghc(9,0,0) + w +#endif + 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 + arg +#endif + : bs + , ty', named + ) + split orig_ty ty' | Just ty'' <- coreView ty' = split orig_ty ty'' + split orig_ty _ = ([], orig_ty, False) +{-# INLINE split_pi_tys' #-} + +ty_con_binders_ty_binders' :: [TyConBinder] -> ([TyCoBinder], Bool) +ty_con_binders_ty_binders' = foldr go ([], False) + where + go (Bndr tv (NamedTCB vis)) (bndrs, _) + = (Named (Bndr tv vis) : bndrs, True) + 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 +#endif + (tyVarKind tv) + ) + : bndrs + , n) + {-# INLINE go #-} +{-# INLINE ty_con_binders_ty_binders' #-} + +{-# INLINE rewrite_args #-} +rewrite_args :: [TyCoBinder] -> Bool + -> Kind -> TcTyCoVarSet + -> Maybe [Role] -> [Type] + -> RewriteM ArgsReductions +rewrite_args orig_binders + any_named_bndrs + orig_inner_ki + orig_fvs + orig_m_roles + orig_tys + = case (orig_m_roles, any_named_bndrs) of + (Nothing, False) -> rewrite_args_fast orig_tys + _ -> rewrite_args_slow orig_binders orig_inner_ki orig_fvs orig_roles orig_tys + where orig_roles = fromMaybe (repeat Nominal) orig_m_roles + +{-# INLINE rewrite_args_fast #-} +rewrite_args_fast :: [Type] -> RewriteM ArgsReductions +rewrite_args_fast orig_tys + = fmap finish (iterate orig_tys) + where + + iterate :: [Type] -> RewriteM Reductions + iterate (ty : tys) = do + Reduction co xi <- rewrite_one ty + Reductions cos xis <- iterate tys + pure $ Reductions (co : cos) (xi : xis) + iterate [] = pure $ Reductions [] [] + + {-# INLINE finish #-} + finish :: Reductions -> ArgsReductions + finish redns = ArgsReductions redns MRefl + +{-# INLINE rewrite_args_slow #-} +rewrite_args_slow :: [TyCoBinder] -> Kind -> TcTyCoVarSet + -> [Role] -> [Type] + -> RewriteM ArgsReductions +rewrite_args_slow binders inner_ki fvs roles tys + = do { rewritten_args <- zipWith3M fl (map isNamedBinder binders ++ repeat True) + roles tys + ; return $ simplifyArgsWorker binders inner_ki fvs roles rewritten_args } + where + {-# INLINE fl #-} + fl :: Bool -- must we ensure to produce a real coercion here? + -- see comment at top of function + -> Role -> Type -> RewriteM Reduction + fl True r ty = noBogusCoercions $ fl1 r ty + fl False r ty = fl1 r ty + + {-# INLINE fl1 #-} + fl1 :: Role -> Type -> RewriteM Reduction + fl1 Nominal ty + = setEqRel NomEq $ + rewrite_one ty + + fl1 Representational ty + = setEqRel ReprEq $ + rewrite_one ty + + fl1 Phantom ty + = do { ty' <- liftTcS $ zonkTcType ty + ; return $ mkReflRedn Phantom ty' } + +noBogusCoercions :: RewriteM a -> RewriteM a +noBogusCoercions thing_inside + = RewriteM \ env s -> + let !renv = rewriteEnv env + !renv' = case fe_flavour renv of + Derived -> renv { fe_flavour = Wanted WDeriv } + _ -> renv + !env' = env { rewriteEnv = renv' } + in + runRewriteM thing_inside env' s + +chkAppend :: [a] -> [a] -> [a] +chkAppend xs ys + | null ys = xs + | otherwise = xs ++ ys + +-------------------------------------------------------------------------------- + +data ReduceQ = NoReduction | DidReduce +instance Semigroup ReduceQ where + NoReduction <> NoReduction = NoReduction + _ <> _ = DidReduce +instance Monoid ReduceQ where + mempty = NoReduction + +data RewriteState = + RewriteState + { rewrittenCts :: ![ Ct ] + , reductionOccurred :: !ReduceQ + } + +data ShimRewriteEnv + = ShimRewriteEnv + { rewriters :: !Rewriters + , rewriteEnv :: !RewriteEnv + , rewriteGivens :: ![ Ct ] + } + +newtype RewriteM a + = RewriteM + { runRewriteM + :: ShimRewriteEnv + -> RewriteState + -> TcS ( a, RewriteState ) + } + deriving ( Functor, Applicative, Monad ) + via ( ReaderT ShimRewriteEnv + ( StateT RewriteState TcS ) + ) + +runRewritePluginM :: ShimRewriteEnv + -> RewriteM a + -> TcPluginM ( Maybe a, [Ct] ) +runRewritePluginM env ( RewriteM { runRewriteM = run } ) = do + + evBindsVar <- getEvBindsTcPluginM + ( a, RewriteState { rewrittenCts, reductionOccurred } ) + <- unsafeTcPluginTcM + $ runTcSWithEvBinds evBindsVar + $ run env ( RewriteState [] NoReduction ) + let + mb_a = case reductionOccurred of + NoReduction -> Nothing + DidReduce -> Just a + pure ( mb_a, rewrittenCts ) + +addRewriting :: Maybe Reduction -> [Ct] -> RewriteM ( Maybe Reduction ) +addRewriting mbRedn newCts = RewriteM \ _ ( RewriteState cts s ) -> + let + s' :: ReduceQ + s' + | Just _ <- mbRedn + = DidReduce + | otherwise + = s + in pure ( mbRedn , RewriteState ( cts <> newCts ) s' ) + +getRewriters :: RewriteM Rewriters +getRewriters = RewriteM \ env s -> pure ( rewriters env, s ) + +getRewriteEnvField :: (RewriteEnv -> a) -> RewriteM a +getRewriteEnvField accessor = RewriteM \ env s -> + pure ( accessor ( rewriteEnv env ), s ) + +getEqRel :: RewriteM EqRel +getEqRel = getRewriteEnvField fe_eq_rel + +getRole :: RewriteM Role +getRole = eqRelRole <$> getEqRel + +getFlavour :: RewriteM CtFlavour +getFlavour = getRewriteEnvField fe_flavour + +getFlavourRole :: RewriteM CtFlavourRole +getFlavourRole = do + flavour <- getFlavour + eq_rel <- getEqRel + return (flavour, eq_rel) + +setEqRel :: EqRel -> RewriteM a -> RewriteM a +setEqRel new_eq_rel thing_inside = RewriteM \ env s -> + if new_eq_rel == fe_eq_rel ( rewriteEnv env ) + then runRewriteM thing_inside env s + else runRewriteM thing_inside ( setEqRel' env ) s + where + setEqRel' :: ShimRewriteEnv -> ShimRewriteEnv + setEqRel' env = env { rewriteEnv = ( rewriteEnv env ) { fe_eq_rel = new_eq_rel } } +{-# INLINE setEqRel #-} + +liftTcS :: TcS a -> RewriteM a +liftTcS thing_inside = RewriteM \ _env s -> do + a <- thing_inside + pure ( a, s ) + +traceRewriteM :: String -> SDoc -> RewriteM () +traceRewriteM herald doc = liftTcS $ traceTcS herald doc +{-# INLINE traceRewriteM #-} + +getLoc :: RewriteM CtLoc +getLoc = getRewriteEnvField fe_loc + +checkStackDepth :: Type -> RewriteM () +checkStackDepth ty = do + loc <- getLoc + liftTcS $ checkReductionDepth loc ty + +bumpDepth :: RewriteM a -> RewriteM a +bumpDepth (RewriteM thing_inside) = RewriteM \ env s -> do + let !renv = rewriteEnv env + !renv' = renv { fe_loc = bumpCtLocDepth ( fe_loc renv ) } + !env' = env { rewriteEnv = renv' } + thing_inside env' s + +#if !MIN_VERSION_ghc(9,1,0) +-------------------------------------------------------------------------------- +-- GHC 9.0 compatibility. + +firstJustsM :: (Monad m, Foldable f) => f (m (Maybe a)) -> m (Maybe a) +firstJustsM = foldlM go Nothing where + go :: Monad m => Maybe a -> m (Maybe a) -> m (Maybe a) + go Nothing action = action + go result@(Just _) _action = return result + +lookupFamAppCache :: TyCon -> [Type] -> TcS (Maybe (Coercion, Type)) +lookupFamAppCache fam_tc tys = do + res <- lookupFlatCache fam_tc tys + pure $ case res of + Nothing -> Nothing + Just ( co, ty, _ ) -> Just ( co, ty ) + +extendFamAppCache :: TyCon -> [Type] -> (Coercion, Type) -> CtFlavour -> TcS () +extendFamAppCache tc xi_args (co, ty) f = extendFlatCache tc xi_args (co, ty, f) + +lookupFamAppInert :: TyCon -> [Type] -> TcS (Maybe (Coercion, Type, CtFlavourRole)) +lookupFamAppInert tc tys = do + res <- lookupFlatCache tc tys + pure $ case res of + Nothing -> Nothing + Just ( co, ty, f ) -> Just ( co, ty, (f, NomEq) ) + +tcSplitForAllTyVarBinders :: Type -> ([TyVarBinder], Type) +tcSplitForAllTyVarBinders = tcSplitForAllVarBndrs + +#endif + +-------------------------------------------------------------------------------- +-- Unflattening constraints + +#if !MIN_VERSION_ghc(9,1,0) +unflattenCts :: [ Ct ] -> [ Ct ] -> [ Ct ] -> ( [ Ct ], [ Ct ], [ Ct ] ) +unflattenCts givens0 deriveds0 wanteds0 = + -- NB: on all GHC versions we support (GHC >= 8.8), + -- GHC passes zonked constraints to typechecker plugins. + -- So there's no need for us to zonk anything. + let ( subst, givens ) = add_fsks emptyTCvSubst [] givens0 + deriveds = substCts subst deriveds0 + wanteds = substCts subst wanteds0 + + in + ( givens, deriveds, wanteds ) + +-- Construct an unflattening substitution from Givens of the form +-- +-- [G] fsk ~ rhs +-- +-- and filter them out. +add_fsks :: TCvSubst -> [ Ct ] -> [ Ct ] -> ( TCvSubst, [ Ct ] ) +add_fsks subst rev_acc [] = ( subst, substCts subst $ reverse rev_acc ) +add_fsks subst rev_acc ( ct : cts ) = + case ct of + CFunEqCan { cc_fsk, cc_fun, cc_tyargs } -> + let subst' = extendSubst subst cc_fsk $ mkTyConApp cc_fun cc_tyargs + in add_fsks subst' rev_acc cts + _ -> add_fsks subst ( ct : rev_acc ) cts + +extendSubst :: TCvSubst -> TyVar -> Type -> TCvSubst +extendSubst subst@( TCvSubst in_scope tv_env cv_env ) tv ty = + -- Keep the substitution idempotent + let ty' = substTy subst ty + tv_subst = extendTvSubst emptyTCvSubst tv ty' + subst' = TCvSubst in_scope ( fmap ( substTy tv_subst ) tv_env ) cv_env + in extendTvSubst subst' tv ty' + +substCts :: TCvSubst -> [ Ct ] -> [ Ct ] +substCts subst = map $ substCt subst + +substCt :: TCvSubst -> Ct -> Ct +substCt subst ct = + case ct of + CIrredCan { cc_ev } -> + ct { cc_ev = substCtEv subst cc_ev } + CNonCanonical { cc_ev } -> + ct { cc_ev = substCtEv subst cc_ev } + CDictCan { cc_ev, cc_tyargs } -> + ct { cc_ev = substCtEv subst cc_ev + , cc_tyargs = substTys subst cc_tyargs + } + CFunEqCan {} -> + pprPanic "substCt: CFunEqCan" (ppr ct) + CTyEqCan { cc_ev, cc_tyvar, cc_rhs } -> + let ev' = substCtEv subst cc_ev + rhs' = substTy subst cc_rhs + in + case lookupTyVar subst cc_tyvar of + Nothing -> + ct { cc_ev = ev' + , cc_tyvar = updateTyVarKind ( substTy subst ) cc_tyvar + , cc_rhs = rhs' + } + Just ty' -> + case ty' of + TyVarTy tv' -> + ct { cc_ev = ev' + , cc_tyvar = tv' + , cc_rhs = rhs' + } + _ -> + CNonCanonical { cc_ev = ev' } + CQuantCan qci@( QCI { qci_ev, qci_tvs, qci_pred } ) -> + CQuantCan $ + qci { qci_ev = substCtEv subst qci_ev + , qci_tvs = map ( updateTyVarKind $ substTy subst ) qci_tvs + , qci_pred = substTy subst qci_pred + } +#if !MIN_VERSION_ghc(8,11,0) + CHoleCan { cc_ev } -> + let ev' = substCtEv subst cc_ev + in ct { cc_ev = ev' } +#endif + +substCtEv :: TCvSubst -> CtEvidence -> CtEvidence +substCtEv subst ctev = + setCtEvPredType ctev ( substTy subst ( ctev_pred ctev ) ) + +setCtEvPredType :: CtEvidence -> Type -> CtEvidence +setCtEvPredType old_ev@(CtGiven { ctev_evar = ev }) new_pred + = old_ev { ctev_pred = new_pred + , ctev_evar = setVarType ev new_pred } + +setCtEvPredType old_ev@(CtWanted { ctev_dest = dest }) new_pred + = old_ev { ctev_pred = new_pred + , ctev_dest = new_dest } + where + new_dest = case dest of + EvVarDest ev -> EvVarDest (setVarType ev new_pred) + HoleDest h -> HoleDest (setCoHoleType h new_pred) +setCtEvPredType old_ev@( CtDerived {} ) new_pred + = old_ev { ctev_pred = new_pred } + +setCoHoleType :: CoercionHole -> Type -> CoercionHole +setCoHoleType h t = setCoHoleCoVar h (setVarType (coHoleCoVar h) t) + +#endif
src/GHC/TcPlugin/API/Internal/Shim/Reduction.hs view
@@ -1,604 +1,604 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-}--module GHC.TcPlugin.API.Internal.Shim.Reduction where---- base-import Prelude- hiding (Floating(cos))---- ghc-import GHC.Core.Class- ( Class(classTyCon) )-import GHC.Core.Coercion- ( Coercion, CoercionN, MCoercion(..)- , Role(Nominal), LiftingContext-#if MIN_VERSION_ghc(9,0,0)- , castCoercionKind1, castCoercionKind2- , coercionLKind, coercionRKind-#else- , mkCoherenceLeftCo, mkNomReflCo-#endif- , coercionKind-#if MIN_VERSION_ghc(8,10,0)- , coToMCo-#else- , isReflCo-#endif- , decomposePiCos, downgradeRole- , liftCoSubst, emptyLiftingContext, extendLiftingContextAndInScope, zapLiftingContext- , mkAppCo, mkAppCos- , mkCoherenceRightCo- , mkForAllCo, mkFunCo- , mkGReflLeftCo, mkGReflRightCo- , mkHomoForAllCos, mkProofIrrelCo- , mkReflCo, mkSubCo, mkSymCo, mkTransCo, mkTyConAppCo- )-import GHC.Core.Predicate- ( mkClassPred )-import GHC.Core.TyCo.Rep- ( TyCoBinder, mkFunTy-#if !MIN_VERSION_ghc(9,0,0)- , Coercion(..)-#endif- )-import GHC.Core.TyCon- ( TyCon )-import GHC.Core.Type- ( ArgFlag, Kind, Type, TyVar, TyVarBinder-#if MIN_VERSION_ghc(8,10,0)- , AnonArgFlag-#endif- , binderVars- , mkAppTy, mkAppTys, mkCastTy, mkCoercionTy, mkForAllTy, mkForAllTys- , mkTyConApp, mkPiTys- , noFreeVarsOfType- , splitPiTys, tyCoBinderType, tyCoBinderVar_maybe- )-import GHC.Data.Pair- ( Pair(Pair) )-import GHC.Types.Var- ( setTyVarKind )-import GHC.Types.Var.Env- ( mkInScopeSet )-import GHC.Types.Var.Set- ( TyCoVarSet )-import GHC.Utils.Outputable- ( Outputable(ppr), (<+>)- , braces, text, vcat- )--------------------------------------------------------------------------------------- | A 'Reduction' is the result of an operation that rewrites a type @ty_in@.--- The 'Reduction' includes the rewritten type @ty_out@ and a 'Coercion' @co@--- such that @co :: ty_in ~ ty_out@, where the role of the coercion is determined--- by the context. That is, the LHS type of the coercion is the original type--- @ty_in@, while its RHS type is the rewritten type @ty_out@.------ A Reduction is always homogeneous, unless it is wrapped inside a 'HetReduction',--- which separately stores the kind coercion.-data Reduction =- Reduction- { reductionCoercion :: Coercion- , reductionReducedType :: !Type- }---- | Stores a heterogeneous reduction.------ The stored kind coercion must relate the kinds of the--- stored reduction. That is, in @HetReduction (Reduction co xi) kco@,--- we must have:------ > co :: ty ~ xi--- > kco :: typeKind ty ~ typeKind xi-data HetReduction =- HetReduction- Reduction- MCoercion---- | Create a heterogeneous reduction.------ Pre-condition: the provided kind coercion (second argument)--- relates the kinds of the stored reduction.--- That is, if the coercion stored in the 'Reduction' is of the form------ > co :: ty ~ xi------ Then the kind coercion supplied must be of the form:------ > kco :: typeKind ty ~ typeKind xi-mkHetReduction :: Reduction -- ^ heterogeneous reduction- -> MCoercion -- ^ kind coercion- -> HetReduction-mkHetReduction redn mco = HetReduction redn mco-{-# INLINE mkHetReduction #-}---- | Homogenise a heterogeneous reduction.------ Given @HetReduction (Reduction co xi) kco@, with------ > co :: ty ~ xi--- > kco :: typeKind(ty) ~ typeKind(xi)------ this returns the homogeneous reduction:------ > hco :: ty ~ ( xi |> sym kco )-homogeniseHetRedn :: Role -> HetReduction -> Reduction-homogeniseHetRedn role (HetReduction redn kco)- = mkCoherenceRightMRedn role redn (mkSymMCo kco)-{-# INLINE homogeniseHetRedn #-}---- | Create a 'Reduction' from a pair of a 'Coercion' and a 'Type.------ Pre-condition: the RHS type of the coercion matches the provided type--- (perhaps up to zonking).------ Use 'coercionRedn' when you only have the coercion.-mkReduction :: Coercion -> Type -> Reduction-mkReduction co ty = Reduction co ty-{-# INLINE mkReduction #-}--instance Outputable Reduction where- ppr redn =- braces $ vcat- [ text "reductionOriginalType:" <+> ppr (reductionOriginalType redn)- , text " reductionReducedType:" <+> ppr (reductionReducedType redn)- , text " reductionCoercion:" <+> ppr (reductionCoercion redn)- ]---- | A 'Reduction' in which the 'Coercion' has 'Nominal' role.-type ReductionN = Reduction---- | A 'Reduction' in which the 'Coercion' has 'Representational' role.-type ReductionR = Reduction---- | Get the original, unreduced type corresponding to a 'Reduction'.------ This is obtained by computing the LHS kind of the stored coercion,--- which may be slow.-reductionOriginalType :: Reduction -> Type-reductionOriginalType = coercionLKind . reductionCoercion-{-# INLINE reductionOriginalType #-}---- | Turn a 'Coercion' into a 'Reduction'--- by inspecting the RHS type of the coercion.------ Prefer using 'mkReduction' when you already know--- the RHS type of the coercion, to avoid computing it anew.-coercionRedn :: Coercion -> Reduction-coercionRedn co = Reduction co (coercionRKind co)-{-# INLINE coercionRedn #-}---- | Downgrade the role of the coercion stored in the 'Reduction'.-downgradeRedn :: Role -- ^ desired role- -> Role -- ^ current role- -> Reduction- -> Reduction-downgradeRedn new_role old_role redn@(Reduction co _)- = redn { reductionCoercion = downgradeRole new_role old_role co }-{-# INLINE downgradeRedn #-}---- | Downgrade the role of the coercion stored in the 'Reduction',--- from 'Nominal' to 'Representational'.-mkSubRedn :: Reduction -> Reduction-mkSubRedn redn@(Reduction co _) = redn { reductionCoercion = mkSubCo co }-{-# INLINE mkSubRedn #-}---- | Compose a reduction with a coercion on the left.------ Pre-condition: the provided coercion's RHS type must match the LHS type--- of the coercion that is stored in the reduction.-mkTransRedn :: Coercion -> Reduction -> Reduction-mkTransRedn co1 redn@(Reduction co2 _)- = redn { reductionCoercion = co1 `mkTransCo` co2 }-{-# INLINE mkTransRedn #-}---- | The reflexive reduction.-mkReflRedn :: Role -> Type -> Reduction-mkReflRedn r ty = mkReduction (mkReflCo r ty) ty---- | Create a 'Reduction' from a kind cast, in which--- the casted type is the rewritten type.------ Given @ty :: k1@, @mco :: k1 ~ k2@,--- produces the 'Reduction' @ty ~res_co~> (ty |> mco)@--- at the given 'Role'.-mkGReflRightRedn :: Role -> Type -> CoercionN -> Reduction-mkGReflRightRedn role ty co- = mkReduction- (mkGReflRightCo role ty co)- (mkCastTy ty co)-{-# INLINE mkGReflRightRedn #-}---- | Create a 'Reduction' from a kind cast, in which--- the casted type is the rewritten type.------ Given @ty :: k1@, @mco :: k1 ~ k2@,--- produces the 'Reduction' @ty ~res_co~> (ty |> mco)@--- at the given 'Role'.-mkGReflRightMRedn :: Role -> Type -> MCoercion -> Reduction-mkGReflRightMRedn role ty mco- = mkReduction- (mkGReflRightMCo role ty mco)- (mkCastTyMCo ty mco)-{-# INLINE mkGReflRightMRedn #-}---- | Create a 'Reduction' from a kind cast, in which--- the casted type is the original (non-rewritten) type.------ Given @ty :: k1@, @mco :: k1 ~ k2@,--- produces the 'Reduction' @(ty |> mco) ~res_co~> ty@--- at the given 'Role'.-mkGReflLeftRedn :: Role -> Type -> CoercionN -> Reduction-mkGReflLeftRedn role ty co- = mkReduction- (mkGReflLeftCo role ty co)- ty-{-# INLINE mkGReflLeftRedn #-}---- | Create a 'Reduction' from a kind cast, in which--- the casted type is the original (non-rewritten) type.------ Given @ty :: k1@, @mco :: k1 ~ k2@,--- produces the 'Reduction' @(ty |> mco) ~res_co~> ty@--- at the given 'Role'.-mkGReflLeftMRedn :: Role -> Type -> MCoercion -> Reduction-mkGReflLeftMRedn role ty mco- = mkReduction- (mkGReflLeftMCo role ty mco)- ty-{-# INLINE mkGReflLeftMRedn #-}---- | Apply a cast to the result of a 'Reduction'.------ Given a 'Reduction' @ty1 ~co1~> (ty2 :: k2)@ and a kind coercion @kco@--- with LHS kind @k2@, produce a new 'Reduction' @ty1 ~co2~> ( ty2 |> kco )@--- of the given 'Role' (which must match the role of the coercion stored--- in the 'Reduction' argument).-mkCoherenceRightRedn :: Role -> Reduction -> CoercionN -> Reduction-mkCoherenceRightRedn r (Reduction co1 ty2) kco- = mkReduction- (mkCoherenceRightCo r ty2 kco co1)- (mkCastTy ty2 kco)-{-# INLINE mkCoherenceRightRedn #-}---- | Apply a cast to the result of a 'Reduction', using an 'MCoercionN'.------ Given a 'Reduction' @ty1 ~co1~> (ty2 :: k2)@ and a kind coercion @mco@--- with LHS kind @k2@, produce a new 'Reduction' @ty1 ~co2~> ( ty2 |> mco )@--- of the given 'Role' (which must match the role of the coercion stored--- in the 'Reduction' argument).-mkCoherenceRightMRedn :: Role -> Reduction -> MCoercion -> Reduction-mkCoherenceRightMRedn r (Reduction co1 ty2) kco- = mkReduction- (mkCoherenceRightMCo r ty2 kco co1)- (mkCastTyMCo ty2 kco)-{-# INLINE mkCoherenceRightMRedn #-}---- | Apply a cast to a 'Reduction', casting both the original and the reduced type.------ Given @cast_co@ and 'Reduction' @ty ~co~> xi@, this function returns--- the 'Reduction' @(ty |> cast_co) ~return_co~> (xi |> cast_co)@--- of the given 'Role' (which must match the role of the coercion stored--- in the 'Reduction' argument).------ Pre-condition: the 'Type' passed in is the same as the LHS type--- of the coercion stored in the 'Reduction'.-mkCastRedn1 :: Role- -> Type -- ^ original type- -> CoercionN -- ^ coercion to cast with- -> Reduction -- ^ rewritten type, with rewriting coercion- -> Reduction-mkCastRedn1 r ty cast_co (Reduction co xi)- -- co :: ty ~r ty'- -- return_co :: (ty |> cast_co) ~r (ty' |> cast_co)- = mkReduction- (castCoercionKind1 co r ty xi cast_co)- (mkCastTy xi cast_co)-{-# INLINE mkCastRedn1 #-}---- | Apply casts on both sides of a 'Reduction' (of the given 'Role').------ Use 'mkCastRedn1' when you want to cast both the original and reduced types--- in a 'Reduction' using the same coercion.------ Pre-condition: the 'Type' passed in is the same as the LHS type--- of the coercion stored in the 'Reduction'.-mkCastRedn2 :: Role- -> Type -- ^ original type- -> CoercionN -- ^ coercion to cast with on the left- -> Reduction -- ^ rewritten type, with rewriting coercion- -> CoercionN -- ^ coercion to cast with on the right- -> Reduction-mkCastRedn2 r ty cast_co (Reduction nco nty) cast_co'- = mkReduction- (castCoercionKind2 nco r ty nty cast_co cast_co')- (mkCastTy nty cast_co')-{-# INLINE mkCastRedn2 #-}---- | Apply one 'Reduction' to another.------ Combines 'mkAppCo' and 'mkAppTy`.-mkAppRedn :: Reduction -> Reduction -> Reduction-mkAppRedn (Reduction co1 ty1) (Reduction co2 ty2)- = mkReduction (mkAppCo co1 co2) (mkAppTy ty1 ty2)-{-# INLINE mkAppRedn #-}---- | Create a function 'Reduction'.------ 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-#if MIN_VERSION_ghc(8,10,0)- vis-#endif-#if MIN_VERSION_ghc(9,0,0)- (Reduction w_co w_ty)-#endif- (Reduction arg_co arg_ty)- (Reduction res_co res_ty)- = mkReduction- ( mkFunCo- r-#if MIN_VERSION_ghc(9,0,0)- w_co-#endif- arg_co- res_co- )- ( mkFunTy-#if MIN_VERSION_ghc(8,10,0)- vis-#endif-#if MIN_VERSION_ghc(9,0,0)- w_ty-#endif- arg_ty- res_ty- )-{-# INLINE mkFunRedn #-}---- | Create a 'Reduction' associated to a Π type,--- from a kind 'Reduction' and a body 'Reduction'.------ Combines 'mkForAllCo' and 'mkForAllTy'.-mkForAllRedn :: ArgFlag- -> TyVar- -> ReductionN -- ^ kind reduction- -> Reduction -- ^ body reduction- -> Reduction-mkForAllRedn vis tv1 (Reduction h ki') (Reduction co ty)- = mkReduction- (mkForAllCo tv1 h co)- (mkForAllTy tv2 vis ty)- where- tv2 = setTyVarKind tv1 ki'-{-# INLINE mkForAllRedn #-}---- | Create a 'Reduction' of a quantified type from a--- 'Reduction' of the body.------ Combines 'mkHomoForAllCos' and 'mkForAllTys'.-mkHomoForAllRedn :: [TyVarBinder] -> Reduction -> Reduction-mkHomoForAllRedn bndrs (Reduction co ty)- = mkReduction- (mkHomoForAllCos (binderVars bndrs) co)- (mkForAllTys bndrs ty)-{-# INLINE mkHomoForAllRedn #-}---- | Create a 'Reduction' from a coercion between coercions.------ Combines 'mkProofIrrelCo' and 'mkCoercionTy'.-mkProofIrrelRedn :: Role -- ^ role of the created coercion, "r"- -> CoercionN -- ^ co :: phi1 ~N phi2- -> Coercion -- ^ g1 :: phi1- -> Coercion -- ^ g2 :: phi2- -> Reduction -- ^ res_co :: g1 ~r g2-mkProofIrrelRedn role co g1 g2- = mkReduction- (mkProofIrrelCo role co g1 g2)- (mkCoercionTy g2)-{-# INLINE mkProofIrrelRedn #-}---- | Create a reflexive 'Reduction' whose RHS is the given 'Coercion',--- with the specified 'Role'.-mkReflCoRedn :: Role -> Coercion -> Reduction-mkReflCoRedn role co- = mkReduction- (mkReflCo role co_ty)- co_ty- where- co_ty = mkCoercionTy co-{-# INLINE mkReflCoRedn #-}---- | A collection of 'Reduction's where the coercions and the types are stored separately.------ Use 'unzipRedns' to obtain 'Reductions' from a list of 'Reduction's.------ This datatype is used in 'mkAppRedns', 'mkClassPredRedns' and 'mkTyConAppRedn',--- which expect separate types and coercions.------ Invariant: the two stored lists are of the same length,--- and the RHS type of each coercion is the corresponding type.-data Reductions = Reductions [Coercion] [Type]---- | Create 'Reductions' from individual lists of coercions and types.------ The lists should be of the same length, and the RHS type of each coercion--- should match the specified type in the other list.-mkReductions :: [Coercion] -> [Type] -> Reductions-mkReductions cos tys = Reductions cos tys-{-# INLINE mkReductions #-}---- | Combines 'mkAppCos' and 'mkAppTys'.-mkAppRedns :: Reduction -> Reductions -> Reduction-mkAppRedns (Reduction co ty) (Reductions cos tys)- = mkReduction (mkAppCos co cos) (mkAppTys ty tys)-{-# INLINE mkAppRedns #-}---- | 'TyConAppCo' for 'Reduction's: combines 'mkTyConAppCo' and `mkTyConApp`.-mkTyConAppRedn :: Role -> TyCon -> Reductions -> Reduction-mkTyConAppRedn role tc (Reductions cos tys)- = mkReduction (mkTyConAppCo role tc cos) (mkTyConApp tc tys)-{-# INLINE mkTyConAppRedn #-}---- | Reduce the arguments of a 'Class' 'TyCon'.-mkClassPredRedn :: Class -> Reductions -> Reduction-mkClassPredRedn cls (Reductions cos tys)- = mkReduction- (mkTyConAppCo Nominal (classTyCon cls) cos)- (mkClassPred cls tys)-{-# INLINE mkClassPredRedn #-}---- | Obtain 'Reductions' from a list of 'Reduction's by unzipping.-unzipRedns :: [Reduction] -> Reductions-unzipRedns = foldr accRedn (Reductions [] [])- where- accRedn :: Reduction -> Reductions -> Reductions- accRedn (Reduction co xi) (Reductions cos xis)- = Reductions (co:cos) (xi:xis)-{-# INLINE unzipRedns #-}------------------------------------------------------------------------------------data ArgsReductions =- ArgsReductions- {-# UNPACK #-} !Reductions- !MCoercion--{-# INLINE simplifyArgsWorker #-}-simplifyArgsWorker :: [TyCoBinder] -> Kind -> TyCoVarSet -> [Role] -> [Reduction] -> ArgsReductions-simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs- orig_roles orig_simplified_args- = go orig_lc- orig_ki_binders orig_inner_ki- orig_roles orig_simplified_args- where- orig_lc = emptyLiftingContext $ mkInScopeSet $ orig_fvs-- go :: LiftingContext -> [TyCoBinder] -> Kind -> [Role] -> [Reduction] -> ArgsReductions- go !lc binders inner_ki _ []- = ArgsReductions- (mkReductions [] [])- kind_co- where- final_kind = mkPiTys binders inner_ki- kind_co | noFreeVarsOfType final_kind = MRefl- | otherwise = MCo $ liftCoSubst Nominal lc final_kind-- go lc (binder:binders) inner_ki (role:roles) (arg_redn:arg_redns)- = let !kind_co = liftCoSubst Nominal lc (tyCoBinderType binder)- !(Reduction casted_co casted_xi)- = mkCoherenceRightRedn role arg_redn kind_co- -- now, extend the lifting context with the new binding- !new_lc | Just tv <- tyCoBinderVar_maybe binder- = extendLiftingContextAndInScope lc tv casted_co- | otherwise- = lc- !(ArgsReductions (Reductions cos xis) final_kind_co)- = go new_lc binders inner_ki roles arg_redns- in ArgsReductions- (Reductions (casted_co:cos) (casted_xi:xis))- final_kind_co-- -- See Note [Last case in simplifyArgsWorker]- go lc [] inner_ki roles arg_redns- = let co1 = liftCoSubst Nominal lc inner_ki- co1_kind = coercionKind co1- unrewritten_tys = map reductionOriginalType arg_redns- (arg_cos, res_co) = decomposePiCos co1 co1_kind unrewritten_tys- casted_args = zipWith3 mkCoherenceRightRedn roles arg_redns arg_cos- zapped_lc = zapLiftingContext lc- Pair rewritten_kind _ = co1_kind- (bndrs, new_inner) = splitPiTys rewritten_kind-- ArgsReductions redns_out res_co_out- = go zapped_lc bndrs new_inner roles casted_args- in- ArgsReductions redns_out (res_co `mkTransMCoR` res_co_out)-- go _ _ _ _ _ = error "simplifyArgsWorker wandered into deeper water than usual"-------------------------------------------------------------------------------------- | Get the reverse of an 'MCoercion'-mkSymMCo :: MCoercion -> MCoercion-mkSymMCo MRefl = MRefl-mkSymMCo (MCo co) = MCo (mkSymCo co)--mkGReflLeftMCo :: Role -> Type -> MCoercion -> Coercion-mkGReflLeftMCo r ty MRefl = mkReflCo r ty-mkGReflLeftMCo r ty (MCo co) = mkGReflLeftCo r ty co--mkGReflRightMCo :: Role -> Type -> MCoercion -> Coercion-mkGReflRightMCo r ty MRefl = mkReflCo r ty-mkGReflRightMCo r ty (MCo co) = mkGReflRightCo r ty co---- | Cast a type by an 'MCoercion'-mkCastTyMCo :: Type -> MCoercion -> Type-mkCastTyMCo ty MRefl = ty-mkCastTyMCo ty (MCo co) = ty `mkCastTy` co---- | Like 'mkCoherenceRightCo', but with an 'MCoercion'-mkCoherenceRightMCo :: Role -> Type -> MCoercion -> Coercion -> Coercion-mkCoherenceRightMCo _ _ MRefl co2 = co2-mkCoherenceRightMCo r ty (MCo co) co2 = mkCoherenceRightCo r ty co co2--mkTransMCoR :: Coercion -> MCoercion -> MCoercion-mkTransMCoR co1 MRefl = coToMCo co1-mkTransMCoR co1 (MCo co2) = MCo (mkTransCo co1 co2)------------------------------------------------------------------------------------#if !MIN_VERSION_ghc(9,0,0)--coercionLKind, coercionRKind :: Coercion -> Type-coercionLKind co = case coercionKind co of { Pair lco _ -> lco }-coercionRKind co = case coercionKind co of { Pair _ rco -> rco }---- | Creates a new coercion with both of its types casted by different casts--- @castCoercionKind2 g r t1 t2 h1 h2@, where @g :: t1 ~r t2@,--- has type @(t1 |> h1) ~r (t2 |> h2)@.--- @h1@ and @h2@ must be nominal.-castCoercionKind2 :: Coercion -> Role -> Type -> Type- -> CoercionN -> CoercionN -> Coercion-castCoercionKind2 g r t1 t2 h1 h2- = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g)---- | @castCoercionKind1 g r t1 t2 h@ = @coercionKind g r t1 t2 h h@--- That is, it's a specialised form of castCoercionKind, where the two--- kind coercions are identical--- @castCoercionKind1 g r t1 t2 h@, where @g :: t1 ~r t2@,--- has type @(t1 |> h) ~r (t2 |> h)@.--- @h@ must be nominal.--- See Note [castCoercionKind1]-castCoercionKind1 :: Coercion -> Role -> Type -> Type- -> CoercionN -> Coercion-castCoercionKind1 g r t1 t2 h- = case g of- Refl {} -> mkNomReflCo (mkCastTy t2 h)- GRefl _ _ mco -> case mco of- MRefl -> mkReflCo r (mkCastTy t2 h)- 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+{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} + +module GHC.TcPlugin.API.Internal.Shim.Reduction where + +-- base +import Prelude + hiding (Floating(cos)) + +-- ghc +import GHC.Core.Class + ( Class(classTyCon) ) +import GHC.Core.Coercion + ( Coercion, CoercionN, MCoercion(..) + , Role(Nominal), LiftingContext +#if MIN_VERSION_ghc(9,0,0) + , castCoercionKind1, castCoercionKind2 + , coercionLKind, coercionRKind +#else + , mkCoherenceLeftCo, mkNomReflCo +#endif + , coercionKind +#if MIN_VERSION_ghc(8,10,0) + , coToMCo +#else + , isReflCo +#endif + , decomposePiCos, downgradeRole + , liftCoSubst, emptyLiftingContext, extendLiftingContextAndInScope, zapLiftingContext + , mkAppCo, mkAppCos + , mkCoherenceRightCo + , mkForAllCo, mkFunCo + , mkGReflLeftCo, mkGReflRightCo + , mkHomoForAllCos, mkProofIrrelCo + , mkReflCo, mkSubCo, mkSymCo, mkTransCo, mkTyConAppCo + ) +import GHC.Core.Predicate + ( mkClassPred ) +import GHC.Core.TyCo.Rep + ( TyCoBinder, mkFunTy +#if !MIN_VERSION_ghc(9,0,0) + , Coercion(..) +#endif + ) +import GHC.Core.TyCon + ( TyCon ) +import GHC.Core.Type + ( ArgFlag, Kind, Type, TyVar, TyVarBinder +#if MIN_VERSION_ghc(8,10,0) + , AnonArgFlag +#endif + , binderVars + , mkAppTy, mkAppTys, mkCastTy, mkCoercionTy, mkForAllTy, mkForAllTys + , mkTyConApp, mkPiTys + , noFreeVarsOfType + , splitPiTys, tyCoBinderType, tyCoBinderVar_maybe + ) +import GHC.Data.Pair + ( Pair(Pair) ) +import GHC.Types.Var + ( setTyVarKind ) +import GHC.Types.Var.Env + ( mkInScopeSet ) +import GHC.Types.Var.Set + ( TyCoVarSet ) +import GHC.Utils.Outputable + ( Outputable(ppr), (<+>) + , braces, text, vcat + ) + +-------------------------------------------------------------------------------- + + +-- | A 'Reduction' is the result of an operation that rewrites a type @ty_in@. +-- The 'Reduction' includes the rewritten type @ty_out@ and a 'Coercion' @co@ +-- such that @co :: ty_in ~ ty_out@, where the role of the coercion is determined +-- by the context. That is, the LHS type of the coercion is the original type +-- @ty_in@, while its RHS type is the rewritten type @ty_out@. +-- +-- A Reduction is always homogeneous, unless it is wrapped inside a 'HetReduction', +-- which separately stores the kind coercion. +data Reduction = + Reduction + { reductionCoercion :: Coercion + , reductionReducedType :: !Type + } + +-- | Stores a heterogeneous reduction. +-- +-- The stored kind coercion must relate the kinds of the +-- stored reduction. That is, in @HetReduction (Reduction co xi) kco@, +-- we must have: +-- +-- > co :: ty ~ xi +-- > kco :: typeKind ty ~ typeKind xi +data HetReduction = + HetReduction + Reduction + MCoercion + +-- | Create a heterogeneous reduction. +-- +-- Pre-condition: the provided kind coercion (second argument) +-- relates the kinds of the stored reduction. +-- That is, if the coercion stored in the 'Reduction' is of the form +-- +-- > co :: ty ~ xi +-- +-- Then the kind coercion supplied must be of the form: +-- +-- > kco :: typeKind ty ~ typeKind xi +mkHetReduction :: Reduction -- ^ heterogeneous reduction + -> MCoercion -- ^ kind coercion + -> HetReduction +mkHetReduction redn mco = HetReduction redn mco +{-# INLINE mkHetReduction #-} + +-- | Homogenise a heterogeneous reduction. +-- +-- Given @HetReduction (Reduction co xi) kco@, with +-- +-- > co :: ty ~ xi +-- > kco :: typeKind(ty) ~ typeKind(xi) +-- +-- this returns the homogeneous reduction: +-- +-- > hco :: ty ~ ( xi |> sym kco ) +homogeniseHetRedn :: Role -> HetReduction -> Reduction +homogeniseHetRedn role (HetReduction redn kco) + = mkCoherenceRightMRedn role redn (mkSymMCo kco) +{-# INLINE homogeniseHetRedn #-} + +-- | Create a 'Reduction' from a pair of a 'Coercion' and a 'Type. +-- +-- Pre-condition: the RHS type of the coercion matches the provided type +-- (perhaps up to zonking). +-- +-- Use 'coercionRedn' when you only have the coercion. +mkReduction :: Coercion -> Type -> Reduction +mkReduction co ty = Reduction co ty +{-# INLINE mkReduction #-} + +instance Outputable Reduction where + ppr redn = + braces $ vcat + [ text "reductionOriginalType:" <+> ppr (reductionOriginalType redn) + , text " reductionReducedType:" <+> ppr (reductionReducedType redn) + , text " reductionCoercion:" <+> ppr (reductionCoercion redn) + ] + +-- | A 'Reduction' in which the 'Coercion' has 'Nominal' role. +type ReductionN = Reduction + +-- | A 'Reduction' in which the 'Coercion' has 'Representational' role. +type ReductionR = Reduction + +-- | Get the original, unreduced type corresponding to a 'Reduction'. +-- +-- This is obtained by computing the LHS kind of the stored coercion, +-- which may be slow. +reductionOriginalType :: Reduction -> Type +reductionOriginalType = coercionLKind . reductionCoercion +{-# INLINE reductionOriginalType #-} + +-- | Turn a 'Coercion' into a 'Reduction' +-- by inspecting the RHS type of the coercion. +-- +-- Prefer using 'mkReduction' when you already know +-- the RHS type of the coercion, to avoid computing it anew. +coercionRedn :: Coercion -> Reduction +coercionRedn co = Reduction co (coercionRKind co) +{-# INLINE coercionRedn #-} + +-- | Downgrade the role of the coercion stored in the 'Reduction'. +downgradeRedn :: Role -- ^ desired role + -> Role -- ^ current role + -> Reduction + -> Reduction +downgradeRedn new_role old_role redn@(Reduction co _) + = redn { reductionCoercion = downgradeRole new_role old_role co } +{-# INLINE downgradeRedn #-} + +-- | Downgrade the role of the coercion stored in the 'Reduction', +-- from 'Nominal' to 'Representational'. +mkSubRedn :: Reduction -> Reduction +mkSubRedn redn@(Reduction co _) = redn { reductionCoercion = mkSubCo co } +{-# INLINE mkSubRedn #-} + +-- | Compose a reduction with a coercion on the left. +-- +-- Pre-condition: the provided coercion's RHS type must match the LHS type +-- of the coercion that is stored in the reduction. +mkTransRedn :: Coercion -> Reduction -> Reduction +mkTransRedn co1 redn@(Reduction co2 _) + = redn { reductionCoercion = co1 `mkTransCo` co2 } +{-# INLINE mkTransRedn #-} + +-- | The reflexive reduction. +mkReflRedn :: Role -> Type -> Reduction +mkReflRedn r ty = mkReduction (mkReflCo r ty) ty + +-- | Create a 'Reduction' from a kind cast, in which +-- the casted type is the rewritten type. +-- +-- Given @ty :: k1@, @mco :: k1 ~ k2@, +-- produces the 'Reduction' @ty ~res_co~> (ty |> mco)@ +-- at the given 'Role'. +mkGReflRightRedn :: Role -> Type -> CoercionN -> Reduction +mkGReflRightRedn role ty co + = mkReduction + (mkGReflRightCo role ty co) + (mkCastTy ty co) +{-# INLINE mkGReflRightRedn #-} + +-- | Create a 'Reduction' from a kind cast, in which +-- the casted type is the rewritten type. +-- +-- Given @ty :: k1@, @mco :: k1 ~ k2@, +-- produces the 'Reduction' @ty ~res_co~> (ty |> mco)@ +-- at the given 'Role'. +mkGReflRightMRedn :: Role -> Type -> MCoercion -> Reduction +mkGReflRightMRedn role ty mco + = mkReduction + (mkGReflRightMCo role ty mco) + (mkCastTyMCo ty mco) +{-# INLINE mkGReflRightMRedn #-} + +-- | Create a 'Reduction' from a kind cast, in which +-- the casted type is the original (non-rewritten) type. +-- +-- Given @ty :: k1@, @mco :: k1 ~ k2@, +-- produces the 'Reduction' @(ty |> mco) ~res_co~> ty@ +-- at the given 'Role'. +mkGReflLeftRedn :: Role -> Type -> CoercionN -> Reduction +mkGReflLeftRedn role ty co + = mkReduction + (mkGReflLeftCo role ty co) + ty +{-# INLINE mkGReflLeftRedn #-} + +-- | Create a 'Reduction' from a kind cast, in which +-- the casted type is the original (non-rewritten) type. +-- +-- Given @ty :: k1@, @mco :: k1 ~ k2@, +-- produces the 'Reduction' @(ty |> mco) ~res_co~> ty@ +-- at the given 'Role'. +mkGReflLeftMRedn :: Role -> Type -> MCoercion -> Reduction +mkGReflLeftMRedn role ty mco + = mkReduction + (mkGReflLeftMCo role ty mco) + ty +{-# INLINE mkGReflLeftMRedn #-} + +-- | Apply a cast to the result of a 'Reduction'. +-- +-- Given a 'Reduction' @ty1 ~co1~> (ty2 :: k2)@ and a kind coercion @kco@ +-- with LHS kind @k2@, produce a new 'Reduction' @ty1 ~co2~> ( ty2 |> kco )@ +-- of the given 'Role' (which must match the role of the coercion stored +-- in the 'Reduction' argument). +mkCoherenceRightRedn :: Role -> Reduction -> CoercionN -> Reduction +mkCoherenceRightRedn r (Reduction co1 ty2) kco + = mkReduction + (mkCoherenceRightCo r ty2 kco co1) + (mkCastTy ty2 kco) +{-# INLINE mkCoherenceRightRedn #-} + +-- | Apply a cast to the result of a 'Reduction', using an 'MCoercionN'. +-- +-- Given a 'Reduction' @ty1 ~co1~> (ty2 :: k2)@ and a kind coercion @mco@ +-- with LHS kind @k2@, produce a new 'Reduction' @ty1 ~co2~> ( ty2 |> mco )@ +-- of the given 'Role' (which must match the role of the coercion stored +-- in the 'Reduction' argument). +mkCoherenceRightMRedn :: Role -> Reduction -> MCoercion -> Reduction +mkCoherenceRightMRedn r (Reduction co1 ty2) kco + = mkReduction + (mkCoherenceRightMCo r ty2 kco co1) + (mkCastTyMCo ty2 kco) +{-# INLINE mkCoherenceRightMRedn #-} + +-- | Apply a cast to a 'Reduction', casting both the original and the reduced type. +-- +-- Given @cast_co@ and 'Reduction' @ty ~co~> xi@, this function returns +-- the 'Reduction' @(ty |> cast_co) ~return_co~> (xi |> cast_co)@ +-- of the given 'Role' (which must match the role of the coercion stored +-- in the 'Reduction' argument). +-- +-- Pre-condition: the 'Type' passed in is the same as the LHS type +-- of the coercion stored in the 'Reduction'. +mkCastRedn1 :: Role + -> Type -- ^ original type + -> CoercionN -- ^ coercion to cast with + -> Reduction -- ^ rewritten type, with rewriting coercion + -> Reduction +mkCastRedn1 r ty cast_co (Reduction co xi) + -- co :: ty ~r ty' + -- return_co :: (ty |> cast_co) ~r (ty' |> cast_co) + = mkReduction + (castCoercionKind1 co r ty xi cast_co) + (mkCastTy xi cast_co) +{-# INLINE mkCastRedn1 #-} + +-- | Apply casts on both sides of a 'Reduction' (of the given 'Role'). +-- +-- Use 'mkCastRedn1' when you want to cast both the original and reduced types +-- in a 'Reduction' using the same coercion. +-- +-- Pre-condition: the 'Type' passed in is the same as the LHS type +-- of the coercion stored in the 'Reduction'. +mkCastRedn2 :: Role + -> Type -- ^ original type + -> CoercionN -- ^ coercion to cast with on the left + -> Reduction -- ^ rewritten type, with rewriting coercion + -> CoercionN -- ^ coercion to cast with on the right + -> Reduction +mkCastRedn2 r ty cast_co (Reduction nco nty) cast_co' + = mkReduction + (castCoercionKind2 nco r ty nty cast_co cast_co') + (mkCastTy nty cast_co') +{-# INLINE mkCastRedn2 #-} + +-- | Apply one 'Reduction' to another. +-- +-- Combines 'mkAppCo' and 'mkAppTy`. +mkAppRedn :: Reduction -> Reduction -> Reduction +mkAppRedn (Reduction co1 ty1) (Reduction co2 ty2) + = mkReduction (mkAppCo co1 co2) (mkAppTy ty1 ty2) +{-# INLINE mkAppRedn #-} + +-- | Create a function 'Reduction'. +-- +-- 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 +#if MIN_VERSION_ghc(8,10,0) + vis +#endif +#if MIN_VERSION_ghc(9,0,0) + (Reduction w_co w_ty) +#endif + (Reduction arg_co arg_ty) + (Reduction res_co res_ty) + = mkReduction + ( mkFunCo + r +#if MIN_VERSION_ghc(9,0,0) + w_co +#endif + arg_co + res_co + ) + ( mkFunTy +#if MIN_VERSION_ghc(8,10,0) + vis +#endif +#if MIN_VERSION_ghc(9,0,0) + w_ty +#endif + arg_ty + res_ty + ) +{-# INLINE mkFunRedn #-} + +-- | Create a 'Reduction' associated to a Π type, +-- from a kind 'Reduction' and a body 'Reduction'. +-- +-- Combines 'mkForAllCo' and 'mkForAllTy'. +mkForAllRedn :: ArgFlag + -> TyVar + -> ReductionN -- ^ kind reduction + -> Reduction -- ^ body reduction + -> Reduction +mkForAllRedn vis tv1 (Reduction h ki') (Reduction co ty) + = mkReduction + (mkForAllCo tv1 h co) + (mkForAllTy tv2 vis ty) + where + tv2 = setTyVarKind tv1 ki' +{-# INLINE mkForAllRedn #-} + +-- | Create a 'Reduction' of a quantified type from a +-- 'Reduction' of the body. +-- +-- Combines 'mkHomoForAllCos' and 'mkForAllTys'. +mkHomoForAllRedn :: [TyVarBinder] -> Reduction -> Reduction +mkHomoForAllRedn bndrs (Reduction co ty) + = mkReduction + (mkHomoForAllCos (binderVars bndrs) co) + (mkForAllTys bndrs ty) +{-# INLINE mkHomoForAllRedn #-} + +-- | Create a 'Reduction' from a coercion between coercions. +-- +-- Combines 'mkProofIrrelCo' and 'mkCoercionTy'. +mkProofIrrelRedn :: Role -- ^ role of the created coercion, "r" + -> CoercionN -- ^ co :: phi1 ~N phi2 + -> Coercion -- ^ g1 :: phi1 + -> Coercion -- ^ g2 :: phi2 + -> Reduction -- ^ res_co :: g1 ~r g2 +mkProofIrrelRedn role co g1 g2 + = mkReduction + (mkProofIrrelCo role co g1 g2) + (mkCoercionTy g2) +{-# INLINE mkProofIrrelRedn #-} + +-- | Create a reflexive 'Reduction' whose RHS is the given 'Coercion', +-- with the specified 'Role'. +mkReflCoRedn :: Role -> Coercion -> Reduction +mkReflCoRedn role co + = mkReduction + (mkReflCo role co_ty) + co_ty + where + co_ty = mkCoercionTy co +{-# INLINE mkReflCoRedn #-} + +-- | A collection of 'Reduction's where the coercions and the types are stored separately. +-- +-- Use 'unzipRedns' to obtain 'Reductions' from a list of 'Reduction's. +-- +-- This datatype is used in 'mkAppRedns', 'mkClassPredRedns' and 'mkTyConAppRedn', +-- which expect separate types and coercions. +-- +-- Invariant: the two stored lists are of the same length, +-- and the RHS type of each coercion is the corresponding type. +data Reductions = Reductions [Coercion] [Type] + +-- | Create 'Reductions' from individual lists of coercions and types. +-- +-- The lists should be of the same length, and the RHS type of each coercion +-- should match the specified type in the other list. +mkReductions :: [Coercion] -> [Type] -> Reductions +mkReductions cos tys = Reductions cos tys +{-# INLINE mkReductions #-} + +-- | Combines 'mkAppCos' and 'mkAppTys'. +mkAppRedns :: Reduction -> Reductions -> Reduction +mkAppRedns (Reduction co ty) (Reductions cos tys) + = mkReduction (mkAppCos co cos) (mkAppTys ty tys) +{-# INLINE mkAppRedns #-} + +-- | 'TyConAppCo' for 'Reduction's: combines 'mkTyConAppCo' and `mkTyConApp`. +mkTyConAppRedn :: Role -> TyCon -> Reductions -> Reduction +mkTyConAppRedn role tc (Reductions cos tys) + = mkReduction (mkTyConAppCo role tc cos) (mkTyConApp tc tys) +{-# INLINE mkTyConAppRedn #-} + +-- | Reduce the arguments of a 'Class' 'TyCon'. +mkClassPredRedn :: Class -> Reductions -> Reduction +mkClassPredRedn cls (Reductions cos tys) + = mkReduction + (mkTyConAppCo Nominal (classTyCon cls) cos) + (mkClassPred cls tys) +{-# INLINE mkClassPredRedn #-} + +-- | Obtain 'Reductions' from a list of 'Reduction's by unzipping. +unzipRedns :: [Reduction] -> Reductions +unzipRedns = foldr accRedn (Reductions [] []) + where + accRedn :: Reduction -> Reductions -> Reductions + accRedn (Reduction co xi) (Reductions cos xis) + = Reductions (co:cos) (xi:xis) +{-# INLINE unzipRedns #-} + +-------------------------------------------------------------------------------- + +data ArgsReductions = + ArgsReductions + {-# UNPACK #-} !Reductions + !MCoercion + +{-# INLINE simplifyArgsWorker #-} +simplifyArgsWorker :: [TyCoBinder] -> Kind -> TyCoVarSet -> [Role] -> [Reduction] -> ArgsReductions +simplifyArgsWorker orig_ki_binders orig_inner_ki orig_fvs + orig_roles orig_simplified_args + = go orig_lc + orig_ki_binders orig_inner_ki + orig_roles orig_simplified_args + where + orig_lc = emptyLiftingContext $ mkInScopeSet $ orig_fvs + + go :: LiftingContext -> [TyCoBinder] -> Kind -> [Role] -> [Reduction] -> ArgsReductions + go !lc binders inner_ki _ [] + = ArgsReductions + (mkReductions [] []) + kind_co + where + final_kind = mkPiTys binders inner_ki + kind_co | noFreeVarsOfType final_kind = MRefl + | otherwise = MCo $ liftCoSubst Nominal lc final_kind + + go lc (binder:binders) inner_ki (role:roles) (arg_redn:arg_redns) + = let !kind_co = liftCoSubst Nominal lc (tyCoBinderType binder) + !(Reduction casted_co casted_xi) + = mkCoherenceRightRedn role arg_redn kind_co + -- now, extend the lifting context with the new binding + !new_lc | Just tv <- tyCoBinderVar_maybe binder + = extendLiftingContextAndInScope lc tv casted_co + | otherwise + = lc + !(ArgsReductions (Reductions cos xis) final_kind_co) + = go new_lc binders inner_ki roles arg_redns + in ArgsReductions + (Reductions (casted_co:cos) (casted_xi:xis)) + final_kind_co + + -- See Note [Last case in simplifyArgsWorker] + go lc [] inner_ki roles arg_redns + = let co1 = liftCoSubst Nominal lc inner_ki + co1_kind = coercionKind co1 + unrewritten_tys = map reductionOriginalType arg_redns + (arg_cos, res_co) = decomposePiCos co1 co1_kind unrewritten_tys + casted_args = zipWith3 mkCoherenceRightRedn roles arg_redns arg_cos + zapped_lc = zapLiftingContext lc + Pair rewritten_kind _ = co1_kind + (bndrs, new_inner) = splitPiTys rewritten_kind + + ArgsReductions redns_out res_co_out + = go zapped_lc bndrs new_inner roles casted_args + in + ArgsReductions redns_out (res_co `mkTransMCoR` res_co_out) + + go _ _ _ _ _ = error "simplifyArgsWorker wandered into deeper water than usual" + +-------------------------------------------------------------------------------- + +-- | Get the reverse of an 'MCoercion' +mkSymMCo :: MCoercion -> MCoercion +mkSymMCo MRefl = MRefl +mkSymMCo (MCo co) = MCo (mkSymCo co) + +mkGReflLeftMCo :: Role -> Type -> MCoercion -> Coercion +mkGReflLeftMCo r ty MRefl = mkReflCo r ty +mkGReflLeftMCo r ty (MCo co) = mkGReflLeftCo r ty co + +mkGReflRightMCo :: Role -> Type -> MCoercion -> Coercion +mkGReflRightMCo r ty MRefl = mkReflCo r ty +mkGReflRightMCo r ty (MCo co) = mkGReflRightCo r ty co + +-- | Cast a type by an 'MCoercion' +mkCastTyMCo :: Type -> MCoercion -> Type +mkCastTyMCo ty MRefl = ty +mkCastTyMCo ty (MCo co) = ty `mkCastTy` co + +-- | Like 'mkCoherenceRightCo', but with an 'MCoercion' +mkCoherenceRightMCo :: Role -> Type -> MCoercion -> Coercion -> Coercion +mkCoherenceRightMCo _ _ MRefl co2 = co2 +mkCoherenceRightMCo r ty (MCo co) co2 = mkCoherenceRightCo r ty co co2 + +mkTransMCoR :: Coercion -> MCoercion -> MCoercion +mkTransMCoR co1 MRefl = coToMCo co1 +mkTransMCoR co1 (MCo co2) = MCo (mkTransCo co1 co2) + +-------------------------------------------------------------------------------- + +#if !MIN_VERSION_ghc(9,0,0) + +coercionLKind, coercionRKind :: Coercion -> Type +coercionLKind co = case coercionKind co of { Pair lco _ -> lco } +coercionRKind co = case coercionKind co of { Pair _ rco -> rco } + +-- | Creates a new coercion with both of its types casted by different casts +-- @castCoercionKind2 g r t1 t2 h1 h2@, where @g :: t1 ~r t2@, +-- has type @(t1 |> h1) ~r (t2 |> h2)@. +-- @h1@ and @h2@ must be nominal. +castCoercionKind2 :: Coercion -> Role -> Type -> Type + -> CoercionN -> CoercionN -> Coercion +castCoercionKind2 g r t1 t2 h1 h2 + = mkCoherenceRightCo r t2 h2 (mkCoherenceLeftCo r t1 h1 g) + +-- | @castCoercionKind1 g r t1 t2 h@ = @coercionKind g r t1 t2 h h@ +-- That is, it's a specialised form of castCoercionKind, where the two +-- kind coercions are identical +-- @castCoercionKind1 g r t1 t2 h@, where @g :: t1 ~r t2@, +-- has type @(t1 |> h) ~r (t2 |> h)@. +-- @h@ must be nominal. +-- See Note [castCoercionKind1] +castCoercionKind1 :: Coercion -> Role -> Type -> Type + -> CoercionN -> Coercion +castCoercionKind1 g r t1 t2 h + = case g of + Refl {} -> mkNomReflCo (mkCastTy t2 h) + GRefl _ _ mco -> case mco of + MRefl -> mkReflCo r (mkCastTy t2 h) + 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
src/GHC/TcPlugin/API/Names.hs view
@@ -1,494 +1,477 @@-{-# LANGUAGE AllowAmbiguousTypes #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralisedNewtypeDeriving #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PolyKinds #-}-{-# LANGUAGE QuantifiedConstraints #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE UndecidableInstances #-}--#if MIN_VERSION_ghc(9,0,0)-{-# LANGUAGE StandaloneKindSignatures #-}-#endif--{-|-Module: GHC.TcPlugin.API.Names--This module provides an /optional/ framework that facilitates name lookup-in type-checking plugins, using constrained traversals (similar to the-<https://hackage.haskell.org/package/barbies barbies library>).--See the 'ResolveNames' typeclass.--Before:--> data PluginDefs =-> PluginDefs-> { myTyCon :: TyCon-> , myClass :: Class-> , myPromotedDataCon :: TyCon-> }->-> findMyModule :: MonadTcPlugin m => m Module-> findMyModule = do-> findResult <- findImportedModule ( mkModuleName "MyModule" ) Nothing-> case findResult of-> Found _ res -> pure res-> _ -> error $ "MyPlugin: could not find any module named MyModule."->-> pluginInit :: TcPluginM Init PluginDefs-> pluginInit = do-> myModule <- findMyModule-> myTyCon <- tcLookupTyCon =<< lookupOrig myModule ( mkTcOcc "MyTyCon" )-> myClass <- tcLookupClass =<< lookupOrig myModule ( mkClsOcc "MyClass" )-> myPromotedDataCon <- fmap promoteDataCon . tcLookupDataCon =<< lookupOrig myModule ( mkDataOcc "MyDataCon" )-> pure ( PluginDefs { .. } )--After:--> data PluginDefsHKD n =-> PluginDefs-> { myTyCon :: Wear n TyCon-> , myClass :: Wear n Class-> , myPromotedDataCon :: Wear n ( Promoted DataCon )-> }-> deriving stock Generic-> deriving ResolveNames-> via Generically1 PluginDefsHKD->-> type PluginDefs = PluginDefsHKD Resolved->-> pluginInit :: TcPluginM Init PluginDefs-> pluginInit = resolveNames pluginNames-> where-> pluginNames :: PluginDefsHKD Named-> pluginNames =-> PluginDefs-> { myTyCon = mkQualified "MyTyCon"-> , myClass = mkQualified "MyClass"-> , myPromotedDataCon = mkQualified "MyDataCon"-> }-> mkQualified :: String -> QualifiedName thing-> mkQualified str =-> Qualified-> { name = str-> , module' = mkModuleName "MyModule"-> , package = Nothing-> }---}--module GHC.TcPlugin.API.Names- ( ResolveNames, resolveNames- , Wear, QualifiedName(..), NameResolution(..)- , Promoted- , Lookupable(..)-- -- * Re-export Generically1 for compatibility.- , Generically1(..)- ) where---- base-import Prelude- hiding ( lookup )-import Data.Coerce- ( Coercible, coerce )-import Data.Kind- ( Type, Constraint )-import GHC.Generics- ( Generic(..)-#if MIN_VERSION_base(4,17,0)- , Generically1(..)-#endif- , (:+:)(..), (:*:)(..)- , K1(K1), M1(M1), U1(..), V1, Rec0- )-import GHC.TypeLits- ( TypeError, ErrorMessage(..) )---- transformers-import Control.Monad.Trans.State.Strict- ( StateT, evalStateT, get, put )-import Control.Monad.Trans.Class- ( MonadTrans(lift) )---- ghc-#if MIN_VERSION_ghc(9,3,0)-import GHC.Iface.Errors- ( cannotFindModule )-#elif MIN_VERSION_ghc(9,2,0)-import GHC.Iface.Load- ( cannotFindModule )-#else-import GHC.Driver.Types- ( hsc_dflags )-import GHC.Driver.Finder- ( cannotFindModule )-import GHC.Driver.Session- ( DynFlags )-#endif-#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- ( addToUFM, addToUFM_C, lookupUFM, plusUFM, unitUFM )---- ghc-tcplugin-api-import GHC.TcPlugin.API- hiding ( Type )-import GHC.TcPlugin.API.Internal- ( MonadTcPlugin(liftTcPluginM) )-------------------------------------------------------------------------------------- | A 'QualifiedName' is the name of something,--- together with the names of the module and package it comes from.-data QualifiedName (thing :: Type)- = Qualified- { -- | Name of the thing (e.g. name of the 'TyCon' or 'Class').- name :: String- -- | Name of the module in which the thing can be found.- , module' :: ModuleName- -- | Name of the package in which the module can be found.- , package :: PkgQual- }---- | Type-level parameter to 'Wear' type family, for higher-kinded data.------ @Wear Named thing@ is the identifier data passed in as an argument.--- @Wear Resolved thing@ is the result of name resolving the thing.------ This allows users to pass a record of names, of type @MyData Named@,--- and obtain a record of looked-up things, of type @MyData Resolved@.------ Refer to 'ResolveNames' for a worked example.-data NameResolution = Named | Resolved---- | Use this to refer to a @Promoted DataCon@.-data Promoted (thing :: k) :: Type---- | Type-family used for higher-kinded data pattern.------ This allows the same record to be re-used,--- as explained in the worked example for 'ResolveNames'.------ For instance, if one defines:------ > data MyData n--- > = MyData--- > { myClass :: !( Wear n Class )--- > , myTyCon :: !( Wear n TyCon )--- > }------ then a record of type @MyData Named@ is simply a record of textual names--- (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-#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- ( Text "Cannot promote " :<>: ShowType a :<>: Text "."- :$$: Text "Can only promote 'DataCon's."- )- Wear Resolved thing = thing---- | Retrieve the underlying thing being referred to by inspecting--- the type parameter of 'QualifiedName'.-type family UnwearNamed (loc :: Type) :: Type where- UnwearNamed (QualifiedName thing) = thing---- | Type-class overloading things that can be looked up by name:------ * classes,--- * data constructors (as well as their promotion),--- * type-constructors.-#if MIN_VERSION_ghc(9,0,0)-type Lookupable :: forall {k}. k -> Constraint-#endif-class Lookupable (a :: k) where- mkOccName :: String -> OccName- lookup :: MonadTcPlugin m => Name -> m (Wear Resolved a)--instance Lookupable TyCon where- mkOccName = mkTcOcc- lookup = tcLookupTyCon-instance Lookupable DataCon where- mkOccName = mkDataOcc- lookup = tcLookupDataCon-instance Lookupable Class where- mkOccName = mkClsOcc- lookup = tcLookupClass-instance Lookupable (Promoted DataCon) where- mkOccName = mkDataOcc- lookup = fmap promoteDataCon . tcLookupDataCon---- | This class exposes the method 'resolveNames' which will--- perform name resolution for all the fields in a datatype.------ Example usage: we define a record that will hold--- the things we want to look up, using the 'Wear' type family.------ For example:------ > data MyData n--- > = MyData--- > { myClass :: !( Wear n Class )--- > , myTyCon :: !( Wear n TyCon )--- > , myDataCon :: !( Wear n DataCon )--- > , myPromDataCon :: !( Wear n (Promoted DataCon) )--- > }--- > deriving stock Generic--- > deriving ResolveNames--- > via Generically1 MyData------ Now we can specify the names of the things which we want to look up,--- together with the modules and packages in which they belong:------ > myNames :: MyData Named--- > myNames = MyData--- > { myClass = QualifiedName "MyClass" "My.Module" ( Just "my-pkg-name" )--- > , ...--- > }------ Then we can call 'resolveNames':------ > resolvedNames :: MonadTcPlugin m => m (MyData Resolved)--- > resolvedNames = resolveNames myNames------ This returns a record containing the looked up things we want,--- e.g. @myClass :: Class@, @myPromDataCon :: TyCon@, etc.-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",- -- because otherwise GHC complains when using DerivingVia that we don't know the role- -- of the parameter to m, despite the quantified constraint superclass to MonadTcPlugin.- --- -- This unfortunately worsens type-inference, so we export- -- 'resolveNames' separately.---- | Resolve a collection of names.------ See 'ResolveNames' for further details.-resolveNames :: ( MonadTcPlugin m, ResolveNames f )- => f Named -> m ( f Resolved )-resolveNames = resolve_names--instance ( Generic (f Named)- , Generic (f Resolved)- , GTraversableC ResolveName (Rep (f Named)) (Rep (f Resolved))- )- => ResolveNames (Generically1 f) where- resolve_names- :: forall-#if MIN_VERSION_ghc(9,0,0)- {m}-#else- m-#endif- res- . ( Coercible res ( Generically1 f Resolved ), MonadTcPlugin m )- => Generically1 f Named -> m res- resolve_names ( Generically1 dat )- = ( `evalStateT` emptyModules )- $ coerce . to @(f Resolved)- <$> gtraverseC @ResolveName resolveName ( from dat )---- | Type-class dispatch for looking up names.------ Every instance is of the form:------ > ResolveName (Wear Named thing) (Wear Resolved thing)------ which allows one to write 'resolveName':------ > resolveName :: ... => Wear Named thing -> m ( Wear Resolved thing )-class ( a ~ Wear Named ( UnwearNamed a )- , b ~ Wear Resolved ( UnwearNamed a )- , Lookupable ( UnwearNamed a )- )- => 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 :: 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 pkg) = do- md <- lookupModule pkg mod_name- 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.--data ImportedModules- = ImportedModules- { 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- { home_modules = emptyUFM- , this_pkg_modules = emptyUFM- , other_pkg_modules = emptyUFM- }--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--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) }--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 pkg mod_name res- pure res- Nothing -> do- findResult <- lift $ findImportedModule mod_name pkg- case findResult of- Found _ res- -> pure res- other -> do- hsc_env <- lift . liftTcPluginM $ getTopEnv- let- err_doc :: SDoc-#if MIN_VERSION_ghc(9,2,0)- err_doc = cannotFindModule hsc_env mod_name other-#else- err_doc = cannotFindModule dflags mod_name other- dflags :: DynFlags- dflags = hsc_dflags hsc_env-#endif- pgmErrorDoc- ( "GHC.TcPlugin.API: could not find module " <> mod_str <> " in " <> pkg_name )- 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.--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--class GTraversableC (c :: Type -> Type -> Constraint) (s :: Type -> Type) (t :: Type -> Type) where- gtraverseC :: TraversalC c (s x) (t x)--instance- ( GTraversableC c l l'- , GTraversableC c r r'- ) => GTraversableC c (l :*: r) (l' :*: r') where- gtraverseC f (l :*: r)- = (:*:) <$> gtraverseC @c f l <*> gtraverseC @c f r--instance- ( GTraversableC c l l'- , GTraversableC c r r'- ) => GTraversableC c (l :+: r) (l' :+: r') where- gtraverseC f (L1 l) = L1 <$> gtraverseC @c f l- gtraverseC f (R1 r) = R1 <$> gtraverseC @c f r--instance GTraversableC c s t- => GTraversableC c (M1 i m s) (M1 i m t) where- gtraverseC f (M1 x) = M1 <$> gtraverseC @c f x--instance GTraversableC c U1 U1 where- gtraverseC _ _ = pure U1--instance GTraversableC c V1 V1 where- gtraverseC _ = pure--instance c a b => GTraversableC c (Rec0 a) (Rec0 b) where- gtraverseC f (K1 a) = K1 <$> f a------------------------------------------------------------------------------------- Generically and Generically1 wrappers for DerivingVia.--#if !MIN_VERSION_base(4,17,0)--- | A type whose instances are defined generically, using the--- 'Generic1' representation. 'Generically1' is a higher-kinded--- version of 'Generically' that uses 'Generic'.------ Generic instances can be derived for type constructors via--- @'Generically1' F@ using @-XDerivingVia@.-newtype Generically1 (f :: k -> Type) (a :: k) = Generically1 ( f a )-#endif+{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralisedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuantifiedConstraints #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +#if MIN_VERSION_ghc(9,0,0) +{-# LANGUAGE StandaloneKindSignatures #-} +#endif + +{-| +Module: GHC.TcPlugin.API.Names + +This module provides an /optional/ framework that facilitates name lookup +in type-checking plugins, using constrained traversals (similar to the +<https://hackage.haskell.org/package/barbies barbies library>). + +See the 'ResolveNames' typeclass. + +Before: + +> data PluginDefs = +> PluginDefs +> { myTyCon :: TyCon +> , myClass :: Class +> , myPromotedDataCon :: TyCon +> } +> +> findMyModule :: MonadTcPlugin m => m Module +> findMyModule = do +> 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." +> +> pluginInit :: TcPluginM Init PluginDefs +> pluginInit = do +> myModule <- findMyModule +> myTyCon <- tcLookupTyCon =<< lookupOrig myModule ( mkTcOcc "MyTyCon" ) +> myClass <- tcLookupClass =<< lookupOrig myModule ( mkClsOcc "MyClass" ) +> myPromotedDataCon <- fmap promoteDataCon . tcLookupDataCon =<< lookupOrig myModule ( mkDataOcc "MyDataCon" ) +> pure ( PluginDefs { .. } ) + +After: + +> data PluginDefsHKD n = +> PluginDefs +> { myTyCon :: Wear n TyCon +> , myClass :: Wear n Class +> , myPromotedDataCon :: Wear n ( Promoted DataCon ) +> } +> deriving stock Generic +> deriving ResolveNames +> via Generically1 PluginDefsHKD +> +> type PluginDefs = PluginDefsHKD Resolved +> +> pluginInit :: TcPluginM Init PluginDefs +> pluginInit = resolveNames pluginNames +> where +> pluginNames :: PluginDefsHKD Named +> pluginNames = +> PluginDefs +> { myTyCon = mkQualified "MyTyCon" +> , myClass = mkQualified "MyClass" +> , myPromotedDataCon = mkQualified "MyDataCon" +> } +> mkQualified :: String -> QualifiedName thing +> mkQualified str = +> Qualified +> { name = str +> , module' = mkModuleName "MyModule" +> , package = Nothing +> } + +-} + +module GHC.TcPlugin.API.Names + ( ResolveNames, resolveNames + , Wear, QualifiedName(..), NameResolution(..) + , Promoted + , Lookupable(..) + + -- * Re-export Generically1 for compatibility. + , Generically1(..) + ) where + +-- base +import Prelude + hiding ( lookup ) +import Data.Coerce + ( Coercible, coerce ) +import Data.Kind + ( Type, Constraint ) +import GHC.Generics + ( Generic(..) +#if MIN_VERSION_base(4,17,0) + , Generically1(..) +#endif + , (:+:)(..), (:*:)(..) + , K1(K1), M1(M1), U1(..), V1, Rec0 + ) +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, modify ) +import Control.Monad.Trans.Class + ( MonadTrans(lift) ) + +-- ghc +#if MIN_VERSION_ghc(9,8,0) +import GHC.Iface.Errors.Ppr + ( missingInterfaceErrorDiagnostic ) +#endif +#if MIN_VERSION_ghc(9,3,0) +import GHC.Iface.Errors + ( cannotFindModule ) +#elif MIN_VERSION_ghc(9,2,0) +import GHC.Iface.Load + ( cannotFindModule ) +#else +import GHC.Driver.Types + ( hsc_dflags ) +import GHC.Driver.Finder + ( cannotFindModule ) +#endif +#if MIN_VERSION_ghc(9,5,0) +import Language.Haskell.Syntax.Module.Name + ( moduleNameString ) +#else +import GHC.Unit.Module.Name + ( moduleNameString ) +#endif +import GHC.Utils.Panic + ( pgmErrorDoc ) +import GHC.Tc.Plugin + ( getTopEnv ) +#if MIN_VERSION_ghc(9,8,0) +import GHC.Types.Error + ( HasDefaultDiagnosticOpts(defaultOpts) ) +#endif + +-- ghc-tcplugin-api +import GHC.TcPlugin.API + hiding ( Type ) +import GHC.TcPlugin.API.Internal + ( MonadTcPlugin(liftTcPluginM) ) + +-------------------------------------------------------------------------------- + +-- | A 'QualifiedName' is the name of something, +-- together with the names of the module and package it comes from. +data QualifiedName (thing :: Type) + = Qualified + { -- | Name of the thing (e.g. name of the 'TyCon' or 'Class'). + name :: String + -- | Name of the module in which the thing can be found. + , module' :: ModuleName + -- | Name of the package in which the module can be found. + , package :: PkgQual + } + +-- | Type-level parameter to 'Wear' type family, for higher-kinded data. +-- +-- @Wear Named thing@ is the identifier data passed in as an argument. +-- @Wear Resolved thing@ is the result of name resolving the thing. +-- +-- This allows users to pass a record of names, of type @MyData Named@, +-- and obtain a record of looked-up things, of type @MyData Resolved@. +-- +-- Refer to 'ResolveNames' for a worked example. +data NameResolution = Named | Resolved + +-- | Use this to refer to a @Promoted DataCon@. +data Promoted (thing :: k) :: Type + +-- | Type-family used for higher-kinded data pattern. +-- +-- This allows the same record to be re-used, +-- as explained in the worked example for 'ResolveNames'. +-- +-- For instance, if one defines: +-- +-- > data MyData n +-- > = MyData +-- > { myClass :: !( Wear n Class ) +-- > , myTyCon :: !( Wear n TyCon ) +-- > } +-- +-- then a record of type @MyData Named@ is simply a record of textual names +-- (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 +#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 + ( Text "Cannot promote " :<>: ShowType a :<>: Text "." + :$$: Text "Can only promote 'DataCon's." + ) + Wear Resolved thing = thing + +-- | Retrieve the underlying thing being referred to by inspecting +-- the type parameter of 'QualifiedName'. +type family UnwearNamed (loc :: Type) :: Type where + UnwearNamed (QualifiedName thing) = thing + +-- | Type-class overloading things that can be looked up by name: +-- +-- * classes, +-- * data constructors (as well as their promotion), +-- * type-constructors. +#if MIN_VERSION_ghc(9,0,0) +type Lookupable :: forall {k}. k -> Constraint +#endif +class Lookupable (a :: k) where + mkOccName :: String -> OccName + lookup :: MonadTcPlugin m => Name -> m (Wear Resolved a) + +instance Lookupable TyCon where + mkOccName = mkTcOcc + lookup = tcLookupTyCon +instance Lookupable DataCon where + mkOccName = mkDataOcc + lookup = tcLookupDataCon +instance Lookupable Class where + mkOccName = mkClsOcc + lookup = tcLookupClass +instance Lookupable (Promoted DataCon) where + mkOccName = mkDataOcc + lookup = fmap promoteDataCon . tcLookupDataCon + +-- | This class exposes the method 'resolveNames' which will +-- perform name resolution for all the fields in a datatype. +-- +-- Example usage: we define a record that will hold +-- the things we want to look up, using the 'Wear' type family. +-- +-- For example: +-- +-- > data MyData n +-- > = MyData +-- > { myClass :: !( Wear n Class ) +-- > , myTyCon :: !( Wear n TyCon ) +-- > , myDataCon :: !( Wear n DataCon ) +-- > , myPromDataCon :: !( Wear n (Promoted DataCon) ) +-- > } +-- > deriving stock Generic +-- > deriving ResolveNames +-- > via Generically1 MyData +-- +-- Now we can specify the names of the things which we want to look up, +-- together with the modules and packages in which they belong: +-- +-- > myNames :: MyData Named +-- > myNames = MyData +-- > { myClass = QualifiedName "MyClass" "My.Module" ( Just "my-pkg-name" ) +-- > , ... +-- > } +-- +-- Then we can call 'resolveNames': +-- +-- > resolvedNames :: MonadTcPlugin m => m (MyData Resolved) +-- > resolvedNames = resolveNames myNames +-- +-- This returns a record containing the looked up things we want, +-- e.g. @myClass :: Class@, @myPromDataCon :: TyCon@, etc. +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", + -- because otherwise GHC complains when using DerivingVia that we don't know the role + -- of the parameter to m, despite the quantified constraint superclass to MonadTcPlugin. + -- + -- This unfortunately worsens type-inference, so we export + -- 'resolveNames' separately. + +-- | Resolve a collection of names. +-- +-- See 'ResolveNames' for further details. +resolveNames :: ( MonadTcPlugin m, ResolveNames f ) + => f Named -> m ( f Resolved ) +resolveNames = resolve_names + +instance ( Generic (f Named) + , Generic (f Resolved) + , GTraversableC ResolveName (Rep (f Named)) (Rep (f Resolved)) + ) + => ResolveNames (Generically1 f) where + resolve_names + :: forall +#if MIN_VERSION_ghc(9,0,0) + {m} +#else + m +#endif + res + . ( Coercible res ( Generically1 f Resolved ), MonadTcPlugin m ) + => Generically1 f Named -> m res + resolve_names ( Generically1 dat ) + = ( `evalStateT` emptyModules ) + $ coerce . to @(f Resolved) + <$> gtraverseC @ResolveName resolveName ( from dat ) + +-- | Type-class dispatch for looking up names. +-- +-- Every instance is of the form: +-- +-- > ResolveName (Wear Named thing) (Wear Resolved thing) +-- +-- which allows one to write 'resolveName': +-- +-- > resolveName :: ... => Wear Named thing -> m ( Wear Resolved thing ) +class ( a ~ Wear Named ( UnwearNamed a ) + , b ~ Wear Resolved ( UnwearNamed a ) + , Lookupable ( UnwearNamed a ) + ) + => 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 :: 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 pkg) = do + md <- lookupModule pkg mod_name + 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. + +newtype ImportedModules + = ImportedModules + { imported_modules :: Map (PkgQual, ModuleName) Module + } + +emptyModules :: ImportedModules +emptyModules = + ImportedModules Map.empty + +lookupCachedModule :: Monad m => PkgQual -> ModuleName -> StateT ImportedModules m (Maybe Module) +lookupCachedModule pkg modl = Map.lookup (pkg, modl) . imported_modules <$> get + +insertCachedModule :: Monad m => PkgQual -> ModuleName -> Module -> StateT ImportedModules m () +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 + cachedResult <- lookupCachedModule pkg mod_name + case cachedResult of + Just res -> do + insertCachedModule pkg mod_name res + pure res + Nothing -> do + findResult <- lift $ findImportedModule mod_name pkg + case findResult of + Found _ res + -> pure res + other -> do + hsc_env <- lift . liftTcPluginM $ getTopEnv + let + err_doc :: SDoc + err_doc = +#if MIN_VERSION_ghc(9,8,0) + missingInterfaceErrorDiagnostic defaultOpts $ +#endif +#if MIN_VERSION_ghc(9,2,0) + cannotFindModule hsc_env mod_name other +#else + cannotFindModule (hsc_dflags hsc_env) mod_name other +#endif + pgmErrorDoc + ( "GHC.TcPlugin.API: could not find module " + <> moduleNameString mod_name + <> case pkgQualToPkgName pkg of + Just p -> " in package " <> p + Nothing -> mempty + ) + err_doc + +-------------------------------------------------------------------------------- +-- Constrained traversals. + +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 + +class GTraversableC (c :: Type -> Type -> Constraint) (s :: Type -> Type) (t :: Type -> Type) where + gtraverseC :: TraversalC c (s x) (t x) + +instance + ( GTraversableC c l l' + , GTraversableC c r r' + ) => GTraversableC c (l :*: r) (l' :*: r') where + gtraverseC f (l :*: r) + = (:*:) <$> gtraverseC @c f l <*> gtraverseC @c f r + +instance + ( GTraversableC c l l' + , GTraversableC c r r' + ) => GTraversableC c (l :+: r) (l' :+: r') where + gtraverseC f (L1 l) = L1 <$> gtraverseC @c f l + gtraverseC f (R1 r) = R1 <$> gtraverseC @c f r + +instance GTraversableC c s t + => GTraversableC c (M1 i m s) (M1 i m t) where + gtraverseC f (M1 x) = M1 <$> gtraverseC @c f x + +instance GTraversableC c U1 U1 where + gtraverseC _ _ = pure U1 + +instance GTraversableC c V1 V1 where + gtraverseC _ = pure + +instance c a b => GTraversableC c (Rec0 a) (Rec0 b) where + gtraverseC f (K1 a) = K1 <$> f a + +-------------------------------------------------------------------------------- +-- Generically and Generically1 wrappers for DerivingVia. + +#if !MIN_VERSION_base(4,17,0) +-- | A type whose instances are defined generically, using the +-- 'Generic1' representation. 'Generically1' is a higher-kinded +-- version of 'Generically' that uses 'Generic'. +-- +-- Generic instances can be derived for type constructors via +-- @'Generically1' F@ using @-XDerivingVia@. +newtype Generically1 (f :: k -> Type) (a :: k) = Generically1 ( f a ) +#endif
+ src/GHC/TcPlugin/API/TyConSubst.hs view
@@ -0,0 +1,537 @@+{-# LANGUAGE CPP #-} + +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} + +{-| +Module: GHC.TcPlugin.API.TyConSubst + +This module provides functionality for recognising whether a type is a +'TyConApp' while taking into account Given nominal equalities. + +In particular, this allows dealing with flattening variables on older GHC versions +(9.0 and below). For example, instead of @[W] m + n ~ n + m@, older GHCs might +produce @[G] u ~ m + n, [G] v ~ n + m, [W] u ~ v@. In this case, one needs to +use the Givens to recognise that @u ~ v@ can be solved using the laws of natural +number arithmetic. + +Usage: + + - Use 'mkTyConSubst' to create a 'TyConSubst' from Givens. + - Use 'splitTyConApp_upTo' to compute whether a type is a 'TyConApp', taking + into account Given constraints (in the form of the 'TyConSubst'). + +Notes: + + - 'splitTyConApp_upTo' will also look through type synonyms, + - 'splitTyConApp_upTo' only takes into account nominal equalities. + Please open a ticket if you have a need for rewriting modulo representational + equalities. + +-} +module GHC.TcPlugin.API.TyConSubst ( + TyConSubst -- opaque + , mkTyConSubst + , splitTyConApp_upTo + ) where + +-- Word64Map is available: +-- +-- - from 9.10.1 onwards +-- - in 9.8.4 +-- - in 9.6.7 +-- +-- This is unusual: whether a module is exposed depends on the MINOR version +#define HAS_WORD64MAP \ + (MIN_VERSION_ghc(9,9,0) || \ + (MIN_VERSION_ghc(9,8,4) && !(MIN_VERSION_ghc(9,9,0))) || \ + (MIN_VERSION_ghc(9,6,7) && !(MIN_VERSION_ghc(9,7,0)))) + +-- base +import Data.Bifunctor + ( Bifunctor(first, second) ) +import Data.Either + ( partitionEithers ) +import Data.Foldable + ( toList, asum ) +import Data.List.NonEmpty + ( NonEmpty(..) ) +import Data.Maybe + ( fromJust ) +#if !MIN_VERSION_ghc(8,11,0) +import Unsafe.Coerce + ( unsafeCoerce ) +#endif + +-- containers +import Data.Sequence + ( Seq ) +import qualified Data.Sequence as Seq + +-- ghc +#if HAS_WORD64MAP +import qualified GHC.Data.Word64Map.Strict as Word64Map +#else +import qualified Data.IntMap.Strict as IntMap +#endif +import GHC.Types.Unique + ( Uniquable, getUnique ) +import qualified GHC.Types.Unique.FM as UFM +import GHC.Types.Unique.Set + ( UniqSet ) +import qualified GHC.Types.Unique.Set as UniqSet +import GHC.Utils.Outputable + hiding ( (<>) ) + +-- ghc-tcplugin-api +import GHC.TcPlugin.API +import GHC.Tc.Types.Constraint + +{------------------------------------------------------------------------------- + The main type + + TODO: maybe this could be sped up with + <https://hackage.haskell.org/package/union-find>? +-------------------------------------------------------------------------------} + +-- | Substitution for recognizing 'TyCon' applications modulo nominal equalities. +data TyConSubst = TyConSubst { + tyConSubstMap :: UniqFM TcTyVar (NonEmpty (TyCon, [Type], [Coercion])) + , tyConSubstCanon :: UniqFM TcTyVar (TcTyVar, [Coercion]) + } +-- During constraint solving the set of Given constraints includes so-called +-- "canonical equalities": equalities of the form +-- +-- > var ~ typ (CTyEqCan) +-- > var ~ TyCon arg1 .. argN (CFunEqCan, the TyCon will be a type family) +-- +-- The problem we want to solve is recognizing if some type τ is of the form +-- +-- > TyCon arg1 arg2 .. argN (0 <= N) +-- +-- modulo those canonical equalities. We limit the scope of what we try to do: +-- +-- o We are only interested in recognizing types of the form above +-- (as opposed to general parsing-modulo-equalities). +-- o We will only use the canonical equalities as-is: we will not attempt to +-- derive any additional equalities from them (i.e. if, say, we know that +-- @x ~ T1@ and @x ~ T2@, we will not attempt to use the fact that this means +-- that @T1 ~ T2@, nor any derived conclusions thereof). We /will/ however +-- try to apply the canonical equalities as often as is necessary (e.g., +-- first applying @x ~ T y@, then applying @y ~ T2@). +-- +-- We solve this problem by constructing a 'TyConSubst': a possibly +-- non-deterministic substitution mapping type variables to types of the form +-- above (that is, a type constructor applied to some arguments). +-- +-- We detail the construction of this substitution below (see documentation of +-- 'Classified' and 'process'), but once we have this substitution, the +-- recognition problem becomes easy: +-- +-- 1. Without loss of generality, let τ be of the form @t arg1 arg2 .. argN@ +-- 2. If @t@ is a 'TyCon', we're done. +-- 3. Otherwise, if @t@ is a variable @x@, lookup @x@ in the substitution; if +-- there is one (or more) mappings for @x@, then we have successfully +-- recognized τ to be of the form above. There is no need to apply the +-- substitution repeatedly. +-- +-- The substitution is non-deterministic because there might be multiple +-- matches. For example, if we have +-- +-- > type family Foo where +-- > Foo = Int +-- +-- then we might well have equalities @x ~ Int, x ~ Foo@ in scope, and so a type +-- @x@ would match two different 'TyCon's. What we do know, however, is that if +-- τ matches both @t arg1 .. argN@ and @t' arg1' .. argM'@ (possibly @N /= M@), +-- then +-- +-- > t arg1 .. argN ~ t' arg1' .. argM' +-- +-- If @t == t'@, we can conclude that the arguments are equal only if @t@ is +-- injective. + +{------------------------------------------------------------------------------- + Basic functionality for working with 'TyConSubst' +-------------------------------------------------------------------------------} + +-- | Empty substitution +-- +-- The canonical variables map is established once when the initial substitution +-- is generated and not updated thereafter. +tyConSubstEmpty :: UniqFM TcTyVar (TcTyVar, [Coercion]) -> TyConSubst +tyConSubstEmpty canon = TyConSubst { + tyConSubstMap = UFM.emptyUFM + , tyConSubstCanon = canon + } + +-- | Lookup a variable in the substitution +tyConSubstLookup :: TcTyVar -> TyConSubst -> Maybe (NonEmpty (TyCon, [Type], [Coercion])) +tyConSubstLookup var TyConSubst{..} = + fmap ( \ (tc, tys, deps) -> (tc, tys, deps ++ deps')) <$> UFM.lookupUFM tyConSubstMap var' + where + var' :: TcTyVar + deps' :: [Coercion] + (var', deps') = canonicalize tyConSubstCanon var + +-- | Extend substitution with new bindings +tyConSubstExtend :: + [(TcTyVar, (TyCon, [Type]), [Coercion])] + -> TyConSubst -> TyConSubst +tyConSubstExtend new subst@TyConSubst{..} = subst { + tyConSubstMap = UFM.plusUFM_C (<>) + (UFM.listToUFM $ map aux new) + tyConSubstMap + } + where + aux :: (TcTyVar, (TyCon, [Type]), [Coercion]) + -> (TcTyVar, NonEmpty (TyCon, [Type] , [Coercion])) + aux (var, (tc, args), deps) = + let (var', deps') = canonicalize tyConSubstCanon var + in (var', (tc, args, deps ++ deps') :| []) + +{------------------------------------------------------------------------------- + Classification +-------------------------------------------------------------------------------} + +-- | Classified canonical nominal equality constraints. +-- +-- The first step in the construction of the 'TyConSubst' is to classify the +-- available canonical equalities as one of three categories, defined below. +data Classified = Classified { + -- | " Obviously " productive mappings + -- + -- An equality @var := TyCon args@ is productive, because as soon as we + -- apply it, we are done: we have successfully recognized a type as being + -- an application of a concrete type constructor (note that we only ever + -- apply the substitution to the head @t@ of a type @t args@, never to the + -- arguments). + classifiedProductive :: [(TcTyVar, (TyCon, [Type]), [Coercion])] + + -- | Extend equivalence class of variables + -- + -- An equality @var1 := var2@ we will regard as extending the equivalence + -- classes of variables (see 'constructEquivClasses'). + , classifiedExtendEquivClass :: [(TcTyVar, TcTyVar, [Coercion])] + + -- | Substitutions we need to reconsider later + -- + -- An equality @var1 := var2 args@ (with @args@ a non-empty list of + -- arguments) is most problematic. Applying it /may/ allow us to make + -- progress, but it may not (consider for example @var := var arg@). We + -- will reconsider such equalities at the end (see 'process'). + , classifiedReconsider :: [(TcTyVar, (TcTyVar, NonEmpty Type), [Coercion])] + } + +instance Semigroup Classified where + c1 <> c2 = Classified { + classifiedProductive = combine classifiedProductive + , classifiedExtendEquivClass = combine classifiedExtendEquivClass + , classifiedReconsider = combine classifiedReconsider + } + where + combine :: (Classified -> [a]) -> [a] + combine f = f c1 ++ f c2 + +instance Monoid Classified where + mempty = Classified [] [] [] + +productive :: TcTyVar -> (TyCon, [Type]) -> [Coercion] -> Classified +productive var app deps = mempty { + classifiedProductive = [(var, app, deps)] + } + +extendEquivClass :: TcTyVar -> TcTyVar -> [Coercion] -> Classified +extendEquivClass var var' deps = mempty { + classifiedExtendEquivClass = [(var, var', deps)] + } + +reconsider :: TcTyVar -> (TcTyVar, NonEmpty Type) -> [Coercion] -> Classified +reconsider var (var', args) deps = mempty { + classifiedReconsider = [(var, (var', args), deps)] + } + +-- | Classify a set of Given constraints. +-- +-- See 'Classified' for details. +classify :: [Ct] -> Classified +classify = go mempty + where + go :: Classified -> [Ct] -> Classified + go acc [] = acc + go acc (c:cs) = + let deps = [ctEvCoercion (ctEvidence c)] in + case isCanonicalVarEq c of + Just (var, splitAppTys -> (fn, args), NomEq) + | Just (tyCon, inner) <- splitTyConApp_maybe fn -> + go (productive var (tyCon, inner ++ args) deps <> acc) cs + | Just var' <- getTyVar_maybe fn, null args -> + go (extendEquivClass var var' deps <> acc) cs + | Just var' <- getTyVar_maybe fn, x:xs <- args -> + go (reconsider var (var', x :| xs) deps <> acc) cs + _otherwise -> + go acc cs + +{------------------------------------------------------------------------------- + Processing +-------------------------------------------------------------------------------} + +-- | Construct 'TyCon' substitution from classified nominal equality constraints. +-- +-- The difficult part in constructing this substitution are the equalities of +-- the form @var1 ~ var2 args@, which we ear-marked as "to reconsider" during +-- classification. +-- +-- We will do this iteratively: +-- +-- o We first construct a set of variable equivalence classes based on +-- 'classifiedExtendEquivClass' (using 'constructEquivClasses'), and use that +-- along with the "obviously productive" equalities ('classifiedProductive') +-- as the initial value of the accumulator (a 'TyConSubst'). +-- o We then repeatedly consider the remaining equalities. Whenever there is +-- a substitution available in the accumulator for @var2@ which turns it into +-- a type of the form @TyCon args'@, we add @var1 := TyCon args' args@ to the +-- accumulator. +-- o We keep doing this until we can make no more progress. +-- +-- The functions for working with 'TyConSubst' take the variable equivalence +-- classes into account, so we do not need to do that here. +-- +-- Two observations: +-- +-- o This process must terminate: there are a finite number of constraints +-- to consider, and whenever we apply a substitution from the accumulator, +-- we get an "obviously productive" substitution: we do not create new work +-- in the loop. +-- o We may end up ignoring some substitutions: if there is a substitution +-- @var1 := var2 args@ and we don't have any (productive) substitutions for +-- @var2@, we will just ignore it. +-- +-- A note on recursive bindings: a direct or indirect recursive binding +-- +-- > x := x args1 x := y args1 +-- > y := x args2 +-- +-- where @args1, args2@ are non-empty lists of arguments, /cannot/ be relevant: +-- if they were, that would imply that there is some type constructor (regular +-- datatype or type family) which can be applied to an arbitrary number of +-- arguments. Such datatypes or type families cannot be defined in Haskell. +-- We therefore take no special care in handling recursive bindings, other than +-- to note (as we did above) that the process must terminate. +process :: Classified -> TyConSubst +process Classified{..} = + go initSubst classifiedReconsider + where + initSubst :: TyConSubst + initSubst = + tyConSubstExtend classifiedProductive + $ tyConSubstEmpty (constructEquivClasses classifiedExtendEquivClass) + + go :: TyConSubst + -> [(TcTyVar, (TcTyVar, NonEmpty Type), [Coercion])] + -> TyConSubst + go acc rs = + let (prod, rest) = tryApply makeProductive rs in + if null prod + then acc -- No other equations can be made productive + else go (tyConSubstExtend prod acc) rest + where + makeProductive :: + (TcTyVar, (TcTyVar, NonEmpty Type), [Coercion]) + -> Maybe (NonEmpty (TcTyVar, (TyCon, [Type]), [Coercion])) + makeProductive (var, (var', args), deps) = do + tcApp <- tyConSubstLookup var' acc + return $ fmap aux tcApp + where + aux :: (TyCon, [Type], [Coercion]) -> (TcTyVar, (TyCon, [Type]), [Coercion]) + aux (tyCon, args', deps') = + (var, (tyCon, args' ++ toList args), deps ++ deps') + +-- | Construct a 'TyConSubst' from a collection of Given constraints. +mkTyConSubst :: [Ct] -> TyConSubst +mkTyConSubst = process . classify + +{------------------------------------------------------------------------------- + Using +-------------------------------------------------------------------------------} + +-- | Like 'splitTyConApp_maybe', but taking Given constraints into account. +-- +-- Alongside the @TyCon@ and its arguments, also returns a list of coercions +-- that embody the Givens that we depended on. +-- +-- Looks through type synonyms, just like 'splitTyConApp_maybe' does. +splitTyConApp_upTo :: TyConSubst -> Type -> Maybe (NonEmpty (TyCon, [Type], [Coercion])) +splitTyConApp_upTo subst typ = asum [ + -- Direct match + do (tyCon, inner) <- splitTyConApp_maybe fn + return ((tyCon, inner ++ args, []) :| []) + + -- Indirect match + , do var <- getTyVar_maybe fn + tcApps <- tyConSubstLookup var subst + return $ + fmap (\ (tc, inner, deps) -> (tc, inner ++ args, deps)) tcApps + ] + where + (fn, args) = splitAppTys typ + +{------------------------------------------------------------------------------- + Outputable +-------------------------------------------------------------------------------} + +instance Outputable TyConSubst where + ppr TyConSubst{..} = parens $ + text "TyConSubst" + <+> ppr tyConSubstMap + <+> ppr tyConSubstCanon + +{------------------------------------------------------------------------------- + Canonical equalities +-------------------------------------------------------------------------------} + +isCanonicalVarEq :: Ct -> Maybe (TcTyVar, Type, EqRel) +isCanonicalVarEq = \case +#if __GLASGOW_HASKELL__ < 902 + CTyEqCan { cc_tyvar, cc_rhs, cc_eq_rel } -> + Just (cc_tyvar, cc_rhs, cc_eq_rel) + CFunEqCan { cc_fsk, cc_fun, cc_tyargs } -> + Just (cc_fsk, mkTyConApp cc_fun cc_tyargs, NomEq) +#elif __GLASGOW_HASKELL__ < 907 + CEqCan { cc_lhs, cc_rhs, cc_eq_rel } + | TyVarLHS var <- cc_lhs + -> Just (var, cc_rhs, cc_eq_rel) + | TyFamLHS tyCon args <- cc_lhs + , Just var <- getTyVar_maybe cc_rhs + -> Just (var, mkTyConApp tyCon args, NomEq) +#else + CEqCan eqCt + | TyVarLHS var <- lhs + -> Just (var, rhs, rel) + | TyFamLHS tyCon args <- lhs + , Just var <- getTyVar_maybe rhs + -> Just (var, mkTyConApp tyCon args, rel) + where + lhs = eq_lhs eqCt + rhs = eq_rhs eqCt + rel = eq_eq_rel eqCt +#endif + -- Deal with CNonCanonical, which are produced by ghc-tcplugin-api + -- in GHC 9.0 and below due to 'unflattenCts'. + ct@(CNonCanonical {}) + | EqPred rel lhs rhs <- classifyPredType (ctPred ct) + -> if | Just tv <- getTyVar_maybe lhs + -> Just (tv, rhs, rel) + | Just tv <- getTyVar_maybe rhs + -> Just (tv, lhs, rel) + | otherwise + -> Nothing + _ -> Nothing + +{------------------------------------------------------------------------------- + Internal auxiliary +-------------------------------------------------------------------------------} + +-- | Attempt to apply a non-deterministic function to a list of values +-- +-- Returns the successful results as well as the inputs on which the function +-- failed. +tryApply :: forall a b. (a -> Maybe (NonEmpty b)) -> [a] -> ([b], [a]) +tryApply f = first (concat . map toList) . partitionEithers . map f' + where + f' :: a -> Either (NonEmpty b) a + f' a = maybe (Right a) Left $ f a + +{------------------------------------------------------------------------------- + Equivalence classes +-------------------------------------------------------------------------------} + +-- | Given a set of labelled equivalent pairs, map every value to a canonical +-- value in the same equivalence class, with the shortest path (as a list of +-- labels) connecting the value to the canonical value. +-- +-- Example with two equivalence classes: +-- +-- >>> constructEquivClasses [(1, 2, ["12"]), (4, 5, ["45"]), (2, 3, ["23"])] +-- fromList [(1,(1,[])),(2,(1,["12"])),(3,(1,["23","12"])),(4,(4,[])),(5,(4,["45"]))] +-- +-- Adding one element that connects both equivalence classes: +-- +-- >>> constructEquivClasses [(1, 2, ["12"]), (4, 5, ["45"]), (2, 3, ["23"]), (3, 4, ["34"])] +-- fromList [(1,(1,[])),(2,(1,["12"])),(3,(1,["23","12"])),(4,(1,["34","23","12"])),(5,(1,["45","34","23","12"]))] +constructEquivClasses :: forall a l. (Uniquable a, Monoid l) => [(a, a, l)] -> UniqFM a (a, l) +constructEquivClasses equivs = canonicals + where + neighbours :: UniqFM a (UniqFM a l) + neighbours = neighboursMap equivs + + allValues :: UniqSet a + allValues = UniqSet.mkUniqSet $ concat [ [x,y] | (x,y,_) <- equivs ] + + canonicals :: UniqFM a (a, l) + canonicals = go UFM.emptyUFM allValues + where + go :: UniqFM a (a, l) -> UniqSet a -> UniqFM a (a, l) + go acc vs = + case minViewUniqSet vs of + Nothing -> acc + Just (v, vs') -> + let + !comp = doComp + ( UFM.unitUFM v mempty ) + ( Seq.singleton $ getUnique v ) + in + go + ( UFM.plusUFM acc ( ( v , ) <$> comp ) ) + ( vs' `UniqSet.uniqSetMinusUFM` comp ) + + doComp :: UniqFM a l -> Seq Unique -> UniqFM a l + doComp !ds Seq.Empty = ds + doComp ds (v Seq.:<| vs) = + let + -- unvisited neighbours + !us = ( fromJust $ UFM.lookupUFM_Directly neighbours v ) `UFM.minusUFM` ds + !d = fromJust $ UFM.lookupUFM_Directly ds v + + !ds' = UFM.plusUFM ds ( UFM.mapUFM (<> d) us ) + !vs' = vs Seq.>< Seq.fromList ( UFM.nonDetKeysUFM us ) + in + doComp ds' vs' + +minViewUniqSet :: forall a. UniqSet a -> Maybe (a, UniqSet a) +minViewUniqSet s = + let m = UFM.ufmToIntMap $ UniqSet.getUniqSet s + in second + ( UniqSet.unsafeUFMToUniqSet + . +#if MIN_VERSION_ghc(8,11,0) + UFM.unsafeIntMapToUFM +#else + ( unsafeCoerce :: IntMap.IntMap a -> UniqFM a a ) +#endif + ) <$> +#if HAS_WORD64MAP + Word64Map.minView +#else + IntMap.minView +#endif + m + +neighboursMap :: forall a l. Uniquable a => [(a, a, l)] -> UniqFM a (UniqFM a l) +neighboursMap edges = foldr addEdge UFM.emptyUFM edges + where + addEdge :: (a, a, l) -> UniqFM a (UniqFM a l) -> UniqFM a (UniqFM a l) + addEdge (u, v, l) m + = UFM.addToUFM_C UFM.plusUFM + (UFM.addToUFM_C UFM.plusUFM m v (UFM.unitUFM u l)) + u (UFM.unitUFM v l) + +canonicalize :: (Uniquable a, Monoid l) => UniqFM a (a, l) -> a -> (a, l) +canonicalize canon x = UFM.lookupWithDefaultUFM canon (x, mempty) x