[project @ 1999-05-26 16:54:22 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index 09904ea..fd54e6e 100644 (file)
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -11,7 +11,7 @@ module TcDeriv ( tcDeriving ) where
 #include "HsVersions.h"
 
 import HsSyn           ( HsBinds(..), MonoBinds(..), collectMonoBinders )
-import RdrHsSyn                ( RdrName, RdrNameMonoBinds )
+import RdrHsSyn                ( RdrNameMonoBinds )
 import RnHsSyn         ( RenamedHsBinds, RenamedMonoBinds )
 import CmdLineOpts     ( opt_D_dump_deriv )
 
@@ -29,16 +29,19 @@ import RnMonad              ( RnNameSupply,
 
 import Bag             ( Bag, emptyBag, unionBags, listToBag )
 import Class           ( classKey, Class )
-import ErrUtils                ( ErrMsg, dumpIfSet )
+import ErrUtils                ( dumpIfSet, Message )
 import MkId            ( mkDictFunId )
 import Id              ( mkVanillaId )
 import DataCon         ( dataConArgTys, isNullaryDataCon )
 import PrelInfo                ( needsDataDeclCtxtClassKeys )
 import Maybes          ( maybeToBool )
+import Module          ( ModuleName )
 import Name            ( isLocallyDefined, getSrcLoc,
-                         Name, Module, NamedThing(..),
+                         Name, NamedThing(..),
                          OccName, nameOccName
                        )
+import RdrName         ( RdrName )
+import RnMonad         ( Fixities )
 import SrcLoc          ( mkGeneratedSrcLoc, SrcLoc )
 import TyCon           ( tyConTyVars, tyConDataCons, tyConDerivings,
                          tyConTheta, maybeTyConSingleCon, isDataTyCon,
@@ -183,13 +186,14 @@ context to the instance decl.  The "offending classes" are
 %************************************************************************
 
 \begin{code}
-tcDeriving  :: Module                  -- name of module under scrutiny
+tcDeriving  :: ModuleName              -- name of module under scrutiny
+           -> Fixities                 -- for the deriving code (Show/Read.)
            -> RnNameSupply             -- for "renaming" bits of generated code
            -> Bag InstInfo             -- What we already know about instances
            -> TcM s (Bag InstInfo,     -- The generated "instance decls".
                      RenamedHsBinds)   -- Extra generated bindings
 
-tcDeriving modname rn_name_supply inst_decl_infos_in
+tcDeriving modname fixs rn_name_supply inst_decl_infos_in
   = recoverTc (returnTc (emptyBag, EmptyBinds)) $
 
        -- Fish the "deriving"-related information out of the TcEnv
@@ -216,7 +220,7 @@ tcDeriving modname rn_name_supply inst_decl_infos_in
     let
        extra_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
        extra_mbinds     = foldr AndMonoBinds EmptyMonoBinds extra_mbind_list
-       method_binds_s   = map gen_bind new_inst_infos
+       method_binds_s   = map (gen_bind fixs) new_inst_infos
        mbinders         = bagToList (collectMonoBinders extra_mbinds)
        
        -- Rename to get RenamedBinds.
@@ -230,13 +234,14 @@ tcDeriving modname rn_name_supply inst_decl_infos_in
                        returnRn (dfun_names_w_method_binds, rn_extra_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, _) ->
+               = newDFunName (cl_nm, tycon_nm)
+                             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)
+       really_new_inst_infos = zipWith gen_inst_info
+                                       new_inst_infos
+                                       dfun_names_w_method_binds
 
        ddump_deriv = ddump_deriving really_new_inst_infos rn_extra_binds
     in
@@ -552,10 +557,14 @@ the renamer.  What a great hack!
 -- Generate the method bindings for the required instance
 -- (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] _ _ _ _ _)
+gen_bind :: Fixities -> InstInfo -> ({-class-}OccName, {-tyCon-}OccName, RdrNameMonoBinds)
+gen_bind fixities (InstInfo clas _ [ty] _ _ _ _ _)
   | not from_here 
   = (clas_nm, tycon_nm, EmptyMonoBinds)
+  |  ckey == showClassKey 
+  = (clas_nm, tycon_nm, gen_Show_binds fixities tycon)
+  |  ckey == readClassKey 
+  = (clas_nm, tycon_nm, gen_Read_binds fixities tycon)
   | otherwise
   = (clas_nm, tycon_nm,
      assoc "gen_bind:bad derived class"
@@ -563,25 +572,24 @@ gen_bind (InstInfo clas _ [ty] _ _ _ _ _)
           ,(ordClassKey,     gen_Ord_binds)
           ,(enumClassKey,    gen_Enum_binds)
           ,(boundedClassKey, gen_Bounded_binds)
-          ,(showClassKey,    gen_Show_binds)
-          ,(readClassKey,    gen_Read_binds)
           ,(ixClassKey,      gen_Ix_binds)
           ]
-          (classKey clas) 
+          ckey
           tycon)
   where
       clas_nm     = nameOccName (getName clas)
       tycon_nm    = nameOccName (getName tycon)
       from_here   = isLocallyDefined tycon
       (tycon,_,_) = splitAlgTyConApp ty        
+      ckey       = classKey clas
            
 
-gen_inst_info :: Module                                        -- Module name
-             -> (InstInfo, (Name, RenamedMonoBinds))           -- the main stuff to work on
+gen_inst_info :: InstInfo
+             -> (Name, RenamedMonoBinds)
              -> InstInfo                               -- the gen'd (filled-in) "instance decl"
 
-gen_inst_info modname
-    (InstInfo clas tyvars tys@(ty:_) inst_decl_theta _ _ locn _, (dfun_name, meth_binds))
+gen_inst_info (InstInfo clas tyvars tys@(ty:_) inst_decl_theta _ _ locn _) 
+             (dfun_name, meth_binds)
   =
        -- Generate the various instance-related Ids
     InstInfo clas tyvars tys inst_decl_theta
@@ -663,7 +671,8 @@ gen_taggery_Names inst_infos
     do_tag2con acc_Names tycon
       | isDataTyCon tycon &&
          (we_are_deriving enumClassKey tycon ||
-         we_are_deriving ixClassKey   tycon)
+         we_are_deriving ixClassKey   tycon
+         && isEnumerationTyCon tycon)
       = returnTc ( (tag2con_RDR tycon, tycon, GenTag2Con)
                 : (maxtag_RDR  tycon, tycon, GenMaxTag)
                 : acc_Names)
@@ -681,7 +690,7 @@ gen_taggery_Names inst_infos
 \end{code}
 
 \begin{code}
-derivingThingErr :: FAST_STRING -> FAST_STRING -> TyCon -> ErrMsg
+derivingThingErr :: FAST_STRING -> FAST_STRING -> TyCon -> Message
 
 derivingThingErr thing why tycon
   = hang (hsep [ptext SLIT("Can't make a derived instance of"), ptext thing])