In doTopReactDict, try lookup even if fundeps work
authorSimon Peyton Jones <simonpj@microsoft.com>
Fri, 3 May 2013 06:42:57 +0000 (07:42 +0100)
committerSimon Peyton Jones <simonpj@microsoft.com>
Fri, 3 May 2013 06:44:03 +0000 (07:44 +0100)
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

index 39955e3..ce03a9e 100644 (file)
@@ -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
-     
-     doSolveFromInstance :: [CtEvidence] -> EvTerm -> TcS TopInteractResult
+     pred = mkClassPred cls xis
+                       
+     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