[project @ 2001-10-18 16:29:12 by simonpj]

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

diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs
index cc1c949..e799f09 100644 (file)
--- a/ghc/compiler/typecheck/TcModule.lhs
+++ b/ghc/compiler/typecheck/TcModule.lhs
@@ -6,6 +6,7 @@
 \begin{code}
 module TcModule (
        typecheckModule, typecheckIface, typecheckStmt, typecheckExpr,
+       typecheckExtraDecls,
        TcResults(..)
     ) where
 
@@ -60,7 +61,7 @@ import ErrUtils               ( printErrorsAndWarnings, errorsFound,
 import Id              ( Id, idType, idUnfolding )
 import Module           ( Module, moduleName )
 import Name            ( Name )
-import NameEnv         ( nameEnvElts, lookupNameEnv )
+import NameEnv         ( lookupNameEnv )
 import TyCon           ( tyConGenInfo )
 import BasicTypes       ( EP(..), Fixity, RecFlag(..) )
 import SrcLoc          ( noSrcLoc )
@@ -69,8 +70,8 @@ import IO             ( stdout )
 import HscTypes                ( PersistentCompilerState(..), HomeSymbolTable, 
                          PackageTypeEnv, ModIface(..),
                          ModDetails(..), DFunId,
-                         TypeEnv, extendTypeEnvList, 
-                         TyThing(..), implicitTyThingIds, 
+                         TypeEnv, extendTypeEnvList, typeEnvTyCons, typeEnvElts,
+                         TyThing(..), 
                          mkTypeEnv
                        )
 \end{code}
@@ -289,6 +290,33 @@ typecheckExpr dflags pcs hst ic_type_env unqual this_mod (expr, decls)
 
 %************************************************************************
 %*                                                                     *
+\subsection{Typechecking extra declarations}
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+typecheckExtraDecls 
+   :: DynFlags
+   -> PersistentCompilerState
+   -> HomeSymbolTable
+   -> PrintUnqualified    -- For error printing
+   -> Module              -- Is this really needed
+   -> [RenamedHsDecl]     -- extra decls sucked in from interface files
+   -> IO (Maybe PersistentCompilerState)
+
+typecheckExtraDecls  dflags pcs hst unqual this_mod decls
+ = typecheck dflags pcs hst unqual $
+     fixTc (\ ~(unf_env, _, _, _, _) ->
+         tcImports unf_env pcs hst get_fixity this_mod decls
+     ) `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
+     ASSERT( null local_inst_info && nullBinds deriv_binds && null local_rules )
+     returnTc new_pcs
+ where
+    get_fixity n = pprPanic "typecheckExpr" (ppr n)
+\end{code}
+
+%************************************************************************
+%*                                                                     *
 \subsection{Typechecking a module}
 %*                                                                     *
 %************************************************************************
@@ -419,17 +447,7 @@ tcModule pcs hst get_fixity this_mod decls
        zonkRules more_local_rules      `thenNF_Tc` \ more_local_rules' ->
        
        
-       let     local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv final_env))
-       
-               -- Create any necessary "implicit" bindings (data constructors etc)
-               -- Should we create bindings for dictionary constructors?
-               -- They are always fully applied, and the bindings are just there
-               -- to support partial applications. But it's easier to let them through.
-               implicit_binds = andMonoBindList [ CoreMonoBind id (unfoldingTemplate unf)
-                                                | id <- implicitTyThingIds local_things
-                                                , let unf = idUnfolding id
-                                                , hasUnfolding unf
-                                                ]
+       let     local_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env))
        
                local_type_env :: TypeEnv
                local_type_env = mkTypeEnv local_things
@@ -441,7 +459,7 @@ tcModule pcs hst get_fixity this_mod decls
                  new_pcs,
                  TcResults { tc_env     = local_type_env,
                              tc_insts   = map iDFunId local_insts,
-                             tc_binds   = implicit_binds `AndMonoBinds` all_binds', 
+                             tc_binds   = all_binds', 
                              tc_fords   = foi_decls ++ foe_decls',
                              tc_rules   = all_local_rules
                            }
@@ -491,7 +509,7 @@ typecheckIface dflags pcs hst mod_iface decls
                            deriv_binds, local_rules) ->
          ASSERT(nullBinds deriv_binds)
          let 
-             local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv env))
+             local_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv env))
 
              mod_details = ModDetails { md_types = mkTypeEnv local_things,
                                         md_insts = map iDFunId local_inst_info,
@@ -530,9 +548,9 @@ tcImports unf_env pcs hst get_fixity this_mod decls
        -- tcImports recovers internally, but if anything gave rise to
        -- an error we'd better stop now, to avoid a cascade
        
-    traceTc (text "Tc1")                       `thenNF_Tc_`
-    tcTyAndClassDecls unf_env tycl_decls       `thenTc` \ env ->
-    tcSetEnv env                               $
+    traceTc (text "Tc1")                               `thenNF_Tc_`
+    tcTyAndClassDecls unf_env this_mod tycl_decls      `thenTc` \ env ->
+    tcSetEnv env                                       $
     
        -- Typecheck the instance decls, includes deriving
     traceTc (text "Tc2")       `thenNF_Tc_`
@@ -552,14 +570,14 @@ tcImports unf_env pcs hst get_fixity this_mod decls
     tcExtendGlobalValEnv sig_ids               $
     
     
-    tcIfaceRules (pcs_rules pcs) this_mod iface_rules  `thenNF_Tc` \ (new_pcs_rules, local_rules) ->
+    tcIfaceRules unf_env (pcs_rules pcs) this_mod iface_rules  `thenNF_Tc` \ (new_pcs_rules, local_rules) ->
        -- When relinking this module from its interface-file decls
        -- we'll have IfaceRules that are in fact local to this module
        -- That's the reason we we get any local_rules out here
     
     tcGetEnv                                           `thenTc` \ unf_env ->
     let
-        all_things = nameEnvElts (getTcGEnv unf_env)
+        all_things = typeEnvElts (getTcGEnv unf_env)
     
          -- sometimes we're compiling in the context of a package module
          -- (on the GHCi command line, for example).  In this case, we
@@ -694,7 +712,7 @@ dump_tc_iface dflags results
          ppr_rules (tc_rules results),
 
          if dopt Opt_Generics dflags then
-               ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
+               ppr_gen_tycons (typeEnvTyCons (tc_env results))
          else 
                empty
     ]