[project @ 2000-07-11 16:24:57 by simonmar]

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

diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs
index c929ed1..44a0c5e 100644 (file)
--- a/ghc/compiler/typecheck/TcDeriv.lhs
+++ b/ghc/compiler/typecheck/TcDeriv.lhs
@@ -16,10 +16,9 @@ import RnHsSyn               ( RenamedHsBinds, RenamedMonoBinds )
 import CmdLineOpts     ( opt_D_dump_deriv )
 
 import TcMonad
-import Inst            ( InstanceMapper )
-import TcEnv           ( getEnvTyCons )
+import TcEnv           ( InstEnv, getEnvTyCons, tcSetInstEnv )
 import TcGenDeriv      -- Deriv stuff
-import TcInstUtil      ( InstInfo(..), buildInstanceEnvs )
+import TcInstUtil      ( InstInfo(..), buildInstanceEnv )
 import TcSimplify      ( tcSimplifyThetas )
 
 import RnBinds         ( rnMethodBinds, rnTopMonoBinds )
@@ -41,7 +40,7 @@ import Name           ( isLocallyDefined, getSrcLoc,
                          OccName, nameOccName
                        )
 import RdrName         ( RdrName )
-import RnMonad         ( Fixities )
+import RnMonad         ( FixityEnv )
 import SrcLoc          ( mkGeneratedSrcLoc, SrcLoc )
 import TyCon           ( tyConTyVars, tyConDataCons, tyConDerivings,
                          tyConTheta, maybeTyConSingleCon, isDataTyCon,
@@ -51,7 +50,6 @@ import Type           ( TauType, mkTyVarTys, mkTyConApp,
                          mkSigmaTy, mkDictTy, isUnboxedType,
                          splitAlgTyConApp, classesToPreds
                        )
-import PprType          ( {- instance Outputable Type -} )
 import TysWiredIn      ( voidTy )
 import Var             ( TyVar )
 import Unique          -- Keys stuff
@@ -188,7 +186,7 @@ context to the instance decl.  The "offending classes" are
 
 \begin{code}
 tcDeriving  :: ModuleName              -- name of module under scrutiny
-           -> Fixities                 -- for the deriving code (Show/Read.)
+           -> FixityEnv                -- 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".
@@ -352,14 +350,12 @@ makeDerivEqns
     ------------------------------------------------------------------
     chk_out :: Class -> TyCon -> Maybe Message
     chk_out clas tycon
-       | clas_key == enumClassKey    && not is_enumeration           = bog_out nullary_why
-       | clas_key == boundedClassKey && not is_enumeration_or_single = bog_out single_nullary_why
-       | clas_key == ixClassKey      && not is_enumeration_or_single = bog_out single_nullary_why
+       | clas `hasKey` enumClassKey    && not is_enumeration         = bog_out nullary_why
+       | clas `hasKey` boundedClassKey && not is_enumeration_or_single = bog_out single_nullary_why
+       | clas `hasKey` ixClassKey      && not is_enumeration_or_single = bog_out single_nullary_why
        | any isExistentialDataCon (tyConDataCons tycon)              = Just (existentialErr clas tycon)
        | otherwise                                                   = Nothing
        where
-           clas_key = classKey clas
-
            is_enumeration = isEnumerationTyCon tycon
            is_single_con  = maybeToBool (maybeTyConSingleCon tycon)
            is_enumeration_or_single = is_enumeration || is_single_con
@@ -424,15 +420,15 @@ solveDerivEqns inst_decl_infos_in orig_eqns
            -- with the current set of solutions, giving a
 
        add_solns inst_decl_infos_in orig_eqns current_solns
-                               `thenNF_Tc` \ (new_inst_infos, inst_mapper) ->
-       let
-          class_to_inst_env cls = inst_mapper cls
-       in
+                               `thenNF_Tc` \ (new_inst_infos, inst_env) ->
+
            -- Simplify each RHS
 
-       listTc [ tcAddErrCtxt (derivCtxt tc) $
-                tcSimplifyThetas class_to_inst_env deriv_rhs
-              | (_,tc,_,deriv_rhs) <- orig_eqns ]  `thenTc` \ next_solns ->
+       tcSetInstEnv inst_env (
+         listTc [ tcAddErrCtxt (derivCtxt tc) $
+                  tcSimplifyThetas deriv_rhs
+                | (_,tc,_,deriv_rhs) <- orig_eqns ]  
+       )                                               `thenTc` \ next_solns ->
 
            -- Canonicalise the solutions, so they compare nicely
        let canonicalised_next_solns
@@ -445,18 +441,18 @@ solveDerivEqns inst_decl_infos_in orig_eqns
 add_solns :: Bag InstInfo                      -- The global, non-derived ones
          -> [DerivEqn] -> [DerivSoln]
          -> NF_TcM s ([InstInfo],              -- The new, derived ones
-                      InstanceMapper)
+                      InstEnv)
     -- the eqns and solns move "in lockstep"; we have the eqns
     -- because we need the LHS info for addClassInstance.
 
 add_solns inst_infos_in eqns solns
 
-  = discardErrsTc (buildInstanceEnvs all_inst_infos)   `thenNF_Tc` \ inst_mapper ->
+  = discardErrsTc (buildInstanceEnv all_inst_infos)    `thenNF_Tc` \ inst_env ->
        -- We do the discard-errs so that we don't get repeated error messages
        -- about duplicate instances.
-       -- They'll appear later, when we do the top-level buildInstanceEnvs.
+       -- They'll appear later, when we do the top-level buildInstanceEnv.
 
-    returnNF_Tc (new_inst_infos, inst_mapper)
+    returnNF_Tc (new_inst_infos, inst_env)
   where
     new_inst_infos = zipWithEqual "add_solns" mk_deriv_inst_info eqns solns
 
@@ -555,13 +551,13 @@ 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 :: Fixities -> InstInfo -> ({-class-}OccName, {-tyCon-}OccName, RdrNameMonoBinds)
+gen_bind :: FixityEnv -> InstInfo -> ({-class-}OccName, {-tyCon-}OccName, RdrNameMonoBinds)
 gen_bind fixities (InstInfo clas _ [ty] _ _ _ _ _)
   | not from_here 
   = (clas_nm, tycon_nm, EmptyMonoBinds)
-  |  ckey == showClassKey 
+  |  clas `hasKey` showClassKey 
   = (clas_nm, tycon_nm, gen_Show_binds fixities tycon)
-  |  ckey == readClassKey 
+  |  clas `hasKey` readClassKey 
   = (clas_nm, tycon_nm, gen_Read_binds fixities tycon)
   | otherwise
   = (clas_nm, tycon_nm,
@@ -572,15 +568,13 @@ gen_bind fixities (InstInfo clas _ [ty] _ _ _ _ _)
           ,(boundedClassKey, gen_Bounded_binds)
           ,(ixClassKey,      gen_Ix_binds)
           ]
-          ckey
+          (classKey clas)
           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 :: InstInfo
              -> (Name, RenamedMonoBinds)