[project @ 2000-10-31 09:58:13 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs
index 55a805b..d7da12c 100644 (file)
--- a/ghc/compiler/typecheck/TcClassDcl.lhs
+++ b/ghc/compiler/typecheck/TcClassDcl.lhs
@@ -11,7 +11,7 @@ module TcClassDcl ( tcClassDecl1, tcClassDecls2, mkImplicitClassBinds,
 #include "HsVersions.h"
 
 import HsSyn           ( HsDecl(..), TyClDecl(..), Sig(..), MonoBinds(..),
-                         HsExpr(..), HsLit(..), HsType(..), HsPred(..),
+                         HsExpr(..), HsLit(..), HsType(..), HsPred(..), 
                          mkSimpleMatch, andMonoBinds, andMonoBindList, 
                          isClassDecl, isClassOpSig, isPragSig,
                          getClassDeclSysNames, tyClDeclName
@@ -26,7 +26,7 @@ import TcHsSyn                ( TcMonoBinds, idsToMonoBinds )
 
 import Inst            ( InstOrigin(..), LIE, emptyLIE, plusLIE, plusLIEs, 
                          newDicts, newMethod )
-import TcEnv           ( TcId, TcEnv, TyThingDetails(..), tcAddImportedIdInfo,
+import TcEnv           ( TcId, TcEnv, RecTcEnv, TyThingDetails(..), tcAddImportedIdInfo,
                          tcLookupClass, tcExtendTyVarEnvForMeths, tcExtendGlobalTyVars,
                          tcExtendLocalValEnv, tcExtendTyVarEnv, newDefaultMethodName
                        )
@@ -37,17 +37,18 @@ import TcType               ( TcType, TcTyVar, tcInstTyVars, zonkTcSigTyVars )
 import TcMonad
 import Generics                ( mkGenericRhs, validGenericMethodType )
 import PrelInfo                ( nO_METHOD_BINDING_ERROR_ID )
-import Class           ( classTyVars, classBigSig, classSelIds, classTyCon, 
-                         Class, ClassOpItem, DefMeth (..) )
+import Class           ( classTyVars, classBigSig, classSelIds, classTyCon, classTvsFds,
+                         Class, ClassOpItem, DefMeth (..), FunDep )
 import MkId            ( mkDictSelId, mkDataConId, mkDataConWrapId, mkDefaultMethodId )
 import DataCon         ( mkDataCon, notMarkedStrict )
 import Id              ( Id, idType, idName )
-import Name            ( Name, isLocallyDefined, NamedThing(..),
+import Module          ( Module )
+import Name            ( Name, NamedThing(..), isFrom,
                          NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, 
                          plusNameEnv, nameEnvElts )
 import NameSet         ( emptyNameSet )
 import Outputable
-import Type            ( Type, ClassContext, mkTyVarTys, mkDictTys, mkSigmaTy, mkClassPred,
+import Type            ( Type, ClassContext, mkTyVarTys, mkDictTys, mkClassPred,
                          splitTyConApp_maybe, isTyVarTy
                        )
 import Var             ( TyVar )
@@ -100,7 +101,7 @@ Death to "ExpandingDicts".
 %************************************************************************
 
 \begin{code}
-tcClassDecl1 :: TcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
+tcClassDecl1 :: RecTcEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails)
 tcClassDecl1 rec_env
             (ClassDecl context class_name
                        tyvar_names fundeps class_sigs def_methods
@@ -128,7 +129,7 @@ tcClassDecl1 rec_env
     tcSuperClasses clas context sc_sel_names   `thenTc` \ (sc_theta, sc_sel_ids) ->
 
        -- CHECK THE CLASS SIGNATURES,
-    mapTc (tcClassSig rec_env tyvar_names clas tyvars fds dm_info) 
+    mapTc (tcClassSig rec_env clas tyvars fds dm_info) 
          op_sigs                               `thenTc` \ sig_stuff ->
 
        -- MAKE THE CLASS DETAILS
@@ -236,8 +237,7 @@ tcSuperClasses clas context sc_sel_names
     is_tyvar other      = False
 
 
-tcClassSig :: TcEnv                    -- Knot tying only!
-          -> [HsTyVarBndr Name]        -- From the declaration, for error messages
+tcClassSig :: RecTcEnv
           -> Class                     -- ...ditto...
           -> [TyVar]                   -- The class type variable, used for error check only
           -> [FunDep TyVar]
@@ -251,7 +251,7 @@ tcClassSig :: TcEnv                 -- Knot tying only!
 -- so we distinguish them in checkDefaultBinds, and pass this knowledge in the
 -- Class.DefMeth data structure. 
 
-tcClassSig rec_env tyvar_names clas clas_tyvars fds dm_info
+tcClassSig unf_env clas clas_tyvars fds dm_info
           (ClassOpSig op_name maybe_dm op_ty src_loc)
   = tcAddSrcLoc src_loc $
 
@@ -260,9 +260,12 @@ tcClassSig rec_env tyvar_names clas clas_tyvars fds dm_info
 
     tcHsSigType op_ty                          `thenTc` \ local_ty ->
     let
-       theta       = [mkClassPred clas (mkTyVarTys clas_tyvars)]
-       global_ty   = mkSigmaTy clas_tyvars theta local_ty
+       theta = [mkClassPred clas (mkTyVarTys clas_tyvars)]
+    in
+       -- Check for ambiguous class op types
+    checkAmbiguity True clas_tyvars theta local_ty      `thenTc` \ global_ty ->
 
+    let
        -- Build the selector id and default method id
        sel_id      = mkDictSelId op_name clas
 
@@ -271,15 +274,10 @@ tcClassSig rec_env tyvar_names clas clas_tyvars fds dm_info
        dm_info_id = case dm_info_name of 
                        NoDefMeth       -> NoDefMeth
                        GenDefMeth      -> GenDefMeth
-                       DefMeth dm_name -> DefMeth (tcAddImportedIdInfo rec_env dm_id)
+                       DefMeth dm_name -> DefMeth (tcAddImportedIdInfo unf_env dm_id)
                                        where
                                           dm_id = mkDefaultMethodId dm_name clas global_ty
-
-       full_hs_ty = HsForAllTy (Just tyvar_names) op_ty
     in
-       -- Check for ambiguous class op types
-    checkAmbiguity full_ty clas_tyvars theta local_ty           `thenRn_`
-
        -- Check that for a generic method, the type of 
        -- the method is sufficiently simple
     checkTc (dm_info_name /= GenDefMeth || validGenericMethodType local_ty)
@@ -299,8 +297,8 @@ tcClassSig rec_env tyvar_names clas clas_tyvars fds dm_info
 and superclass dictionary.
 
 \begin{code}
-mkImplicitClassBinds :: [Class] -> NF_TcM ([Id], TcMonoBinds)
-mkImplicitClassBinds classes
+mkImplicitClassBinds :: Module -> [Class] -> NF_TcM ([Id], TcMonoBinds)
+mkImplicitClassBinds this_mod classes
   = returnNF_Tc (concat cls_ids_s, andMonoBindList binds_s)
        -- The selector binds are already in the selector Id's unfoldings
        -- We don't return the data constructor etc from the class,
@@ -311,8 +309,8 @@ mkImplicitClassBinds classes
     mk_implicit clas = (sel_ids, binds)
                     where
                        sel_ids = classSelIds clas
-                       binds | isLocallyDefined clas = idsToMonoBinds sel_ids
-                             | otherwise             = EmptyMonoBinds
+                       binds | isFrom this_mod clas = idsToMonoBinds sel_ids
+                             | otherwise            = EmptyMonoBinds
 \end{code}
 
 
@@ -382,14 +380,14 @@ The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to
 each local class decl.
 
 \begin{code}
-tcClassDecls2 :: [RenamedHsDecl] -> NF_TcM (LIE, TcMonoBinds)
+tcClassDecls2 :: Module -> [RenamedHsDecl] -> NF_TcM (LIE, TcMonoBinds)
 
-tcClassDecls2 decls
+tcClassDecls2 this_mod decls
   = foldr combine
          (returnNF_Tc (emptyLIE, EmptyMonoBinds))
          [tcClassDecl2 cls_decl | TyClD cls_decl <- decls, 
                                   isClassDecl cls_decl,
-                                  isLocallyDefined (tyClDeclName cls_decl)]
+                                  isFrom this_mod (tyClDeclName cls_decl)]
   where
     combine tc1 tc2 = tc1 `thenNF_Tc` \ (lie1, binds1) ->
                      tc2 `thenNF_Tc` \ (lie2, binds2) ->