Commit 64cb4968 authored by Adam Gundry's avatar Adam Gundry

Implement typechecker plugins

Summary:
See https://ghc.haskell.org/trac/ghc/wiki/Plugins/TypeChecker

This is based on work by Iavor Diatchki and Eric Seidel.

Test Plan: validate

Reviewers: simonpj, austin

Reviewed By: austin

Subscribers: gridaphobe, yav, thomie, carter

Differential Revision: https://phabricator.haskell.org/D489

Conflicts:
	docs/users_guide/7.10.1-notes.xml
parent cce6318e
......@@ -318,6 +318,8 @@ Library
PackageConfig
Packages
PlatformConstants
Plugins
TcPluginM
PprTyThing
StaticFlags
SysTools
......
......@@ -3,6 +3,9 @@
-- | Dynamically lookup up values from modules and loading them.
module DynamicLoading (
#ifdef GHCI
-- * Loading plugins
loadPlugins,
-- * Force loading information
forceLoadModuleInterfaces,
forceLoadNameModuleInterface,
......@@ -25,13 +28,17 @@ import Finder ( findImportedModule, cannotFindModule )
import TcRnMonad ( initTcInteractive, initIfaceTcRn )
import LoadIface ( loadPluginInterface )
import RdrName ( RdrName, Provenance(..), ImportSpec(..), ImpDeclSpec(..)
, ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName, gre_name )
, ImpItemSpec(..), mkGlobalRdrEnv, lookupGRE_RdrName
, gre_name, mkRdrQual )
import OccName ( mkVarOcc )
import RnNames ( gresFromAvails )
import DynFlags
import Plugins ( Plugin, CommandLineOption )
import PrelNames ( pluginTyConName )
import HscTypes
import BasicTypes ( HValue )
import TypeRep ( pprTyThingCategory )
import TypeRep ( mkTyConTy, pprTyThingCategory )
import Type ( Type, eqType )
import TyCon ( TyCon )
import Name ( Name, nameModule_maybe )
......@@ -48,6 +55,44 @@ import Data.Maybe ( mapMaybe )
import GHC.Exts ( unsafeCoerce# )
loadPlugins :: HscEnv -> IO [(ModuleName, Plugin, [CommandLineOption])]
loadPlugins hsc_env
= do { plugins <- mapM (loadPlugin hsc_env) to_load
; return $ map attachOptions $ to_load `zip` plugins }
where
dflags = hsc_dflags hsc_env
to_load = pluginModNames dflags
attachOptions (mod_nm, plug) = (mod_nm, plug, options)
where
options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
, opt_mod_nm == mod_nm ]
loadPlugin :: HscEnv -> ModuleName -> IO Plugin
loadPlugin hsc_env mod_name
= do { let plugin_rdr_name = mkRdrQual mod_name (mkVarOcc "plugin")
dflags = hsc_dflags hsc_env
; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name
plugin_rdr_name
; case mb_name of {
Nothing ->
throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
[ ptext (sLit "The module"), ppr mod_name
, ptext (sLit "did not export the plugin name")
, ppr plugin_rdr_name ]) ;
Just name ->
do { plugin_tycon <- forceLoadTyCon hsc_env pluginTyConName
; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)
; case mb_plugin of
Nothing ->
throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
[ ptext (sLit "The value"), ppr name
, ptext (sLit "did not have the type")
, ppr pluginTyConName, ptext (sLit "as required")])
Just plugin -> return plugin } } }
-- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used
-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded.
forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO ()
......
......@@ -8,9 +8,9 @@
-- Particularly interesting modules for plugin writers include
-- "CoreSyn" and "CoreMonad".
module GhcPlugins(
module CoreMonad,
module Plugins,
module RdrName, module OccName, module Name, module Var, module Id, module IdInfo,
module CoreSyn, module Literal, module DataCon,
module CoreMonad, module CoreSyn, module Literal, module DataCon,
module CoreUtils, module MkCore, module CoreFVs, module CoreSubst,
module Rules, module Annotations,
module DynFlags, module Packages,
......@@ -23,7 +23,7 @@ module GhcPlugins(
) where
-- Plugin stuff itself
import CoreMonad
import Plugins
-- Variable naming
import RdrName
......@@ -34,6 +34,7 @@ import Id hiding ( lazySetIdInfo, setIdExported, setIdNotExported {- all
import IdInfo
-- Core
import CoreMonad
import CoreSyn
import Literal
import DataCon
......
module Plugins (
Plugin(..), CommandLineOption,
defaultPlugin
) where
import CoreMonad ( CoreToDo, CoreM )
import TcRnTypes ( TcPlugin )
-- | Command line options gathered from the -PModule.Name:stuff syntax
-- are given to you as this type
type CommandLineOption = String
-- | 'Plugin' is the core compiler plugin data type. Try to avoid
-- constructing one of these directly, and just modify some fields of
-- 'defaultPlugin' instead: this is to try and preserve source-code
-- compatability when we add fields to this.
--
-- Nonetheless, this API is preliminary and highly likely to change in
-- the future.
data Plugin = Plugin {
installCoreToDos :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
-- ^ Modify the Core pipeline that will be used for compilation.
-- This is called as the Core pipeline is built for every module
-- being compiled, and plugins get the opportunity to modify the
-- pipeline in a nondeterministic order.
, tcPlugin :: [CommandLineOption] -> Maybe TcPlugin
-- ^ An optional typechecker plugin, which may modify the
-- behaviour of the constraint solver.
}
-- | Default plugin: does nothing at all! For compatability reasons
-- you should base all your plugin definitions on this default value.
defaultPlugin :: Plugin
defaultPlugin = Plugin {
installCoreToDos = const return
, tcPlugin = const Nothing
}
......@@ -1161,10 +1161,10 @@ ipClassName :: Name
ipClassName = clsQual gHC_IP (fsLit "IP") ipClassNameKey
-- plugins
cORE_MONAD :: Module
cORE_MONAD = mkThisGhcModule (fsLit "CoreMonad")
pLUGINS :: Module
pLUGINS = mkThisGhcModule (fsLit "Plugins")
pluginTyConName :: Name
pluginTyConName = tcQual cORE_MONAD (fsLit "Plugin") pluginTyConKey
pluginTyConName = tcQual pLUGINS (fsLit "Plugin") pluginTyConKey
\end{code}
%************************************************************************
......
......@@ -14,8 +14,7 @@ module CoreMonad (
pprPassDetails,
-- * Plugins
PluginPass, Plugin(..), CommandLineOption,
defaultPlugin, bindsOnlyPass,
PluginPass, bindsOnlyPass,
-- * Counting
SimplCount, doSimplTick, doFreeSimplTick, simplCountN,
......@@ -478,30 +477,6 @@ to switch off those rules until after floating.
%************************************************************************
\begin{code}
-- | Command line options gathered from the -PModule.Name:stuff syntax are given to you as this type
type CommandLineOption = String
-- | 'Plugin' is the core compiler plugin data type. Try to avoid
-- constructing one of these directly, and just modify some fields of
-- 'defaultPlugin' instead: this is to try and preserve source-code
-- compatability when we add fields to this.
--
-- Nonetheless, this API is preliminary and highly likely to change in the future.
data Plugin = Plugin {
installCoreToDos :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
-- ^ Modify the Core pipeline that will be used for compilation.
-- This is called as the Core pipeline is built for every module
-- being compiled, and plugins get the opportunity to modify
-- the pipeline in a nondeterministic order.
}
-- | Default plugin: does nothing at all! For compatability reasons you should base all your
-- plugin definitions on this default value.
defaultPlugin :: Plugin
defaultPlugin = Plugin {
installCoreToDos = const return
}
-- | A description of the plugin pass itself
type PluginPass = ModGuts -> CoreM ModGuts
......
......@@ -52,13 +52,8 @@ import Outputable
import Control.Monad
#ifdef GHCI
import Type ( mkTyConTy )
import RdrName ( mkRdrQual )
import OccName ( mkVarOcc )
import PrelNames ( pluginTyConName )
import DynamicLoading ( forceLoadTyCon, lookupRdrNameInModuleForPlugins, getValueSafely )
import Module ( ModuleName )
import Panic
import DynamicLoading ( loadPlugins )
import Plugins ( installCoreToDos )
#endif
\end{code}
......@@ -77,7 +72,7 @@ core2core hsc_env guts
; let builtin_passes = getCoreToDo dflags
;
; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod print_unqual $
do { all_passes <- addPluginPasses dflags builtin_passes
do { all_passes <- addPluginPasses builtin_passes
; runCorePasses all_passes guts }
; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats
......@@ -321,49 +316,16 @@ getCoreToDo dflags
Loading plugins
\begin{code}
addPluginPasses :: DynFlags -> [CoreToDo] -> CoreM [CoreToDo]
addPluginPasses :: [CoreToDo] -> CoreM [CoreToDo]
#ifndef GHCI
addPluginPasses _ builtin_passes = return builtin_passes
addPluginPasses builtin_passes = return builtin_passes
#else
addPluginPasses dflags builtin_passes
addPluginPasses builtin_passes
= do { hsc_env <- getHscEnv
; named_plugins <- liftIO (loadPlugins hsc_env)
; foldM query_plug builtin_passes named_plugins }
where
query_plug todos (mod_nm, plug)
= installCoreToDos plug options todos
where
options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags
, opt_mod_nm == mod_nm ]
loadPlugins :: HscEnv -> IO [(ModuleName, Plugin)]
loadPlugins hsc_env
= do { let to_load = pluginModNames (hsc_dflags hsc_env)
; plugins <- mapM (loadPlugin hsc_env) to_load
; return $ to_load `zip` plugins }
loadPlugin :: HscEnv -> ModuleName -> IO Plugin
loadPlugin hsc_env mod_name
= do { let plugin_rdr_name = mkRdrQual mod_name (mkVarOcc "plugin")
dflags = hsc_dflags hsc_env
; mb_name <- lookupRdrNameInModuleForPlugins hsc_env mod_name plugin_rdr_name
; case mb_name of {
Nothing ->
throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
[ ptext (sLit "The module"), ppr mod_name
, ptext (sLit "did not export the plugin name")
, ppr plugin_rdr_name ]) ;
Just name ->
do { plugin_tycon <- forceLoadTyCon hsc_env pluginTyConName
; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon)
; case mb_plugin of
Nothing ->
throwGhcExceptionIO (CmdLineError $ showSDoc dflags $ hsep
[ ptext (sLit "The value"), ppr name
, ptext (sLit "did not have the type")
, ppr pluginTyConName, ptext (sLit "as required")])
Just plugin -> return plugin } } }
query_plug todos (_, plug, options) = installCoreToDos plug options todos
#endif
\end{code}
......
......@@ -39,11 +39,11 @@ import TcErrors
import TcSMonad
import Bag
import Data.List( partition )
import Data.List( partition, foldl', deleteFirstsBy )
import VarEnv
import Control.Monad( when, unless, forM )
import Control.Monad( when, unless, forM, foldM )
import Pair (Pair(..))
import Unique( hasKey )
import FastString ( sLit )
......@@ -119,11 +119,15 @@ solveFlatGivens loc givens
| null givens -- Shortcut for common case
= return ()
| otherwise
= solveFlats (listToBag (map mk_given_ct givens))
= go (map mk_given_ct givens)
where
mk_given_ct ev_id = mkNonCanonical (CtGiven { ctev_evtm = EvId ev_id
, ctev_pred = evVarPred ev_id
, ctev_loc = loc })
go givens = do { solveFlats (listToBag givens)
; new_givens <- runTcPluginsGiven
; when (notNull new_givens) (go new_givens)
}
solveFlatWanteds :: Cts -> TcS WantedConstraints
solveFlatWanteds wanteds
......@@ -134,9 +138,14 @@ solveFlatWanteds wanteds
; zonked <- zonkFlats (others `andCts` unflattened_eqs)
-- Postcondition is that the wl_flats are zonked
; return (WC { wc_flat = zonked
, wc_insol = insols
, wc_impl = implics }) }
; (wanteds', insols', rerun) <- runTcPluginsWanted zonked
; if rerun then do { updInertTcS prepareInertsForImplications
; solveFlatWanteds wanteds' }
else return (WC { wc_flat = wanteds'
, wc_insol = insols' `unionBags` insols
, wc_impl = implics }) }
-- The main solver loop implements Note [Basic Simplifier Plan]
---------------------------------------------------------------
......@@ -162,6 +171,127 @@ solveFlats cts
NextWorkItem ct -- More work, loop around!
-> do { runSolverPipeline thePipeline ct; solve_loop max_depth } }
-- | Extract the (inert) givens and invoke the plugins on them.
-- Remove solved givens from the inert set and emit insolubles, but
-- return new work produced so that 'solveFlatGivens' can feed it back
-- into the main solver.
runTcPluginsGiven :: TcS [Ct]
runTcPluginsGiven = do
(givens,_,_) <- fmap splitInertCans getInertCans
if null givens
then return []
else do
p <- runTcPlugins (givens,[],[])
let (solved_givens, _, _) = pluginSolvedCts p
updInertCans (removeInertCts solved_givens)
mapM_ emitInsoluble (pluginBadCts p)
return (pluginNewCts p)
-- | Given a bag of (flattened, zonked) wanteds, invoke the plugins on
-- them and produce an updated bag of wanteds (possibly with some new
-- work) and a bag of insolubles. The boolean indicates whether
-- 'solveFlatWanteds' should feed the updated wanteds back into the
-- main solver.
runTcPluginsWanted :: Cts -> TcS (Cts, Cts, Bool)
runTcPluginsWanted zonked_wanteds
| isEmptyBag zonked_wanteds = return (zonked_wanteds, emptyBag, False)
| otherwise = do
(given,derived,_) <- fmap splitInertCans getInertCans
p <- runTcPlugins (given, derived, bagToList zonked_wanteds)
let (solved_givens, solved_deriveds, solved_wanteds) = pluginSolvedCts p
(_, _, wanteds) = pluginInputCts p
updInertCans (removeInertCts $ solved_givens ++ solved_deriveds)
mapM_ setEv solved_wanteds
return ( listToBag $ pluginNewCts p ++ wanteds
, listToBag $ pluginBadCts p
, notNull (pluginNewCts p) )
where
setEv :: (EvTerm,Ct) -> TcS ()
setEv (ev,ct) = case ctEvidence ct of
CtWanted {ctev_evar = evar} -> setEvBind evar ev
_ -> panic "runTcPluginsWanted.setEv: attempt to solve non-wanted!"
-- | A triple of (given, derived, wanted) constraints to pass to plugins
type SplitCts = ([Ct], [Ct], [Ct])
-- | A solved triple of constraints, with evidence for wanteds
type SolvedCts = ([Ct], [Ct], [(EvTerm,Ct)])
-- | Represents collections of constraints generated by typechecker
-- plugins
data TcPluginProgress = TcPluginProgress
{ pluginInputCts :: SplitCts
-- ^ Original inputs to the plugins with solved/bad constraints
-- removed, but otherwise unmodified
, pluginSolvedCts :: SolvedCts
-- ^ Constraints solved by plugins
, pluginBadCts :: [Ct]
-- ^ Constraints reported as insoluble by plugins
, pluginNewCts :: [Ct]
-- ^ New constraints emitted by plugins
}
-- | Starting from a triple of (given, derived, wanted) constraints,
-- invoke each of the typechecker plugins in turn and return
--
-- * the remaining unmodified constraints,
-- * constraints that have been solved,
-- * constraints that are insoluble, and
-- * new work.
--
-- Note that new work generated by one plugin will not be seen by
-- other plugins on this pass (but the main constraint solver will be
-- re-invoked and they will see it later). There is no check that new
-- work differs from the original constraints supplied to the plugin:
-- the plugin itself should perform this check if necessary.
runTcPlugins :: SplitCts -> TcS TcPluginProgress
runTcPlugins all_cts = do
gblEnv <- getGblEnv
foldM do_plugin initialProgress (tcg_tc_plugins gblEnv)
where
do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress
do_plugin p solver = do
result <- runTcPluginTcS (uncurry3 solver (pluginInputCts p))
return $ progress p result
progress :: TcPluginProgress -> TcPluginResult -> TcPluginProgress
progress p (TcPluginContradiction bad_cts) =
p { pluginInputCts = discard bad_cts (pluginInputCts p)
, pluginBadCts = bad_cts ++ pluginBadCts p
}
progress p (TcPluginOk solved_cts new_cts) =
p { pluginInputCts = discard (map snd solved_cts) (pluginInputCts p)
, pluginSolvedCts = add solved_cts (pluginSolvedCts p)
, pluginNewCts = new_cts ++ pluginNewCts p
}
initialProgress = TcPluginProgress all_cts ([], [], []) [] []
discard :: [Ct] -> SplitCts -> SplitCts
discard cts (xs, ys, zs) =
(xs `without` cts, ys `without` cts, zs `without` cts)
without :: [Ct] -> [Ct] -> [Ct]
without = deleteFirstsBy eqCt
eqCt :: Ct -> Ct -> Bool
eqCt c c' = case (ctEvidence c, ctEvidence c') of
(CtGiven pred _ _, CtGiven pred' _ _) -> pred `eqType` pred'
(CtWanted pred _ _, CtWanted pred' _ _) -> pred `eqType` pred'
(CtDerived pred _ , CtDerived pred' _ ) -> pred `eqType` pred'
(_ , _ ) -> False
add :: [(EvTerm,Ct)] -> SolvedCts -> SolvedCts
add xs scs = foldl' addOne scs xs
addOne :: SolvedCts -> (EvTerm,Ct) -> SolvedCts
addOne (givens, deriveds, wanteds) (ev,ct) = case ctEvidence ct of
CtGiven {} -> (ct:givens, deriveds, wanteds)
CtDerived{} -> (givens, ct:deriveds, wanteds)
CtWanted {} -> (givens, deriveds, (ev,ct):wanteds)
type WorkItem = Ct
type SimplifierStage = WorkItem -> TcS (StopOrContinue Ct)
......
{-# LANGUAGE CPP #-}
-- | This module provides an interface for typechecker plugins to
-- access select functions of the 'TcM', principally those to do with
-- reading parts of the state.
module TcPluginM (
#ifdef GHCI
-- * Basic TcPluginM functionality
TcPluginM,
tcPluginIO,
tcPluginTrace,
unsafeTcPluginTcM,
-- * Lookup
lookupRdrName,
tcLookupGlobal,
tcLookupTyCon,
tcLookupDataCon,
tcLookupClass,
tcLookup,
tcLookupId,
-- * Getting the TcM state
getTopEnv,
getEnvs,
getInstEnvs,
getFamInstEnvs,
-- * Type variables
newFlexiTyVar,
isTouchableTcPluginM,
-- * Zonking
zonkTcType,
zonkCt
#endif
) where
#ifdef GHCI
import qualified TcRnMonad
import qualified TcEnv
import qualified TcMType
import qualified Inst
import qualified FamInst
import FamInstEnv ( FamInstEnv )
import TcRnMonad ( TcGblEnv, TcLclEnv, Ct, TcPluginM
, unsafeTcPluginTcM, liftIO, traceTc )
import TcMType ( TcTyVar, TcType )
import TcEnv ( TcTyThing )
import Module
import Name
import RdrName
import TyCon
import DataCon
import Class
import HscTypes
import Outputable
import Type
import DynamicLoading
import Id
import InstEnv
-- | Perform some IO, typically to interact with an external tool.
tcPluginIO :: IO a -> TcPluginM a
tcPluginIO a = unsafeTcPluginTcM (liftIO a)
-- | Output useful for debugging the compiler.
tcPluginTrace :: String -> SDoc -> TcPluginM ()
tcPluginTrace a b = unsafeTcPluginTcM (traceTc a b)
lookupRdrName :: ModuleName -> RdrName -> TcPluginM (Maybe Name)
lookupRdrName mod rdr = do
hsc_env <- getTopEnv
tcPluginIO $ lookupRdrNameInModuleForPlugins hsc_env mod rdr
tcLookupGlobal :: Name -> TcPluginM TyThing
tcLookupGlobal = unsafeTcPluginTcM . TcEnv.tcLookupGlobal
tcLookupTyCon :: Name -> TcPluginM TyCon
tcLookupTyCon = unsafeTcPluginTcM . TcEnv.tcLookupTyCon
tcLookupDataCon :: Name -> TcPluginM DataCon
tcLookupDataCon = unsafeTcPluginTcM . TcEnv.tcLookupDataCon
tcLookupClass :: Name -> TcPluginM Class
tcLookupClass = unsafeTcPluginTcM . TcEnv.tcLookupClass
tcLookup :: Name -> TcPluginM TcTyThing
tcLookup = unsafeTcPluginTcM . TcEnv.tcLookup
tcLookupId :: Name -> TcPluginM Id
tcLookupId = unsafeTcPluginTcM . TcEnv.tcLookupId
getTopEnv :: TcPluginM HscEnv
getTopEnv = unsafeTcPluginTcM TcRnMonad.getTopEnv
getEnvs :: TcPluginM (TcGblEnv, TcLclEnv)
getEnvs = unsafeTcPluginTcM TcRnMonad.getEnvs
getInstEnvs :: TcPluginM (InstEnv, InstEnv)
getInstEnvs = unsafeTcPluginTcM Inst.tcGetInstEnvs
getFamInstEnvs :: TcPluginM (FamInstEnv, FamInstEnv)
getFamInstEnvs = unsafeTcPluginTcM FamInst.tcGetFamInstEnvs
newFlexiTyVar :: Kind -> TcPluginM TcTyVar
newFlexiTyVar = unsafeTcPluginTcM . TcMType.newFlexiTyVar
isTouchableTcPluginM :: TcTyVar -> TcPluginM Bool
isTouchableTcPluginM = unsafeTcPluginTcM . TcRnMonad.isTouchableTcM
zonkTcType :: TcType -> TcPluginM TcType
zonkTcType = unsafeTcPluginTcM . TcMType.zonkTcType
zonkCt :: Ct -> TcPluginM Ct
zonkCt = unsafeTcPluginTcM . TcMType.zonkCt
#endif
......@@ -20,7 +20,7 @@ module TcRnDriver (
tcRnLookupName,
tcRnGetInfo,
tcRnModule, tcRnModuleTcRnM,
tcTopSrcDecls
tcTopSrcDecls,
) where
#ifdef GHCI
......@@ -93,6 +93,8 @@ import RnExpr
import MkId
import TidyPgm ( globaliseAndTidyId )
import TysWiredIn ( unitTy, mkListTy )
import DynamicLoading ( loadPlugins )
import Plugins ( tcPlugin )
#endif
import TidyPgm ( mkBootModDetailsTc )
......@@ -134,8 +136,11 @@ tcRnModule hsc_env hsc_src save_rn_syntax
Just (L mod_loc mod) -- The normal case
-> (mkModule this_pkg mod, mod_loc) } ;
; initTc hsc_env hsc_src save_rn_syntax this_mod $
tcRnModuleTcRnM hsc_env hsc_src parsedModule pair }
; res <- initTc hsc_env hsc_src save_rn_syntax this_mod $
withTcPlugins hsc_env $
tcRnModuleTcRnM hsc_env hsc_src parsedModule pair
; return res
}
-- To be called at the beginning of renaming hsig files.
-- If we're processing a signature, load up the RdrEnv
......@@ -1380,7 +1385,7 @@ runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a)
-- Initialise the tcg_inst_env with instances from all home modules.
-- This mimics the more selective call to hptInstances in tcRnImports
runTcInteractive hsc_env thing_inside
= initTcInteractive hsc_env $
= initTcInteractive hsc_env $ withTcPlugins hsc_env $
do { traceTc "setInteractiveContext" $
vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))
, text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts)
......@@ -2090,3 +2095,38 @@ ppr_tydecls tycons
where
ppr_tycon tycon = vcat [ ppr (tyThingToIfaceDecl (ATyCon tycon)) ]
\end{code}
********************************************************************************
Type Checker Plugins
********************************************************************************
\begin{code}
withTcPlugins :: HscEnv -> TcM a -> TcM a
withTcPlugins hsc_env m =
do plugins <- liftIO (loadTcPlugins hsc_env)
case plugins of
[] -> m -- Common fast case
_ -> do (solvers,stops) <- unzip `fmap` mapM startPlugin plugins
res <- updGblEnv (\e -> e { tcg_tc_plugins = solvers }) m
mapM_ runTcPluginM stops
return res
where
startPlugin (TcPlugin start solve stop) =
do s <- runTcPluginM start
return (solve s, stop s)
loadTcPlugins :: HscEnv -> IO [TcPlugin]
#ifndef GHCI
loadTcPlugins _ = return []