[project @ 1996-05-01 18:36:59 by partain]

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

diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index d69a577..778a28a 100644 (file)
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -8,9 +8,7 @@ Handles @deriving@ clauses on @data@ declarations.
 \begin{code}
 #include "HsVersions.h"
 
-module TcDeriv (
-       tcDeriving
-    ) where
+module TcDeriv ( tcDeriving ) where
 
 import Ubiq
 
@@ -21,7 +19,7 @@ import HsPragmas      ( InstancePragmas(..) )
 import RnHsSyn         ( RenamedHsBinds(..), RenamedFixityDecl(..) )
 import TcHsSyn         ( TcIdOcc )
 
-import TcMonad
+import TcMonad         hiding ( rnMtoTcM )
 import Inst            ( InstOrigin(..), InstanceMapper(..) )
 import TcEnv           ( getEnv_TyCons )
 import TcKind          ( TcKind )
@@ -29,12 +27,12 @@ import TcKind               ( TcKind )
 import TcInstUtil      ( InstInfo(..), mkInstanceRelatedIds, buildInstanceEnvs )
 import TcSimplify      ( tcSimplifyThetas )
 
---import RnMonad4
-import RnUtils         ( GlobalNameMappers(..), GlobalNameMapper(..) )
---import RnBinds4              ( rnMethodBinds, rnTopBinds )
+import RnMonad
+import RnUtils         ( RnEnv(..) )
+import RnBinds         ( rnMethodBinds, rnTopBinds )
 
 import Bag             ( emptyBag{-ToDo:rm-}, Bag, isEmptyBag, unionBags, listToBag )
-import Class           ( GenClass, getClassKey )
+import Class           ( GenClass, classKey )
 import CmdLineOpts     ( opt_CompilingPrelude )
 import ErrUtils                ( pprBagOfErrors, addErrLoc, Error(..) )
 import Id              ( dataConSig, dataConArity )
@@ -50,7 +48,7 @@ import Type           ( GenType(..), TauType(..), mkTyVarTys, applyTyCon,
                          mkSigmaTy, mkDictTy, isPrimType, instantiateTy,
                          getAppTyCon, getAppDataTyCon )
 import TyVar           ( GenTyVar )
-import UniqFM          ( eltsUFM )
+import UniqFM          ( emptyUFM )
 import Unique          -- Keys stuff
 import Util            ( zipWithEqual, zipEqual, sortLt, removeDups, 
                          thenCmp, cmpList, panic, pprPanic, pprPanic# )
@@ -155,7 +153,7 @@ type DerivSoln = DerivRhs
 
 \begin{code}
 tcDeriving  :: Module                  -- name of module under scrutiny
-           -> GlobalNameMappers        -- for "renaming" bits of generated code
+           -> RnEnv                    -- for "renaming" bits of generated code
            -> Bag InstInfo             -- What we already know about instances
            -> [RenamedFixityDecl]      -- Fixity info; used by Read and Show
            -> TcM s (Bag InstInfo,     -- The generated "instance decls".
@@ -163,11 +161,11 @@ tcDeriving  :: Module                     -- name of module under scrutiny
                      PprStyle -> Pretty)  -- Printable derived instance decls;
                                           -- for debugging via -ddump-derivings.
 
-tcDeriving modname renamer_name_funs inst_decl_infos_in fixities
+tcDeriving modname rn_env inst_decl_infos_in fixities
   = returnTc (trace "tcDeriving:ToDo" (emptyBag, EmptyBinds, \ x -> ppNil))
 {- LATER:
 
-tcDeriving modname renamer_name_funs inst_decl_infos_in fixities
+tcDeriving modname rn_env inst_decl_infos_in fixities
   =    -- Fish the "deriving"-related information out of the TcEnv
        -- and make the necessary "equations".
     makeDerivEqns              `thenTc` \ eqns ->
@@ -205,9 +203,9 @@ tcDeriving modname renamer_name_funs inst_decl_infos_in fixities
        assoc_maybe ((k,v) : vs) key
          = if k `eqProtoName` key then Just v else assoc_maybe vs key
     in
-    gen_tag_n_con_binds deriver_name_funs nm_alist_etc `thenTc` \ extra_binds ->
+    gen_tag_n_con_binds deriver_rn_env nm_alist_etc `thenTc` \ extra_binds ->
 
-    mapTc (gen_inst_info maybe_mod fixities deriver_name_funs) new_inst_infos
+    mapTc (gen_inst_info maybe_mod fixities deriver_rn_env) new_inst_infos
                                                  `thenTc` \ really_new_inst_infos ->
 
     returnTc (listToBag really_new_inst_infos,
@@ -281,7 +279,7 @@ makeDerivEqns
     chk_out :: [(Class, TyCon)] -> (Class, TyCon) -> TcM s ()
     chk_out whole_deriving_list this_one@(clas, tycon)
       =        let
-           clas_key = getClassKey clas
+           clas_key = classKey clas
        in
 
            -- Are things OK for deriving Enum (if appropriate)?
@@ -512,11 +510,11 @@ the renamer.  What a great hack!
 gen_inst_info :: Maybe Module          -- Module name; Nothing => Prelude
              -> [RenamedFixityDecl]    -- all known fixities;
                                        -- may be needed for Text
-             -> GlobalNameMappers              -- lookup stuff for names we may use
+             -> RnEnv                  -- lookup stuff for names we may use
              -> InstInfo               -- the main stuff to work on
              -> TcM s InstInfo         -- the gen'd (filled-in) "instance decl"
 
-gen_inst_info modname fixities deriver_name_funs
+gen_inst_info modname fixities deriver_rn_env
     info@(InstInfo clas tyvars ty inst_decl_theta _ _ _ _ _ _ locn _)
   =
        -- Generate the various instance-related Ids
@@ -543,7 +541,8 @@ gen_inst_info modname fixities deriver_name_funs
          | clas_key == binaryClassKey = gen_Binary_binds tycon
          | otherwise = panic "gen_inst_info:bad derived class"
     in
-    rn4MtoTcM deriver_name_funs (
+    rnMtoTcM deriver_rn_env (
+       setExtraRn emptyUFM{-no fixities-} $
        rnMethodBinds clas_Name proto_mbinds
     )                  `thenNF_Tc` \ (mbinds, errs) ->
 
@@ -562,7 +561,7 @@ gen_inst_info modname fixities deriver_name_funs
                       (if from_here then mbinds else EmptyMonoBinds)
                       from_here modname locn [])
   where
-    clas_key = getClassKey clas
+    clas_key = classKey clas
     clas_Name
       = let  (mod, nm) = moduleNamePair clas  in
        ClassName clas_key (mkPreludeCoreName mod nm) []
@@ -581,17 +580,18 @@ tag2con_Foo :: Int -> Foo ...     -- easier if Int, not Int#
 maxtag_Foo  :: Int             -- ditto (NB: not unboxed)
 
 \begin{code}
-gen_tag_n_con_binds :: GlobalNameMappers
+gen_tag_n_con_binds :: RnEnv
                    -> [(RdrName, RnName, TyCon, TagThingWanted)]
                    -> TcM s RenamedHsBinds
 
-gen_tag_n_con_binds deriver_name_funs nm_alist_etc
+gen_tag_n_con_binds deriver_rn_env nm_alist_etc
   = let
       proto_mbind_list = map gen_tag_n_con_monobind nm_alist_etc
       proto_mbinds     = foldr AndMonoBinds EmptyMonoBinds proto_mbind_list
     in
 
-    rn4MtoTcM deriver_name_funs (
+    rnMtoTcM deriver_rn_env (
+       setExtraRn emptyUFM{-no fixities-} $
        rnTopBinds (SingleBind (RecBind proto_mbinds))
     )                  `thenNF_Tc` \ (binds, errs) ->
 
@@ -670,7 +670,7 @@ gen_taggery_Names eqns
       where
        is_in_eqns clas_key tycon [] = False
        is_in_eqns clas_key tycon ((c,t,_,_):eqns)
-         =  (clas_key == getClassKey c && tycon == t)
+         =  (clas_key == classKey c && tycon == t)
          || is_in_eqns clas_key tycon eqns
 
 \end{code}