X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnSource.lhs;h=97798b76a83a75f38daf00e7c718013521bba9ce;hb=6af6951bef8ba4826103a7170a82d3c70bb16805;hp=cb5abf3e434b80eb746bfce6083225153cf601a8;hpb=edfe93593306cebc7981f5df2d634f9547849587;p=ghc-hetmet.git

diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index cb5abf3..97798b7 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -27,7 +27,7 @@ import RnMonad
 
 import Name		( Name, OccName(..), occNameString, prefixOccName,
 			  ExportFlag(..), Provenance(..), NameSet,
-			  elemNameSet
+			  elemNameSet, nameOccName, NamedThing(..)
 			)
 import FiniteMap	( lookupFM )
 import Id		( GenId{-instance NamedThing-} )
@@ -240,9 +240,36 @@ rnDecl (InstD (InstDecl inst_ty mbinds uprags maybe_dfun src_loc))
     checkDupNames meth_doc meth_names 		`thenRn_`
     rnMethodBinds mbinds			`thenRn` \ mbinds' ->
     mapRn rn_uprag uprags			`thenRn` \ new_uprags ->
-
-    newDfunName maybe_dfun src_loc		`thenRn` \ dfun_name ->
-    addOccurrenceName dfun_name			`thenRn_`
+   
+    let
+     -- We use the class name and the name of the first
+     -- type constructor the class is applied to.
+     (cl_nm, tycon_nm) = mkDictPrefix inst_ty'
+     
+     mkDictPrefix (MonoDictTy cl tys) = 
+        case tys of
+	  []     -> (c_nm, nilOccName )
+	  (ty:_) -> (c_nm, getInstHeadTy ty)
+	where
+	 c_nm = nameOccName (getName cl)
+
+     mkDictPrefix (HsPreForAllTy _ ty) = mkDictPrefix ty
+     mkDictPrefix (HsForAllTy _ _ ty)  = mkDictPrefix ty  -- can this 
+     mkDictPrefix _		       = (nilOccName, nilOccName)
+
+     getInstHeadTy t 
+      = case t of
+          MonoTyVar tv    -> nameOccName (getName tv)
+          MonoTyApp t _   -> getInstHeadTy t
+	  _		  -> nilOccName
+	    -- I cannot see how the rest of HsType constructors
+	    -- can occur, but this isn't really a failure condition,
+	    -- so we return silently.
+
+     nilOccName = (VarOcc _NIL_) -- ToDo: add OccName constructor fun for this.
+    in
+    newDfunName cl_nm tycon_nm maybe_dfun src_loc  `thenRn` \ dfun_name ->
+    addOccurrenceName dfun_name			   `thenRn_`
 			-- The dfun is not optional, because we use its version number
 			-- to identify the version of the instance declaration