X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FInstEnv.lhs;h=7a2a65e06bee0eb6711ad9d49c7f229eb2288fef;hp=2d6a9eb215346b64574ccee53d5578e3ed046145;hb=914e415702a25a6e52ab1eaaf2aea233d6c6097e;hpb=a3bab0506498db41853543558c52a4fda0d183af

diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs
index 2d6a9eb..7a2a65e 100644
--- a/compiler/types/InstEnv.lhs
+++ b/compiler/types/InstEnv.lhs
@@ -119,7 +119,7 @@ instanceDFunId = is_dfun
 
 setInstanceDFunId :: Instance -> DFunId -> Instance
 setInstanceDFunId ispec dfun
-   = ASSERT( idType dfun `tcEqType` idType (is_dfun ispec) )
+   = ASSERT( idType dfun `eqType` idType (is_dfun ispec) )
 	-- We need to create the cached fields afresh from
 	-- the new dfun id.  In particular, the is_tvs in
 	-- the Instance must match those in the dfun!
@@ -128,7 +128,7 @@ setInstanceDFunId ispec dfun
 	-- are ok; hence the assert
      ispec { is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys }
    where 
-     (tvs, _, tys) = tcSplitDFunTy (idType dfun)
+     (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)
 
 instanceRoughTcs :: Instance -> [Maybe Name]
 instanceRoughTcs = is_tcs
@@ -156,7 +156,7 @@ pprInstanceHdr ispec@(Instance { is_flag = flag })
           | debugStyle sty = theta
           | otherwise = drop (dfunNSilent dfun) theta
     in ptext (sLit "instance") <+> ppr flag
-       <+> sep [pprThetaArrow theta_to_print, ppr res_ty]
+       <+> sep [pprThetaArrowTy theta_to_print, ppr res_ty]
   where
     dfun = is_dfun ispec
     (_, theta, res_ty) = tcSplitSigmaTy (idType dfun)
@@ -166,11 +166,14 @@ pprInstances :: [Instance] -> SDoc
 pprInstances ispecs = vcat (map pprInstance ispecs)
 
 instanceHead :: Instance -> ([TyVar], ThetaType, Class, [Type])
-instanceHead ispec 
-   = (tvs, theta, cls, tys)
+-- Returns the *source* theta, without the silent arguments
+instanceHead ispec
+   = (tvs, drop n_silent theta, cls, tys)
    where
-     (tvs, theta, tau) = tcSplitSigmaTy (idType (is_dfun ispec))
-     (cls, tys) = tcSplitDFunHead tau
+     (tvs, theta, tau) = tcSplitSigmaTy (idType dfun)
+     (cls, tys)        = tcSplitDFunHead tau
+     dfun              = is_dfun ispec
+     n_silent          = dfunNSilent dfun
 
 mkLocalInstance :: DFunId
                 -> OverlapFlag
@@ -181,7 +184,7 @@ mkLocalInstance dfun oflag
 		is_tvs = mkVarSet tvs, is_tys = tys,
                 is_cls = className cls, is_tcs = roughMatchTcs tys }
   where
-    (tvs, cls, tys) = tcSplitDFunTy (idType dfun)
+    (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
 
 mkImportedInstance :: Name -> [Maybe Name]
 		   -> DFunId -> OverlapFlag -> Instance
@@ -192,7 +195,7 @@ mkImportedInstance cls mb_tcs dfun oflag
 		is_tvs = mkVarSet tvs, is_tys = tys,
 		is_cls = cls, is_tcs = mb_tcs }
   where
-    (tvs, _, tys) = tcSplitDFunTy (idType dfun)
+    (tvs, _, _, tys) = tcSplitDFunTy (idType dfun)
 
 roughMatchTcs :: [Type] -> [Maybe Name]
 roughMatchTcs tys = map rough tys
@@ -496,7 +499,7 @@ lookupInstEnv (pkg_ie, home_ie) cls tys
  	find ((item, map (lookup_tv subst) dfun_tvs) : ms) us rest
 
 	-- Does not match, so next check whether the things unify
-	-- See Note [overlapping instances] above
+	-- See Note [Overlapping instances] above
       | Incoherent <- oflag
       = find ms us rest
 
@@ -530,14 +533,18 @@ insert_overlapping new_item (item:items)
     old_beats_new = item `beats` new_item
 
     (instA, _) `beats` (instB, _)
-	= overlap_ok && 
-	  isJust (tcMatchTys (is_tvs instB) (is_tys instB) (is_tys instA))
-		-- A beats B if A is more specific than B, and B admits overlap
-		-- I.e. if B can be instantiated to match A
-	where
-	  overlap_ok = case is_flag instB of
-			NoOverlap -> False
-			_         -> True
+          = overlap_ok && 
+            isJust (tcMatchTys (is_tvs instB) (is_tys instB) (is_tys instA))
+                    -- A beats B if A is more specific than B,
+                    -- (ie. if B can be instantiated to match A)
+                    -- and overlap is permitted
+          where
+            -- Overlap permitted if *either* instance permits overlap
+            -- This is a change (Trac #3877, Dec 10). It used to
+            -- require that instB (the less specific one) permitted overlap.
+            overlap_ok = case (is_flag instA, is_flag instB) of
+                              (NoOverlap, NoOverlap) -> False
+                              _                      -> True
 \end{code}