[commit: ghc] master: In doTopReactDict, try lookup even if fundeps work (d31dd88)

[Simon Peyton Jones]

Repository : http://darcs.haskell.org/ghc.git/

On branch  : master

https://github.com/ghc/ghc/commit/d31dd88d4eae4e199d1341da2e7a7550a5e4c3a2

>---------------------------------------------------------------

commit d31dd88d4eae4e199d1341da2e7a7550a5e4c3a2
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Fri May 3 07:42:57 2013 +0100

    In doTopReactDict, try lookup even if fundeps work
    
    Previously we looked for fundeps, and if any fired we
    didn't try to solve the constraint.  But that's wrong
    (see Note [Weird fundeps]).  Now I solve first and only
    if that fails try fundeps.  Code is neater too.
    
    Fixes Trac #7875

>---------------------------------------------------------------

 compiler/typecheck/TcInteract.lhs | 58 +++++++++++++++++++--------------------
 1 file changed, 29 insertions(+), 29 deletions(-)

diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 39955e3..ce03a9e 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -1410,40 +1410,28 @@ doTopReact inerts workItem
 doTopReactDict :: InertSet -> CtEvidence -> Class -> [Xi]
                -> CtLoc -> TcS TopInteractResult
 doTopReactDict inerts fl cls xis loc
-  = do {    -- Try functional dependencies with the instance environment
-         instEnvs <- getInstEnvs 
-       ; let pred = mkClassPred cls xis
-             fd_eqns = improveFromInstEnv instEnvs (pred, arising_sdoc)
-       ; fd_work <- rewriteWithFunDeps fd_eqns loc
-       ; unless (null fd_work) (updWorkListTcS (extendWorkListEqs fd_work))
-       
-       ; if not (isWanted fl) then 
-            return NoTopInt
-         else 
-
-            -- Even if there *were* some functional dependencies against the
-            -- instance environment, there might be a unique match, and if 
-            -- so we should get on and solve it. See Note [Wierd fundeps]
-
-         case lookupSolvedDict inerts pred of {
-            Just ev -> do { setEvBind dict_id (ctEvTerm ev); 
-                          ; return $ 
-                            SomeTopInt { tir_rule = "Dict/Top (cached)" 
-                                       , tir_new_item = Stop } } ;
-            Nothing -> do
-
-      { lkup_inst_res <- matchClassInst inerts cls xis loc
-      ; case lkup_inst_res of
-           GenInst wtvs ev_term -> do { addSolvedDict fl 
-                                      ; doSolveFromInstance wtvs ev_term }
-           NoInstance -> return NoTopInt } } }
+  | not (isWanted fl)
+  = try_fundeps_and_return
+
+  | Just ev <- lookupSolvedDict inerts pred   -- Cached
+  = do { setEvBind dict_id (ctEvTerm ev); 
+       ; return $ SomeTopInt { tir_rule = "Dict/Top (cached)" 
+                             , tir_new_item = Stop } } 
+
+  | otherwise  -- Not cached
+   = do { lkup_inst_res <- matchClassInst inerts cls xis loc
+         ; case lkup_inst_res of
+               GenInst wtvs ev_term -> do { addSolvedDict fl 
+                                          ; solve_from_instance wtvs ev_term }
+               NoInstance -> try_fundeps_and_return }
    where 
      arising_sdoc = pprArisingAt loc
      dict_id = ctEvId fl
+     pred = mkClassPred cls xis
                        
-     doSolveFromInstance :: [CtEvidence] -> EvTerm -> TcS TopInteractResult
+     solve_from_instance :: [CtEvidence] -> EvTerm -> TcS TopInteractResult
       -- Precondition: evidence term matches the predicate workItem
-     doSolveFromInstance evs ev_term 
+     solve_from_instance evs ev_term 
         | null evs
         = do { traceTcS "doTopReact/found nullary instance for" $
                ppr dict_id
@@ -1463,6 +1451,18 @@ doTopReactDict inerts fl cls xis loc
                SomeTopInt { tir_rule     = "Dict/Top (solved, more work)"
                           , tir_new_item = Stop } }
 
+     -- We didn't solve it; so try functional dependencies with 
+     -- the instance environment, and return
+     -- NB: even if there *are* some functional dependencies against the
+     -- instance environment, there might be a unique match, and if 
+     -- so we make sure we get on and solve it first. See Note [Weird fundeps]
+     try_fundeps_and_return
+       = do { instEnvs <- getInstEnvs 
+            ; let fd_eqns = improveFromInstEnv instEnvs (pred, arising_sdoc)
+            ; fd_work <- rewriteWithFunDeps fd_eqns loc
+            ; unless (null fd_work) (updWorkListTcS (extendWorkListEqs fd_work))
+            ; return NoTopInt }
+       
 --------------------
 doTopReactFunEq :: Ct -> CtEvidence -> TyCon -> [Xi] -> Xi
                 -> CtLoc -> TcS TopInteractResult