X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Frename%2FRnSource.lhs;h=d4d73fbc54498aa44115b04c618b156301fa9602;hb=2c8f04b5b883db74f449dfc8c224929fe28b027d;hp=cb5abf3e434b80eb746bfce6083225153cf601a8;hpb=be33dbc967b4915cfdb0307ae1b7ae3cee651b8c;p=ghc-hetmet.git

diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index cb5abf3..d4d73fb 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
 
@@ -589,15 +616,10 @@ rnCoreExpr (UfCase scrut alts)
     rnCoreAlts alts		`thenRn` \ alts' ->
     returnRn (UfCase scrut' alts')
 
-rnCoreExpr (UfSCC cc expr) 
-  = rnCoreExpr expr		`thenRn` \ expr' ->
-    returnRn  (UfSCC cc expr') 
-
-rnCoreExpr(UfCoerce coercion ty body)
-  = rnCoercion coercion		`thenRn` \ coercion' ->
-    rnHsType ty			`thenRn` \ ty' ->
-    rnCoreExpr body		`thenRn` \ body' ->
-    returnRn (UfCoerce coercion' ty' body')
+rnCoreExpr (UfNote note expr) 
+  = rnNote note			`thenRn` \ note' ->
+    rnCoreExpr expr		`thenRn` \ expr' ->
+    returnRn  (UfNote note' expr') 
 
 rnCoreExpr (UfLam bndr body)
   = rnCoreBndr bndr 		$ \ bndr' ->
@@ -670,8 +692,12 @@ rnCoreDefault (UfBindDefault bndr rhs) = bindLocalsRn "unfolding default" [bndr]
 					 rnCoreExpr rhs					`thenRn` \ rhs' ->
 				  	 returnRn (UfBindDefault bndr' rhs')
 
-rnCoercion (UfIn  n) = lookupOccRn n `thenRn` \ n' -> returnRn (UfIn  n')
-rnCoercion (UfOut n) = lookupOccRn n `thenRn` \ n' -> returnRn (UfOut n')
+rnNote (UfCoerce ty)
+  = rnHsType ty			`thenRn` \ ty' ->
+    returnRn (UfCoerce ty')
+
+rnNote (UfSCC cc)   = returnRn (UfSCC cc)
+rnNote UfInlineCall = returnRn UfInlineCall
 
 rnCorePrim (UfOtherOp op) 
   = lookupOccRn op	`thenRn` \ op' ->