Merge branch 'master' of ssh://darcs.haskell.org/srv/darcs/ghc

2 files changed, 52 insertions, 75 deletions

diff --git a/compiler/typecheck/TcInteract.lhs b/compiler/typecheck/TcInteract.lhs
index 27cf52e85e..c0a0760f9f 100644
--- a/compiler/typecheck/TcInteract.lhs
+++ b/compiler/typecheck/TcInteract.lhs
@@ -20,11 +20,12 @@ import VarSet
 import Type
 import Unify
 import FamInstEnv
+import InstEnv( lookupInstEnv, instanceDFunId )
 
 import Var
 import TcType
 import PrelNames (singIClassName, ipClassNameKey )
-
+import Id( idType )
 import Class
 import TyCon
 import Name
@@ -1727,44 +1728,60 @@ matchClassInst _ clas [ k, ty ] _
 
 matchClassInst inerts clas tys loc
    = do { dflags <- getDynFlags
-        ; let pred = mkClassPred clas tys 
-              incoherent_ok = xopt Opt_IncoherentInstances  dflags
-        ; mb_result <- matchClass clas tys
         ; untch <- getUntouchables
         ; traceTcS "matchClassInst" $ vcat [ text "pred =" <+> ppr pred
                                            , text "inerts=" <+> ppr inerts
                                            , text "untouchables=" <+> ppr untch ]
-        ; case mb_result of
-            MatchInstNo   -> return NoInstance
-            MatchInstMany -> return NoInstance -- defer any reactions of a multitude until
-                                               -- we learn more about the reagent 
-            MatchInstSingle (_,_)
-              | not incoherent_ok && given_overlap untch 
-              -> -- see Note [Instance and Given overlap]
-                 do { traceTcS "Delaying instance application" $ 
-                       vcat [ text "Workitem=" <+> pprType (mkClassPred clas tys)
-                            , text "Relevant given dictionaries=" <+> ppr givens_for_this_clas ]
-                     ; return NoInstance
-                     }
-
-            MatchInstSingle (dfun_id, mb_inst_tys) ->
-              do { checkWellStagedDFun pred dfun_id loc
-
-                       -- mb_inst_tys :: Maybe TcType 
-                       -- See Note [DFunInstType: instantiating types] in InstEnv
-
-                 ; (tys, dfun_phi) <- instDFunType dfun_id mb_inst_tys
-                 ; let (theta, _) = tcSplitPhiTy dfun_phi
-                 ; if null theta then
-                       return (GenInst [] (EvDFunApp dfun_id tys []))
-                   else do
-                     { evc_vars <- instDFunConstraints theta
-                     ; let new_ev_vars = freshGoals evc_vars
-                           -- new_ev_vars are only the real new variables that can be emitted 
-                           dfun_app = EvDFunApp dfun_id tys (getEvTerms evc_vars)
-                     ; return $ GenInst new_ev_vars dfun_app } }
-        }
+        ; instEnvs <- getInstEnvs
+        ; case lookupInstEnv instEnvs clas tys of
+            ([], _, _)               -- Nothing matches  
+                -> do { traceTcS "matchClass not matching" $ 
+                        vcat [ text "dict" <+> ppr pred ]
+                      ; return NoInstance }
+
+	    ([(ispec, inst_tys)], [], _) -- A single match 
+                | not (xopt Opt_IncoherentInstances dflags)
+                , given_overlap untch 
+                -> -- See Note [Instance and Given overlap]
+                   do { traceTcS "Delaying instance application" $ 
+                          vcat [ text "Workitem=" <+> pprType (mkClassPred clas tys)
+                               , text "Relevant given dictionaries=" <+> ppr givens_for_this_clas ]
+                      ; return NoInstance  }
+
+                | otherwise
+		-> do	{ let dfun_id = instanceDFunId ispec
+			; traceTcS "matchClass success" $
+                          vcat [text "dict" <+> ppr pred, 
+                                text "witness" <+> ppr dfun_id
+                                               <+> ppr (idType dfun_id) ]
+				  -- Record that this dfun is needed
+                        ; match_one dfun_id inst_tys }
+
+     	    (matches, _, _)    -- More than one matches 
+                               -- Defer any reactions of a multitude
+                               -- until we learn more about the reagent 
+		-> do	{ traceTcS "matchClass multiple matches, deferring choice" $
+                          vcat [text "dict" <+> ppr pred,
+                                text "matches" <+> ppr matches]
+                        ; return NoInstance } }
    where 
+     pred = mkClassPred clas tys 
+
+     match_one :: DFunId -> [Maybe TcType] -> TcS LookupInstResult
+                  -- See Note [DFunInstType: instantiating types] in InstEnv
+     match_one dfun_id mb_inst_tys
+       = do { checkWellStagedDFun pred dfun_id loc
+            ; (tys, dfun_phi) <- instDFunType dfun_id mb_inst_tys
+            ; let (theta, _) = tcSplitPhiTy dfun_phi
+            ; if null theta then
+                  return (GenInst [] (EvDFunApp dfun_id tys []))
+              else do
+            { evc_vars <- instDFunConstraints theta
+            ; let new_ev_vars = freshGoals evc_vars
+                      -- new_ev_vars are only the real new variables that can be emitted 
+                  dfun_app = EvDFunApp dfun_id tys (getEvTerms evc_vars)
+            ; return $ GenInst new_ev_vars dfun_app } }
+
      givens_for_this_clas :: Cts
      givens_for_this_clas 
          = lookupUFM (cts_given (inert_dicts $ inert_cans inerts)) clas 
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 9a7049fcca..0b2e484f7a 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -86,7 +86,7 @@ module TcSMonad (
 
     getDefaultInfo, getDynFlags,
 
-    matchClass, matchFam, matchOpenFam, MatchInstResult (..), 
+    matchFam, matchOpenFam, 
     checkWellStagedDFun, 
     pprEq                                    -- Smaller utils, re-exported from TcM
                                              -- TODO (DV): these are only really used in the 
@@ -1635,46 +1635,6 @@ rewriteCtFlavor (CtWanted { ctev_evar = evar, ctev_pred = old_pred }) new_pred c
 
 
 
--- Matching and looking up classes and family instances
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-data MatchInstResult mi
-  = MatchInstNo         -- No matching instance 
-  | MatchInstSingle mi  -- Single matching instance
-  | MatchInstMany       -- Multiple matching instances
-
-
-matchClass :: Class -> [Type] -> TcS (MatchInstResult (DFunId, [Maybe TcType])) 
--- Look up a class constraint in the instance environment
-matchClass clas tys
-  = do	{ let pred = mkClassPred clas tys 
-        ; instEnvs <- getInstEnvs
-        ; case lookupInstEnv instEnvs clas tys of {
-            ([], _unifs, _)               -- Nothing matches  
-                -> do { traceTcS "matchClass not matching" $ 
-                        vcat [ text "dict" <+> ppr pred
-                             {- , ppr instEnvs -} ]
-                        
-                      ; return MatchInstNo  
-                      } ;  
-	    ([(ispec, inst_tys)], [], _) -- A single match 
-		-> do	{ let dfun_id = is_dfun ispec
-			; traceTcS "matchClass success" $
-                          vcat [text "dict" <+> ppr pred, 
-                                text "witness" <+> ppr dfun_id
-                                               <+> ppr (idType dfun_id) ]
-				  -- Record that this dfun is needed
-                        ; return $ MatchInstSingle (dfun_id, inst_tys)
-                        } ;
-     	    (matches, _unifs, _)          -- More than one matches 
-		-> do	{ traceTcS "matchClass multiple matches, deferring choice" $
-                          vcat [text "dict" <+> ppr pred,
-                                text "matches" <+> ppr matches]
-                        ; return MatchInstMany 
-		        }
-	}
-        }
-
 matchOpenFam :: TyCon -> [Type] -> TcS (Maybe FamInstMatch)
 matchOpenFam tycon args = wrapTcS $ tcLookupFamInst tycon args