Fix Trac #4361: be more discerning when inferring types

[ghc-hetmet.git] / compiler / typecheck / TcSimplify.lhs

diff --git a/compiler/typecheck/TcSimplify.lhs b/compiler/typecheck/TcSimplify.lhs
index 57e9125..f66cc07 100644 (file)
--- a/compiler/typecheck/TcSimplify.lhs
+++ b/compiler/typecheck/TcSimplify.lhs
@@ -185,7 +185,7 @@ simplifyInfer :: Bool                   -- Apply monomorphism restriction
                       TcEvBinds)    -- ... binding these evidence variables
 simplifyInfer apply_mr tau_tvs wanted
   | isEmptyBag wanted    -- Trivial case is quite common
-  = do { zonked_tau_tvs <- zonkTcTyVarsAndFV (varSetElems tau_tvs)
+  = do { zonked_tau_tvs <- zonkTcTyVarsAndFV tau_tvs
        ; gbl_tvs        <- tcGetGlobalTyVars        -- Already zonked
        ; qtvs <- zonkQuantifiedTyVars (varSetElems (zonked_tau_tvs `minusVarSet` gbl_tvs))
        ; return (qtvs, [], emptyTcEvBinds) }
@@ -198,12 +198,26 @@ simplifyInfer apply_mr tau_tvs wanted
              , ptext (sLit "tau_tvs =") <+> ppr tau_tvs
              ]
 
-       ; (simple_wanted, tc_binds) 
-              <- simplifyAsMuchAsPossible SimplInfer zonked_wanted
-
+            -- Make a guess at the quantified type variables
+            -- Then split the constraints on the baisis of those tyvars
+            -- to avoid unnecessarily simplifying a class constraint
+            -- See Note [Avoid unecessary constraint simplification]
+       ; gbl_tvs <- tcGetGlobalTyVars
+       ; zonked_tau_tvs <- zonkTcTyVarsAndFV tau_tvs
+       ; let proto_qtvs = zonked_tau_tvs `minusVarSet` gbl_tvs
+             (perhaps_bound, surely_free) 
+                  = partitionBag (quantifyMeWC proto_qtvs) zonked_wanted
+       ; emitConstraints surely_free
+
+                     -- Now simplify the possibly-bound constraints
+       ; (simplified_perhaps_bound, tc_binds) 
+              <- simplifyAsMuchAsPossible SimplInfer perhaps_bound
+
+             -- Sigh: must re-zonk because because simplifyAsMuchAsPossible
+             --       may have done some unification
        ; gbl_tvs <- tcGetGlobalTyVars
-       ; zonked_tau_tvs <- zonkTcTyVarsAndFV (varSetElems tau_tvs)
-       ; zonked_simples <- mapBagM zonkWantedEvVar simple_wanted
+       ; zonked_tau_tvs <- zonkTcTyVarsAndFV tau_tvs
+       ; zonked_simples <- mapBagM zonkWantedEvVar simplified_perhaps_bound
        ; let qtvs = findQuantifiedTyVars apply_mr zonked_simples zonked_tau_tvs gbl_tvs
              (bound, free) | apply_mr  = (emptyBag, zonked_simples)
                            | otherwise = partitionBag (quantifyMe qtvs) zonked_simples
@@ -236,7 +250,7 @@ simplifyAsMuchAsPossible ctxt wanteds
               simplifyApproxLoop 0 wanteds
 
              -- Report any errors
-       ; mapBagM_ reportUnsolvedImplication unsolved_implics
+       ; reportUnsolved (emptyBag, unsolved_implics)
 
        ; let final_wanted_evvars = mapBag deCanonicaliseWanted unsolved_flats
        ; return (final_wanted_evvars, ev_binds) }
@@ -337,8 +351,32 @@ quantifyMe qtvs wev
   | otherwise    = tyVarsOfPred pred `intersectsVarSet` qtvs
   where
     pred = wantedEvVarPred wev
+
+quantifyMeWC :: TyVarSet -> WantedConstraint -> Bool
+quantifyMeWC qtvs (WcImplic implic)
+  = anyBag (quantifyMeWC (qtvs `minusVarSet` ic_skols implic)) (ic_wanted implic)
+quantifyMeWC qtvs (WcEvVar wev)
+  = quantifyMe qtvs wev
 \end{code}
 
+Note [Avoid unecessary constraint simplification]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When inferring the type of a let-binding, with simplifyInfer,
+try to avoid unnecessariliy simplifying class constraints.
+Doing so aids sharing, but it also helps with delicate 
+situations like
+   instance C t => C [t] where ..
+   f :: C [t] => ....
+   f x = let g y = ...(constraint C [t])... 
+         in ...
+When inferring a type for 'g', we don't want to apply the
+instance decl, because then we can't satisfy (C t).  So we
+just notice that g isn't quantified over 't' and partition
+the contraints before simplifying.
+
+This only half-works, but then let-generalisation only half-works.
+
+
 Note [Inheriting implicit parameters]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Consider this:
@@ -405,7 +443,7 @@ simplifySuperClass self wanteds
        ; (unsolved, ev_binds) 
              <- runTcS SimplCheck emptyVarSet $
                do { can_self <- canGivens loc [self]
-                  ; let inert = foldlBag extendInertSet emptyInert can_self
+                  ; let inert = foldlBag updInertSet emptyInert can_self
                     -- No need for solveInteract; we know it's inert
 
                   ; solveWanteds inert wanteds }
@@ -512,7 +550,7 @@ simplifyRule name tv_bndrs lhs_wanted rhs_wanted
        ; rhs_binds_var@(EvBindsVar evb_ref _)  <- newTcEvBinds
        ; loc        <- getCtLoc (RuleSkol name)
        ; rhs_binds1 <- simplifyCheck SimplCheck $ unitBag $ WcImplic $ 
-             Implic { ic_env_tvs = emptyVarSet   -- No untouchables
+             Implic { ic_untch = emptyVarSet     -- No untouchables
                    , ic_env = emptyNameEnv
                    , ic_skols = mkVarSet tv_bndrs
                    , ic_scoped = panic "emitImplication"
@@ -642,12 +680,12 @@ solveImplication :: InertSet     -- Given
 -- 
 -- Precondition: everything is zonked by now
 solveImplication inert 
-     imp@(Implic { ic_env_tvs = untch 
-                 , ic_binds   = ev_binds
-                 , ic_skols   = skols 
-                 , ic_given   = givens
+     imp@(Implic { ic_untch  = untch 
+                 , ic_binds  = ev_binds
+                 , ic_skols  = skols 
+                 , ic_given  = givens
                  , ic_wanted = wanteds
-                 , ic_loc = loc })
+                 , ic_loc    = loc })
   = nestImplicTcS ev_binds untch $
     do { traceTcS "solveImplication {" (ppr imp)