X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypes%2FInstEnv.lhs;h=09b9b5337ed6aec16ebf94cc1bb6964a253d5ce3;hb=ced4c13ea3577e01556a2f76c2cc458c0be6c83c;hp=7aaea5cff768bd204751589e519f104acf5174fa;hpb=6113955d352ba7188a7ae3b4de24c396dff86495;p=ghc-hetmet.git

diff --git a/compiler/types/InstEnv.lhs b/compiler/types/InstEnv.lhs
index 7aaea5c..09b9b53 100644
--- a/compiler/types/InstEnv.lhs
+++ b/compiler/types/InstEnv.lhs
@@ -15,7 +15,7 @@ module InstEnv (
 
 	InstEnv, emptyInstEnv, extendInstEnv, 
 	extendInstEnvList, lookupInstEnv, instEnvElts,
-	classInstances, 
+	classInstances, instanceBindFun,
 	instanceCantMatch, roughMatchTcs
     ) where
 
@@ -27,13 +27,12 @@ import VarSet
 import Name
 import TcType
 import TyCon
-import TcGadt
 import Unify
 import Outputable
 import BasicTypes
 import UniqFM
 import Id
-import SrcLoc
+import FastString
 
 import Data.Maybe	( isJust, isNothing )
 \end{code}
@@ -46,7 +45,6 @@ import Data.Maybe	( isJust, isNothing )
 %************************************************************************
 
 \begin{code}
-type DFunId = Id
 data Instance 
   = Instance { is_cls  :: Name		-- Class name
 	
@@ -60,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
     }
@@ -100,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
@@ -117,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
@@ -132,25 +143,29 @@ instance Outputable Instance where
 
 pprInstance :: Instance -> SDoc
 -- Prints the Instance as an instance declaration
-pprInstance ispec@(Instance { is_flag = flag })
+pprInstance ispec
   = hang (pprInstanceHdr ispec)
-	2 (ptext SLIT("--") <+> (pprDefnLoc (getSrcSpan ispec)))
+	2 (ptext (sLit "--") <+> pprNameLoc (getName ispec))
 
 -- * pprInstanceHdr is used in VStudio to populate the ClassView tree
 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]
+  = ptext (sLit "instance") <+> ppr flag
+    <+> sep [pprThetaArrow theta, ppr res_ty]
   where
-    (_, theta, clas, tys) = instanceHead ispec
+    (_, theta, res_ty) = tcSplitSigmaTy (idType (is_dfun ispec))
 	-- 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))
+instanceHead :: Instance -> ([TyVar], ThetaType, Class, [Type])
+instanceHead ispec 
+   = (tvs, theta, cls, tys)
+   where
+     (tvs, theta, tau) = tcSplitSigmaTy (idType (is_dfun ispec))
+     (cls, tys) = tcSplitDFunHead tau
 
 mkLocalInstance :: DFunId -> OverlapFlag -> Instance
 -- Used for local instances, where we can safely pull on the DFunId
@@ -159,7 +174,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
@@ -170,7 +185,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
@@ -184,7 +199,7 @@ instanceCantMatch :: [Maybe Name] -> [Maybe Name] -> Bool
 -- possibly be instantiated to actual, nor vice versa; 
 -- False is non-committal
 instanceCantMatch (Just t : ts) (Just a : as) = t/=a || instanceCantMatch ts as
-instanceCantMatch ts		as	      =  False	-- Safe
+instanceCantMatch _             _             =  False  -- Safe
 \end{code}
 
 
@@ -371,12 +386,12 @@ extendInstEnv inst_env ins_item@(Instance { is_cls = cls_nm, is_tcs = mb_tcs })
     add (ClsIE cur_insts cur_tyvar) _ = ClsIE (ins_item : cur_insts)
 					      (ins_tyvar || cur_tyvar)
     ins_tyvar = not (any isJust mb_tcs)
-\end{code}		      
+\end{code}
 
 
 %************************************************************************
 %*									*
-\subsection{Looking up an instance}
+	Looking up an instance
 %*									*
 %************************************************************************
 
@@ -482,31 +497,11 @@ lookupInstEnv (pkg_ie, home_ie) cls tys
 		)
 		-- Unification will break badly if the variables overlap
 		-- They shouldn't because we allocate separate uniques for them
-        case tcUnifyTys bind_fn tpl_tys tys of
+        case tcUnifyTys instanceBindFun tpl_tys tys of
 	    Just _   -> find ms (item:us) rest
-	    Nothing  -> find ms us	   rest
+	    Nothing  -> find ms us	  rest
 
 ---------------
-bind_fn tv | isTcTyVar tv && isExistentialTyVar tv = Skolem
-	   | otherwise	 		 	   = BindMe
-	-- The key_tys can contain skolem constants, and we can guarantee that those
-	-- are never going to be instantiated to anything, so we should not involve
-	-- them in the unification test.  Example:
-	--	class Foo a where { op :: a -> Int }
-	--	instance Foo a => Foo [a] 	-- NB overlap
-	--	instance Foo [Int]		-- NB overlap
-	-- 	data T = forall a. Foo a => MkT a
-	--	f :: T -> Int
-	--	f (MkT x) = op [x,x]
-	-- 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
-	--	g :: forall a => [a] -> Int
-	--	g x = op x
-	-- on the grounds that the correct instance depends on the instantiation of 'a'
-
 ---------------
 insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch]
 -- Add a new solution, knocking out strictly less specific ones
@@ -532,6 +527,43 @@ insert_overlapping new_item (item:items)
 	where
 	  overlap_ok = case is_flag instB of
 			NoOverlap -> False
-			other	  -> True
+			_         -> True
 \end{code}
 
+
+%************************************************************************
+%*									*
+	Binding decisions
+%*									*
+%************************************************************************
+
+\begin{code}
+instanceBindFun :: TyVar -> BindFlag
+instanceBindFun tv | isTcTyVar tv && isExistentialTyVar tv = Skolem
+	           | otherwise	 		 	= BindMe
+   -- Note [Binding when looking up instances]
+\end{code}
+
+Note [Binding when looking up instances]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+When looking up in the instance environment, or family-instance environment,
+we are careful about multiple matches, as described above in 
+Note [Overlapping instances]
+
+The key_tys can contain skolem constants, and we can guarantee that those
+are never going to be instantiated to anything, so we should not involve
+them in the unification test.  Example:
+	class Foo a where { op :: a -> Int }
+	instance Foo a => Foo [a] 	-- NB overlap
+	instance Foo [Int]		-- NB overlap
+	data T = forall a. Foo a => MkT a
+	f :: T -> Int
+	f (MkT x) = op [x,x]
+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
+	g :: forall a => [a] -> Int
+	g x = op x
+on the grounds that the correct instance depends on the instantiation of 'a'