X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypes%2FInstEnv.lhs;h=07f68f7b91ce91c6c271b201f7fdce8ddcb20027;hp=a6ddc3c3ed01a85fcdc8960d11951ace5ceace7e;hb=16b9e80dc14db24509f051f294b5b51943285090;hpb=eee94cc7e8e39f84dc61c07461582b9655270d67

diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs
index a6ddc3c..07f68f7 100644
--- a/compiler/types/InstEnv.lhs
+++ b/compiler/types/InstEnv.lhs
@@ -45,7 +45,6 @@ import Data.Maybe	( isJust, isNothing )
 %************************************************************************
 
 \begin{code}
-type DFunId = Id
 data Instance 
   = Instance { is_cls  :: Name		-- Class name
 	
@@ -59,7 +58,7 @@ data Instance
 		-- INVARIANT: is_dfun Id has type 
 		--	forall is_tvs. (...) => is_cls is_tys
 
-	     , is_dfun :: DFunId
+	     , is_dfun :: DFunId -- See Note [Haddock assumptions]
 	     , is_flag :: OverlapFlag	-- See detailed comments with
 					-- the decl of BasicTypes.OverlapFlag
     }
@@ -99,7 +98,20 @@ However, note that:
    (This is so that we can use the matching substitution to
     instantiate the dfun's context.)
 
+Note [Haddock assumptions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+For normal user-written instances, Haddock relies on
 
+ * the SrcSpan of
+ * the Name of
+ * the is_dfun of
+ * an Instance
+
+being equal to
+
+  * the SrcSpan of
+  * the instance head type of
+  * the InstDecl used to construct the Instance.
 
 \begin{code}
 instanceDFunId :: Instance -> DFunId
@@ -139,24 +151,38 @@ pprInstance ispec
 pprInstanceHdr :: Instance -> SDoc
 -- Prints the Instance as an instance declaration
 pprInstanceHdr ispec@(Instance { is_flag = flag })
-  = ptext (sLit "instance") <+> ppr flag
-    <+> sep [pprThetaArrow theta, pprClassPred clas tys]
+  = getPprStyle $ \ sty ->
+    let theta_to_print
+          | debugStyle sty = theta
+          | otherwise = drop (dfunNSilent dfun) theta
+    in ptext (sLit "instance") <+> ppr flag
+       <+> sep [pprThetaArrow theta_to_print, ppr res_ty]
   where
-    (_, theta, clas, tys) = instanceHead ispec
+    dfun = is_dfun ispec
+    (_, theta, res_ty) = tcSplitSigmaTy (idType dfun)
 	-- Print without the for-all, which the programmer doesn't write
 
 pprInstances :: [Instance] -> SDoc
 pprInstances ispecs = vcat (map pprInstance ispecs)
 
-instanceHead :: Instance -> ([TyVar], [PredType], Class, [Type])
-instanceHead ispec = tcSplitDFunTy (idType (is_dfun ispec))
-
-mkLocalInstance :: DFunId -> OverlapFlag -> Instance
+instanceHead :: Instance -> ([TyVar], ThetaType, Class, [Type])
+-- Returns the *source* theta, without the silent arguments
+instanceHead ispec
+   = (tvs, drop n_silent theta, cls, tys)
+   where
+     (tvs, theta, tau) = tcSplitSigmaTy (idType dfun)
+     (cls, tys)        = tcSplitDFunHead tau
+     dfun              = is_dfun ispec
+     n_silent          = dfunNSilent dfun
+
+mkLocalInstance :: DFunId
+                -> OverlapFlag
+                -> Instance
 -- Used for local instances, where we can safely pull on the DFunId
 mkLocalInstance dfun oflag
   = Instance {	is_flag = oflag, is_dfun = dfun,
 		is_tvs = mkVarSet tvs, is_tys = tys,
-		is_cls = className cls, is_tcs = roughMatchTcs tys }
+                is_cls = className cls, is_tcs = roughMatchTcs tys }
   where
     (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun)
 
@@ -337,6 +363,9 @@ data ClsInstEnv
 			-- 	If *not* then the common case of looking up
 			--	(C a b c) can fail immediately
 
+instance Outputable ClsInstEnv where
+  ppr (ClsIE is b) = ptext (sLit "ClsIE") <+> ppr b <+> pprInstances is
+
 -- INVARIANTS:
 --  * The is_tvs are distinct in each Instance
 --	of a ClsInstEnv (so we can safely unify them)
@@ -470,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
 
@@ -504,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}
 
 
@@ -523,8 +556,8 @@ insert_overlapping new_item (item:items)
 
 \begin{code}
 instanceBindFun :: TyVar -> BindFlag
-instanceBindFun tv | isTcTyVar tv && isExistentialTyVar tv = Skolem
-	           | otherwise	 		 	= BindMe
+instanceBindFun tv | isTcTyVar tv && isOverlappableTyVar tv = Skolem
+                   | otherwise                              = BindMe
    -- Note [Binding when looking up instances]
 \end{code}
 
@@ -547,7 +580,7 @@ The op [x,x] means we need (Foo [a]).  Without the filterVarSet we'd
 complain, saying that the choice of instance depended on the instantiation
 of 'a'; but of course it isn't *going* to be instantiated.
 
-We do this only for pattern-bound skolems.  For example we reject
+We do this only for isOverlappableTyVar skolems.  For example we reject
 	g :: forall a => [a] -> Int
 	g x = op x
 on the grounds that the correct instance depends on the instantiation of 'a'