[project @ 1998-03-19 23:54:49 by simonpj]

[ghc-hetmet.git] / ghc / compiler / rename / RnSource.lhs

diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index cb5abf3..d4d73fb 100644 (file)
--- 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' ->