[project @ 2000-05-15 11:21:22 by rrt]

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

diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index cd82d9e..4fc3937 100644 (file)
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -22,7 +22,7 @@ import TcHsSyn                ( TcMonoBinds, TypecheckedMonoBinds,
 import TcMonad
 import Inst            ( Inst, emptyLIE, plusLIE )
 import TcBinds         ( tcTopBindsAndThen )
-import TcClassDcl      ( tcClassDecls2 )
+import TcClassDcl      ( tcClassDecls2, mkImplicitClassBinds )
 import TcDefaults      ( tcDefaults )
 import TcEnv           ( tcExtendGlobalValEnv, tcExtendTypeEnv,
                          getEnvTyCons, getEnvClasses, tcLookupValueMaybe,
@@ -38,7 +38,7 @@ import TcInstDcls     ( tcInstDecls1, tcInstDecls2 )
 import TcInstUtil      ( buildInstanceEnvs, classDataCon, InstInfo )
 import TcSimplify      ( tcSimplifyTop )
 import TcTyClsDecls    ( tcTyAndClassDecls )
-import TcTyDecls       ( mkDataBinds )
+import TcTyDecls       ( mkImplicitDataBinds )
 import TcType          ( TcType, typeToTcType,
                          TcKind, kindToTcKind,
                          newTyVarTy
@@ -46,14 +46,11 @@ import TcType               ( TcType, typeToTcType,
 
 import RnMonad         ( RnNameSupply, getIfaceFixities, Fixities, InterfaceDetails )
 import Bag             ( isEmptyBag )
-import ErrUtils                ( Message,
-                         pprBagOfErrors, dumpIfSet
-                       )
+import ErrUtils                ( Message, printErrorsAndWarnings, dumpIfSet )
 import Id              ( Id, idType )
 import Module           ( pprModuleName )
 import Name            ( Name, nameUnique, isLocallyDefined, NamedThing(..) )
 import TyCon           ( TyCon, tyConKind )
-import DataCon         ( dataConId )
 import Class           ( Class, classSelIds, classTyCon )
 import Type            ( mkTyConApp, mkForAllTy,
                          boxedTypeKind, getTyVar, Type )
@@ -99,8 +96,7 @@ typecheckModule us rn_name_supply iface_det mod
   = initTc us initEnv (tcModule rn_name_supply (getIfaceFixities iface_det) mod)
                        >>= \ (maybe_result, warns, errs) ->
                
-    print_errs warns   >>
-    print_errs errs    >>
+    printErrorsAndWarnings errs warns          >>
 
     -- write the thin-air Id map
     (case maybe_result of
@@ -124,10 +120,6 @@ pp_rules [] = empty
 pp_rules rs = vcat [ptext SLIT("{-# RULES"),
                    nest 4 (vcat (map ppr rs)),
                    ptext SLIT("#-}")]
-
-print_errs errs
-  | isEmptyBag errs = return ()
-  | otherwise       = printErrs (pprBagOfErrors errs)
 \end{code}
 
 The internal monster:
@@ -138,7 +130,7 @@ tcModule :: RnNameSupply    -- for renaming derivings
         -> TcM s TcResults     -- output
 
 tcModule rn_name_supply fixities
-       (HsModule mod_name verion exports imports decls src_loc)
+       (HsModule mod_name verion exports imports decls _ src_loc)
   = tcAddSrcLoc src_loc $      -- record where we're starting
 
     fixTc (\ ~(unf_env ,_) ->
@@ -185,7 +177,8 @@ tcModule rn_name_supply fixities
            local_tycons  = filter isLocallyDefined tycons
            local_classes = filter isLocallyDefined classes
        in
-       mkDataBinds tycons              `thenTc` \ (data_ids, data_binds) ->
+       mkImplicitDataBinds tycons              `thenTc`    \ (data_ids, imp_data_binds) ->
+       mkImplicitClassBinds classes            `thenNF_Tc` \ (cls_ids,  imp_cls_binds) ->
        
        -- Extend the global value environment with 
        --      (a) constructors
@@ -194,14 +187,12 @@ tcModule rn_name_supply fixities
        --      (d) default-method ids... where? I can't see where these are
        --          put into the envt, and I'm worried that the zonking phase
        --          will find they aren't there and complain.
-       tcExtendGlobalValEnv data_ids                           $
-       tcExtendGlobalValEnv (concat (map classSelIds classes)) $
+       tcExtendGlobalValEnv data_ids           $
+       tcExtendGlobalValEnv cls_ids            $
 
        -- Extend the TyCon envt with the tycons corresponding to
-       -- the classes, and the global value environment with the
-       -- corresponding data cons.
+       -- the classes.
        --  They are mentioned in types in interface files.
-       tcExtendGlobalValEnv (map (dataConId . classDataCon) classes)           $
         tcExtendTypeEnv [ (getName tycon, (kindToTcKind (tyConKind tycon), Nothing, ATyCon tycon))
                        | clas <- classes,
                          let tycon = classTyCon clas
@@ -237,7 +228,7 @@ tcModule rn_name_supply fixities
                -- Second pass over class and instance declarations,
                -- to compile the bindings themselves.
        tcInstDecls2  inst_info         `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
-       tcClassDecls2 decls             `thenNF_Tc` \ (lie_clasdecls, cls_binds) ->
+       tcClassDecls2 decls             `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
        tcRules decls                   `thenNF_Tc` \ (lie_rules,     rules) ->
 
 
@@ -267,10 +258,11 @@ tcModule rn_name_supply fixities
            -- Backsubstitution.    This must be done last.
            -- Even tcSimplifyTop may do some unification.
        let
-           all_binds = data_binds              `AndMonoBinds` 
+           all_binds = imp_data_binds          `AndMonoBinds` 
+                       imp_cls_binds           `AndMonoBinds` 
                        val_binds               `AndMonoBinds`
                        inst_binds              `AndMonoBinds`
-                       cls_binds               `AndMonoBinds`
+                       cls_dm_binds            `AndMonoBinds`
                        const_inst_binds        `AndMonoBinds`
                        foe_binds
        in