diff options
Diffstat (limited to 'compiler/GHC')
| -rw-r--r-- | compiler/GHC/Tc/Module.hs | 7 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Solver/Interact.hs | 9 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Solver/Monad.hs | 10 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Types.hs | 5 |
4 files changed, 19 insertions, 12 deletions
diff --git a/compiler/GHC/Tc/Module.hs b/compiler/GHC/Tc/Module.hs index c11639725e..a6e9891b14 100644 --- a/compiler/GHC/Tc/Module.hs +++ b/compiler/GHC/Tc/Module.hs @@ -3115,9 +3115,8 @@ withTcPlugins hsc_env m = case catMaybes $ mapPlugins (hsc_plugins hsc_env) tcPlugin of [] -> m -- Common fast case plugins -> do - ev_binds_var <- newTcEvBinds (solvers, rewriters, stops) <- - unzip3 `fmap` mapM (start_plugin ev_binds_var) plugins + unzip3 `fmap` mapM start_plugin plugins let rewritersUniqFM :: UniqFM TyCon [TcPluginRewriter] !rewritersUniqFM = sequenceUFMList rewriters @@ -3131,9 +3130,9 @@ withTcPlugins hsc_env m = Left _ -> failM Right res -> return res where - start_plugin ev_binds_var (TcPlugin start solve rewrite stop) = + start_plugin (TcPlugin start solve rewrite stop) = do s <- runTcPluginM start - return (solve s ev_binds_var, rewrite s, stop s) + return (solve s, rewrite s, stop s) withDefaultingPlugins :: HscEnv -> TcM a -> TcM a withDefaultingPlugins hsc_env m = diff --git a/compiler/GHC/Tc/Solver/Interact.hs b/compiler/GHC/Tc/Solver/Interact.hs index 5adccd835c..bac38d8f0a 100644 --- a/compiler/GHC/Tc/Solver/Interact.hs +++ b/compiler/GHC/Tc/Solver/Interact.hs @@ -268,11 +268,12 @@ getTcPluginSolvers -- the plugin itself should perform this check if necessary. runTcPluginSolvers :: [TcPluginSolver] -> SplitCts -> TcS TcPluginProgress runTcPluginSolvers solvers all_cts - = foldM do_plugin initialProgress solvers + = do { ev_binds_var <- getTcEvBindsVar + ; foldM (do_plugin ev_binds_var) initialProgress solvers } where - do_plugin :: TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress - do_plugin p solver = do - result <- runTcPluginTcS (uncurry solver (pluginInputCts p)) + do_plugin :: EvBindsVar -> TcPluginProgress -> TcPluginSolver -> TcS TcPluginProgress + do_plugin ev_binds_var p solver = do + result <- runTcPluginTcS (uncurry (solver ev_binds_var) (pluginInputCts p)) return $ progress p result progress :: TcPluginProgress -> TcPluginSolveResult -> TcPluginProgress diff --git a/compiler/GHC/Tc/Solver/Monad.hs b/compiler/GHC/Tc/Solver/Monad.hs index 764f1eb454..26af2ff689 100644 --- a/compiler/GHC/Tc/Solver/Monad.hs +++ b/compiler/GHC/Tc/Solver/Monad.hs @@ -507,7 +507,8 @@ getInertGivens :: TcS [Ct] -- Returns the Given constraints in the inert set getInertGivens = do { inerts <- getInertCans - ; let all_cts = foldDicts (:) (inert_dicts inerts) + ; let all_cts = foldIrreds (:) (inert_irreds inerts) + $ foldDicts (:) (inert_dicts inerts) $ foldFunEqs (++) (inert_funeqs inerts) $ foldDVarEnv (++) [] (inert_eqs inerts) ; return (filter isGivenCt all_cts) } @@ -645,10 +646,15 @@ removeInertCt is ct = CEqCan { cc_lhs = lhs, cc_rhs = rhs } -> delEq is lhs rhs + CIrredCan {} -> is { inert_irreds = filterBag (not . eqCt ct) $ inert_irreds is } + CQuantCan {} -> panic "removeInertCt: CQuantCan" - CIrredCan {} -> panic "removeInertCt: CIrredEvCan" CNonCanonical {} -> panic "removeInertCt: CNonCanonical" +eqCt :: Ct -> Ct -> Bool +-- Equality via ctEvId +eqCt c c' = ctEvId c == ctEvId c' + -- | Looks up a family application in the inerts. lookupFamAppInert :: (CtFlavourRole -> Bool) -- can it rewrite the target? -> TyCon -> [Type] -> TcS (Maybe (Reduction, CtFlavourRole)) diff --git a/compiler/GHC/Tc/Types.hs b/compiler/GHC/Tc/Types.hs index 31e5f8ceed..c56cbc1322 100644 --- a/compiler/GHC/Tc/Types.hs +++ b/compiler/GHC/Tc/Types.hs @@ -1633,7 +1633,8 @@ Constraint Solver Plugins -- and Wanted constraints, and should return a 'TcPluginSolveResult' -- indicating which Wanted constraints it could solve, or whether any are -- insoluble. -type TcPluginSolver = [Ct] -- ^ Givens +type TcPluginSolver = EvBindsVar + -> [Ct] -- ^ Givens -> [Ct] -- ^ Wanteds -> TcPluginM TcPluginSolveResult @@ -1663,7 +1664,7 @@ data TcPlugin = forall s. TcPlugin { tcPluginInit :: TcPluginM s -- ^ Initialize plugin, when entering type-checker. - , tcPluginSolve :: s -> EvBindsVar -> TcPluginSolver + , tcPluginSolve :: s -> TcPluginSolver -- ^ Solve some constraints. -- -- This function will be invoked at two points in the constraint solving |