[project @ 1998-06-16 08:55:30 by sof]

[ghc-hetmet.git] / ghc / compiler / typecheck / TcDeriv.lhs

diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 631833b..eb10d71 100644 (file)
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -24,17 +24,19 @@ import TcSimplify   ( tcSimplifyThetas )
 
 import RnBinds         ( rnMethodBinds, rnTopMonoBinds )
 import RnEnv           ( newDfunName, bindLocatedLocalsRn )
-import RnMonad         ( RnM, RnDown, SDown, RnNameSupply(..), 
+import RnMonad         ( RnM, RnDown, SDown, RnNameSupply, 
                          renameSourceCode, thenRn, mapRn, returnRn )
 
 import Bag             ( Bag, emptyBag, unionBags, listToBag )
 import Class           ( classKey, Class )
 import ErrUtils                ( ErrMsg )
-import Id              ( dataConArgTys, isNullaryDataCon, mkDictFunId )
+import MkId            ( mkDictFunId )
+import Id              ( dataConArgTys, isNullaryDataCon )
 import PrelInfo                ( needsDataDeclCtxtClassKeys )
 import Maybes          ( maybeToBool )
 import Name            ( isLocallyDefined, getSrcLoc, Provenance, 
-                         Name{--O only-}, Module, NamedThing(..)
+                         Name{--O only-}, Module, NamedThing(..),
+                         OccName, nameOccName
                        )
 import SrcLoc          ( mkGeneratedSrcLoc, SrcLoc )
 import TyCon           ( tyConTyVars, tyConDataCons, tyConDerivings,
@@ -228,9 +230,11 @@ tcDeriving modname rn_name_supply inst_decl_infos_in
                        mapRn rn_one method_binds_s             `thenRn` \ dfun_names_w_method_binds ->
                        returnRn (dfun_names_w_method_binds, rn_extra_binds)
                  )
-       rn_one meth_binds = newDfunName Nothing mkGeneratedSrcLoc       `thenRn` \ dfun_name ->
-                           rnMethodBinds meth_binds                    `thenRn` \ rn_meth_binds ->
-                           returnRn (dfun_name, rn_meth_binds)
+       rn_one (cl_nm, tycon_nm, meth_binds) 
+               = newDfunName cl_nm tycon_nm
+                             Nothing mkGeneratedSrcLoc         `thenRn` \ dfun_name ->
+                 rnMethodBinds meth_binds                      `thenRn` \ rn_meth_binds ->
+                 returnRn (dfun_name, rn_meth_binds)
 
        really_new_inst_infos = map (gen_inst_info modname)
                                    (new_inst_infos `zip` dfun_names_w_method_binds)
@@ -570,24 +574,29 @@ the renamer.  What a great hack!
 
 \begin{code}
 -- Generate the method bindings for the required instance
-gen_bind :: InstInfo -> RdrNameMonoBinds
+-- (paired with class name, as we need that when generating dict
+--  names.)
+gen_bind :: InstInfo -> ({-class-}OccName, {-tyCon-}OccName, RdrNameMonoBinds)
 gen_bind (InstInfo clas _ [ty] _ _ _ _ _ _)
   | not from_here 
-  = EmptyMonoBinds
+  = (clas_nm, tycon_nm, EmptyMonoBinds)
   | otherwise
-  = assoc "gen_inst_info:bad derived class"
-         [(eqClassKey,      gen_Eq_binds)
-         ,(ordClassKey,     gen_Ord_binds)
-         ,(enumClassKey,    gen_Enum_binds)
-         ,(evalClassKey,    gen_Eval_binds)
-         ,(boundedClassKey, gen_Bounded_binds)
-         ,(showClassKey,    gen_Show_binds)
-         ,(readClassKey,    gen_Read_binds)
-         ,(ixClassKey,      gen_Ix_binds)
-         ]
-         (classKey clas) 
-         tycon
+  = (clas_nm, tycon_nm,
+     assoc "gen_bind:bad derived class"
+          [(eqClassKey,      gen_Eq_binds)
+          ,(ordClassKey,     gen_Ord_binds)
+          ,(enumClassKey,    gen_Enum_binds)
+          ,(evalClassKey,    gen_Eval_binds)
+          ,(boundedClassKey, gen_Bounded_binds)
+          ,(showClassKey,    gen_Show_binds)
+          ,(readClassKey,    gen_Read_binds)
+          ,(ixClassKey,      gen_Ix_binds)
+          ]
+          (classKey clas) 
+          tycon)
   where
+      clas_nm     = nameOccName (getName clas)
+      tycon_nm    = nameOccName (getName tycon)
       from_here   = isLocallyDefined tycon
       (tycon,_,_) = splitAlgTyConApp ty        
            
@@ -667,12 +676,12 @@ gen_taggery_Names inst_infos
     
     do_con2tag acc_Names tycon
       | isDataTyCon tycon &&
-        (we_are_deriving eqClassKey tycon
+        ((we_are_deriving eqClassKey tycon
            && any isNullaryDataCon (tyConDataCons tycon))
         || (we_are_deriving ordClassKey  tycon
            && not (maybeToBool (maybeTyConSingleCon tycon)))
         || (we_are_deriving enumClassKey tycon)
-        || (we_are_deriving ixClassKey   tycon)
+        || (we_are_deriving ixClassKey   tycon))
        
       = returnTc ((con2tag_RDR tycon, tycon, GenCon2Tag)
                   : acc_Names)
@@ -680,14 +689,14 @@ gen_taggery_Names inst_infos
       = returnTc acc_Names
 
     do_tag2con acc_Names tycon
-      = if (we_are_deriving enumClassKey tycon)
-       || (we_are_deriving ixClassKey   tycon)
-       then
-         returnTc ( (tag2con_RDR tycon, tycon, GenTag2Con)
-                  : (maxtag_RDR  tycon, tycon, GenMaxTag)
-                  : acc_Names)
-       else
-         returnTc acc_Names
+      | isDataTyCon tycon &&
+         (we_are_deriving enumClassKey tycon ||
+         we_are_deriving ixClassKey   tycon)
+      = returnTc ( (tag2con_RDR tycon, tycon, GenTag2Con)
+                : (maxtag_RDR  tycon, tycon, GenMaxTag)
+                : acc_Names)
+      | otherwise
+      = returnTc acc_Names
 
     we_are_deriving clas_key tycon
       = is_in_eqns clas_key tycon all_CTs