[project @ 2001-02-23 12:24:10 by simonmar]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcModule.lhs
index 7c5f5f1..50343ef 100644 (file)
@@ -5,7 +5,7 @@
 
 \begin{code}
 module TcModule (
-       typecheckModule, typecheckExpr, TcResults(..)
+       typecheckModule, typecheckIface, typecheckExpr, TcResults(..)
     ) where
 
 #include "HsVersions.h"
@@ -15,7 +15,7 @@ import HsSyn          ( HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
                          isIfaceRuleDecl, nullBinds, andMonoBindList
                        )
 import HsTypes         ( toHsType )
-import PrelNames       ( mAIN_Name, mainName, ioTyConName, printName )
+import PrelNames       ( SyntaxMap, mAIN_Name, mainName, ioTyConName, printName )
 import RnHsSyn         ( RenamedHsBinds, RenamedHsDecl, RenamedHsExpr )
 import TcHsSyn         ( TypecheckedMonoBinds, TypecheckedHsExpr,
                          TypecheckedForeignDecl, TypecheckedRuleDecl,
@@ -33,7 +33,7 @@ import TcBinds                ( tcTopBinds )
 import TcClassDcl      ( tcClassDecls2 )
 import TcDefaults      ( tcDefaults, defaultDefaultTys )
 import TcExpr          ( tcMonoExpr )
-import TcEnv           ( TcEnv, InstInfo, tcExtendGlobalValEnv, tcLookup_maybe,
+import TcEnv           ( TcEnv, RecTcEnv, InstInfo, tcExtendGlobalValEnv, tcLookup_maybe,
                          isLocalThing, tcSetEnv, tcSetInstEnv, initTcEnv, getTcGEnv,
                          TcTyThing(..), tcLookupTyCon
                        )
@@ -82,16 +82,16 @@ typecheckModule
        :: DynFlags
        -> PersistentCompilerState
        -> HomeSymbolTable
-       -> ModIface             -- Iface for this module
+       -> ModIface             -- Iface for this module (just module & fixities)
        -> PrintUnqualified     -- For error printing
-       -> [RenamedHsDecl]
+       -> (SyntaxMap, [RenamedHsDecl])
        -> IO (Maybe (PersistentCompilerState, TcResults))
                        -- The new PCS is Augmented with imported information,
                                                -- (but not stuff from this module)
 
 
-typecheckModule dflags pcs hst mod_iface unqual decls
-  = do { maybe_tc_result <- typecheck dflags pcs hst unqual $
+typecheckModule dflags pcs hst mod_iface unqual (syn_map, decls)
+  = do { maybe_tc_result <- typecheck dflags syn_map pcs hst unqual $
                             tcModule pcs hst get_fixity this_mod decls
        ; printTcDump dflags maybe_tc_result
        ; return maybe_tc_result }
@@ -103,38 +103,76 @@ typecheckModule dflags pcs hst mod_iface unqual decls
     get_fixity nm = lookupNameEnv fixity_env nm
 
 ---------------
+typecheckIface
+       :: DynFlags
+       -> PersistentCompilerState
+       -> HomeSymbolTable
+       -> ModIface             -- Iface for this module (just module & fixities)
+       -> (SyntaxMap, [RenamedHsDecl])
+       -> IO (Maybe (PersistentCompilerState, TypeEnv, [TypecheckedRuleDecl]))
+                       -- The new PCS is Augmented with imported information,
+                       -- (but not stuff from this module).
+                       -- The TcResults returned contains only the environment
+                       -- and rules.
+
+
+typecheckIface dflags pcs hst mod_iface (syn_map, decls)
+  = do { maybe_tc_stuff <- typecheck dflags syn_map pcs hst alwaysQualify $
+                           tcIfaceImports pcs hst get_fixity this_mod decls
+       ; printIfaceDump dflags maybe_tc_stuff
+       ; return maybe_tc_stuff }
+  where
+    this_mod   = mi_module   mod_iface
+    fixity_env = mi_fixities mod_iface
+
+    get_fixity :: Name -> Maybe Fixity
+    get_fixity nm = lookupNameEnv fixity_env nm
+
+    tcIfaceImports pcs hst get_fixity this_mod decls
+       = 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(nullBinds deriv_binds)
+         let 
+             local_things = filter (isLocalThing this_mod) 
+                                       (nameEnvElts (getTcGEnv env))
+             local_type_env :: TypeEnv
+             local_type_env = mkTypeEnv local_things
+         in
+
+         -- throw away local_inst_info
+          returnTc (new_pcs, local_type_env, local_rules)
+
+---------------
 typecheckExpr :: DynFlags
              -> Bool                   -- True <=> wrap in 'print' to get a result of IO type
              -> PersistentCompilerState
              -> HomeSymbolTable
              -> PrintUnqualified       -- For error printing
              -> Module
-             -> (RenamedHsExpr,        -- The expression itself
+             -> (SyntaxMap,
+                 RenamedHsExpr,        -- The expression itself
                  [RenamedHsDecl])      -- Plus extra decls it sucked in from interface files
              -> IO (Maybe (PersistentCompilerState, TypecheckedHsExpr, TcType))
 
-typecheckExpr dflags wrap_io pcs hst unqual this_mod (expr, decls)
-  = typecheck dflags pcs hst unqual $
+typecheckExpr dflags wrap_io pcs hst unqual this_mod (syn_map, expr, decls)
+  = typecheck dflags syn_map pcs hst unqual $
 
         -- use the default default settings, i.e. [Integer, Double]
     tcSetDefaultTys defaultDefaultTys $
-    tcImports pcs hst get_fixity this_mod decls        `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
+
+       -- Typecheck the extra declarations
+    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 )
 
+       -- Now typecheck the expression
     tcSetEnv env                               $
-    tc_expr expr                                       `thenTc` \ (expr', lie, expr_ty) ->
-    tcSimplifyInfer smpl_doc 
-       (varSetElems (tyVarsOfType expr_ty)) lie        `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) ->
-    tcSimplifyTop lie_free                             `thenTc` \ const_binds ->
-    let all_expr = mkHsLet const_binds $
-                  TyLam qtvs           $
-                  DictLam dict_ids     $
-                  mkHsLet dict_binds   $
-                  expr'
-       all_expr_ty = mkForAllTys qtvs (mkFunTys (map idType dict_ids) expr_ty)
-    in
-    zonkExpr all_expr                                  `thenNF_Tc` \ zonked_expr ->
-    zonkTcType all_expr_ty                             `thenNF_Tc` \ zonked_ty ->
+    tc_expr expr                                       `thenTc` \ (expr', expr_ty) ->
+    zonkExpr expr'                                     `thenNF_Tc` \ zonked_expr ->
+    zonkTcType expr_ty                                 `thenNF_Tc` \ zonked_ty ->
     ioToTc (dumpIfSet_dyn dflags 
                Opt_D_dump_tc "Typechecked" (ppr zonked_expr)) `thenNF_Tc_`
     returnTc (new_pcs, zonked_expr, zonked_ty) 
@@ -152,31 +190,43 @@ typecheckExpr dflags wrap_io pcs hst unqual this_mod (expr, decls)
        | wrap_io   = tryTc_ (tc_io_expr (HsApp (HsVar printName) e))   -- Recovery case
                             (tc_io_expr e)                             -- Main case
        | otherwise = newTyVarTy openTypeKind   `thenTc` \ ty ->
-                     tcMonoExpr expr ty        `thenTc` \ (expr', lie) ->
-                     returnTc (expr', lie, ty)
-                     
+                     tcMonoExpr e ty           `thenTc` \ (e', lie) ->
+                     tcSimplifyInfer smpl_doc (varSetElems (tyVarsOfType ty)) lie 
+                               `thenTc` \ (qtvs, lie_free, dict_binds, dict_ids) ->
+                     tcSimplifyTop lie_free    `thenTc` \ const_binds ->
+                     let all_expr = mkHsLet const_binds        $
+                                    TyLam qtvs                 $
+                                    DictLam dict_ids           $
+                                    mkHsLet dict_binds         $       
+                                    e'
+                         all_expr_ty = mkForAllTys qtvs        $
+                                       mkFunTys (map idType dict_ids) $
+                                       ty
+                     in
+                     returnTc (all_expr, all_expr_ty)
        where
-               -- (tc_io_expr e) typechecks 'e' if that gives a result of IO t,
-               -- or 'print e' otherwise.  Either way the result is of type IO t
          tc_io_expr e = newTyVarTy openTypeKind        `thenTc` \ ty ->
                         tcLookupTyCon ioTyConName      `thenNF_Tc` \ ioTyCon ->
                         let
                            res_ty = mkTyConApp ioTyCon [ty]
                         in
-                        tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
-                        returnTc (expr', lie, res_ty)
+                        tcMonoExpr e res_ty    `thenTc` \ (e', lie) ->
+                        tcSimplifyTop lie      `thenTc` \ const_binds ->
+                        let all_expr = mkHsLet const_binds e' in
+                        returnTc (all_expr, res_ty)
 
 ---------------
 typecheck :: DynFlags
+         -> SyntaxMap
          -> PersistentCompilerState
          -> HomeSymbolTable
          -> PrintUnqualified   -- For error printing
          -> TcM r
          -> IO (Maybe r)
 
-typecheck dflags pcs hst unqual thing_inside 
+typecheck dflags syn_map pcs hst unqual thing_inside 
  = do  { showPass dflags "Typechecker";
-       ; env <- initTcEnv hst (pcs_PTE pcs)
+       ; env <- initTcEnv syn_map hst (pcs_PTE pcs)
 
        ; (maybe_tc_result, errs) <- initTc dflags env thing_inside
 
@@ -199,100 +249,107 @@ tcModule :: PersistentCompilerState
         -> TcM (PersistentCompilerState, TcResults)
 
 tcModule pcs hst get_fixity this_mod decls
-  =    -- Type-check the type and class decls, and all imported decls
-       -- tcImports recovers internally, but if anything gave rise to
-       -- an error we'd better stop now, to avoid a cascade
-    checkNoErrsTc (
-       tcImports pcs hst get_fixity this_mod decls
-    )                                          `thenTc` \ (env, new_pcs, local_inst_info, deriv_binds, local_rules) ->
+  = fixTc (\ ~(unf_env, _, _) ->
+               -- Loop back the final environment, including the fully zonkec
+               -- versions of bindings from this module.  In the presence of mutual
+               -- recursion, interface type signatures may mention variables defined
+               -- in this module, which is why the knot is so big
 
-    tcSetEnv env                               $
+               -- Type-check the type and class decls, and all imported decls
+       tcImports unf_env pcs hst get_fixity this_mod decls     
+                               `thenTc` \ (env, new_pcs, local_insts, deriv_binds, local_rules) ->
+
+       tcSetEnv env                            $
 
         -- Foreign import declarations next
---  traceTc (text "Tc4")                       `thenNF_Tc_`
-    tcForeignImports decls                     `thenTc`    \ (fo_ids, foi_decls) ->
-    tcExtendGlobalValEnv fo_ids                        $
+        traceTc (text "Tc4")                   `thenNF_Tc_`
+       tcForeignImports decls                  `thenTc`    \ (fo_ids, foi_decls) ->
+       tcExtendGlobalValEnv fo_ids             $
     
        -- Default declarations
-    tcDefaults decls                           `thenTc` \ defaulting_tys ->
-    tcSetDefaultTys defaulting_tys             $
+       tcDefaults decls                        `thenTc` \ defaulting_tys ->
+       tcSetDefaultTys defaulting_tys          $
        
        -- Value declarations next.
        -- We also typecheck any extra binds that came out of the "deriving" process
---  traceTc (text "Tc5")                               `thenNF_Tc_`
-    tcTopBinds (val_binds `ThenBinds` deriv_binds)     `thenTc` \ ((val_binds, env), lie_valdecls) ->
-    tcSetEnv env $
-    
-       -- Foreign export declarations next
---  traceTc (text "Tc6")               `thenNF_Tc_`
-    tcForeignExports decls             `thenTc`    \ (lie_fodecls, foe_binds, foe_decls) ->
-    
-       -- Second pass over class and instance declarations,
-       -- to compile the bindings themselves.
-    tcInstDecls2  local_inst_info              `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
-    tcClassDecls2 this_mod tycl_decls          `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
-    tcSourceRules source_rules                 `thenNF_Tc` \ (lie_rules,     more_local_rules) ->
-    
-         -- Deal with constant or ambiguous InstIds.  How could
-         -- there be ambiguous ones?  They can only arise if a
-         -- top-level decl falls under the monomorphism
-         -- restriction, and no subsequent decl instantiates its
-         -- type.  (Usually, ambiguous type variables are resolved
-         -- during the generalisation step.)
-    let
-        lie_alldecls = lie_valdecls    `plusLIE`
-                      lie_instdecls    `plusLIE`
-                      lie_clasdecls    `plusLIE`
-                      lie_fodecls      `plusLIE`
-                      lie_rules
-    in
-    tcSimplifyTop lie_alldecls                 `thenTc` \ const_inst_binds ->
-
-       -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
-    tcCheckMain this_mod                       `thenTc_`
-    
-        -- Backsubstitution.    This must be done last.
-        -- Even tcSimplifyTop may do some unification.
-    let
-        all_binds = val_binds          `AndMonoBinds`
-                   inst_binds          `AndMonoBinds`
-                   cls_dm_binds        `AndMonoBinds`
-                   const_inst_binds    `AndMonoBinds`
-                   foe_binds
-    in
---  traceTc (text "Tc9")               `thenNF_Tc_`
-    zonkTopBinds all_binds             `thenNF_Tc` \ (all_binds', final_env)  ->
-    tcSetEnv final_env                 $
-       -- zonkTopBinds puts all the top-level Ids into the tcGEnv
-    zonkForeignExports foe_decls       `thenNF_Tc` \ foe_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
-                                        ]
-
-       local_type_env :: TypeEnv
-       local_type_env = mkTypeEnv local_things
-           
-       all_local_rules = local_rules ++ more_local_rules'
-    in  
---  traceTc (text "Tc10")              `thenNF_Tc_`
-    returnTc (new_pcs,
-             TcResults { tc_env     = local_type_env,
-                         tc_binds   = implicit_binds `AndMonoBinds` all_binds', 
-                         tc_fords   = foi_decls ++ foe_decls',
-                         tc_rules   = all_local_rules
-                        }
-    )
+       traceTc (text "Default types" <+> ppr defaulting_tys)   `thenNF_Tc_`
+        traceTc (text "Tc5")                           `thenNF_Tc_`
+       tcTopBinds (val_binds `ThenBinds` deriv_binds)  `thenTc` \ ((val_binds, env), lie_valdecls) ->
+       
+       -- Second pass over class and instance declarations, 
+       -- plus rules and foreign exports, to generate bindings
+       tcSetEnv env                            $
+       tcInstDecls2  local_insts               `thenNF_Tc` \ (lie_instdecls, inst_binds) ->
+       tcClassDecls2 this_mod tycl_decls       `thenNF_Tc` \ (lie_clasdecls, cls_dm_binds) ->
+       tcForeignExports decls                  `thenTc`    \ (lie_fodecls,   foe_binds, foe_decls) ->
+       tcSourceRules source_rules              `thenNF_Tc` \ (lie_rules,     more_local_rules) ->
+       
+            -- Deal with constant or ambiguous InstIds.  How could
+            -- there be ambiguous ones?  They can only arise if a
+            -- top-level decl falls under the monomorphism
+            -- restriction, and no subsequent decl instantiates its
+            -- type.  (Usually, ambiguous type variables are resolved
+            -- during the generalisation step.)
+       let
+           lie_alldecls = lie_valdecls  `plusLIE`
+                          lie_instdecls `plusLIE`
+                          lie_clasdecls `plusLIE`
+                          lie_fodecls   `plusLIE`
+                          lie_rules
+       in
+        traceTc (text "Tc6")                           `thenNF_Tc_`
+       tcSimplifyTop lie_alldecls                      `thenTc` \ const_inst_binds ->
+       
+               -- CHECK THAT main IS DEFINED WITH RIGHT TYPE, IF REQUIRED
+       tcCheckMain this_mod            `thenTc_`
+       
+           -- Backsubstitution.    This must be done last.
+           -- Even tcSimplifyTop may do some unification.
+       let
+           all_binds = val_binds               `AndMonoBinds`
+                           inst_binds          `AndMonoBinds`
+                           cls_dm_binds        `AndMonoBinds`
+                           const_inst_binds    `AndMonoBinds`
+                           foe_binds
+       in
+       traceTc (text "Tc7")            `thenNF_Tc_`
+       zonkTopBinds all_binds          `thenNF_Tc` \ (all_binds', final_env)  ->
+       tcSetEnv final_env              $
+               -- zonkTopBinds puts all the top-level Ids into the tcGEnv
+       traceTc (text "Tc8")            `thenNF_Tc_`
+       zonkForeignExports foe_decls    `thenNF_Tc` \ foe_decls' ->
+       traceTc (text "Tc9")            `thenNF_Tc_`
+       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
+                                                ]
+       
+               local_type_env :: TypeEnv
+               local_type_env = mkTypeEnv local_things
+                   
+               all_local_rules = local_rules ++ more_local_rules'
+       in  
+       traceTc (text "Tc10")           `thenNF_Tc_`
+       returnTc (final_env,
+                 new_pcs,
+                 TcResults { tc_env     = local_type_env,
+                             tc_binds   = implicit_binds `AndMonoBinds` all_binds', 
+                             tc_fords   = foi_decls ++ foe_decls',
+                             tc_rules   = all_local_rules
+                           }
+       )
+    )                  `thenTc` \ (_, pcs, tc_result) ->
+    returnTc (pcs, tc_result)
   where
     tycl_decls   = [d | TyClD d <- decls]
     val_binds    = foldr ThenBinds EmptyBinds [binds | ValD binds <- decls]
@@ -301,13 +358,14 @@ tcModule pcs hst get_fixity this_mod decls
 
 
 \begin{code}
-tcImports :: PersistentCompilerState
+tcImports :: RecTcEnv
+         -> PersistentCompilerState
          -> HomeSymbolTable
          -> (Name -> Maybe Fixity)
          -> Module
          -> [RenamedHsDecl]
-         -> TcM (TcEnv, PersistentCompilerState, 
-                 [InstInfo], RenamedHsBinds, [TypecheckedRuleDecl])
+         -> TcM (TcEnv, PersistentCompilerState, [InstInfo], 
+                        RenamedHsBinds, [TypecheckedRuleDecl])
 
 -- tcImports is a slight mis-nomer.  
 -- It deals with everythign that could be an import:
@@ -317,66 +375,68 @@ tcImports :: PersistentCompilerState
 --     rule decls
 -- These can occur in source code too, of course
 
-tcImports pcs hst get_fixity this_mod decls
-  = fixTc (\ ~(unf_env, _, _, _, _) -> 
-         -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
+tcImports unf_env pcs hst get_fixity this_mod decls
+         -- (unf_env :: RecTcEnv) is used for type-checking interface pragmas
          -- which is done lazily [ie failure just drops the pragma
          -- without having any global-failure effect].
          -- 
          -- unf_env is also used to get the pragama info
          -- for imported dfuns and default methods
-               
---     traceTc (text "Tc1")                    `thenNF_Tc_`
-       tcTyAndClassDecls unf_env tycl_decls    `thenTc` \ env ->
-       tcSetEnv env                            $
-       
-               -- Typecheck the instance decls, includes deriving
---     traceTc (text "Tc2")    `thenNF_Tc_`
-       tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs) 
-                    hst unf_env get_fixity this_mod 
-                    decls                      `thenTc` \ (new_pcs_insts, inst_env, local_inst_info, deriv_binds) ->
-       tcSetInstEnv inst_env                   $
-       
-       -- Interface type signatures
-       -- We tie a knot so that the Ids read out of interfaces are in scope
-       --   when we read their pragmas.
-       -- What we rely on is that pragmas are typechecked lazily; if
-       --   any type errors are found (ie there's an inconsistency)
-       --   we silently discard the pragma
---     traceTc (text "Tc3")                    `thenNF_Tc_`
-       tcInterfaceSigs unf_env tycl_decls      `thenTc` \ sig_ids ->
-       tcExtendGlobalValEnv sig_ids            $
-       
-       
-        tcIfaceRules (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)
-
-            -- sometimes we're compiling in the context of a package module
-            -- (on the GHCi command line, for example).  In this case, we
-            -- want to treat everything we pulled in as an imported thing.
-           imported_things
-               | isHomeModule this_mod
-                       = filter (not . isLocalThing this_mod) all_things
-               | otherwise
-                       = all_things
-
-           new_pte :: PackageTypeEnv
-           new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
-           
-           new_pcs :: PersistentCompilerState
-           new_pcs = pcs { pcs_PTE   = new_pte,
-                           pcs_insts = new_pcs_insts,
-                           pcs_rules = new_pcs_rules
-                     }
-       in
-       returnTc (unf_env, new_pcs, local_inst_info, deriv_binds, local_rules)
-    )
+  = checkNoErrsTc $
+       -- 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                               $
+    
+       -- Typecheck the instance decls, includes deriving
+    traceTc (text "Tc2")       `thenNF_Tc_`
+    tcInstDecls1 (pcs_insts pcs) (pcs_PRS pcs) 
+            hst unf_env get_fixity this_mod 
+            decls                      `thenTc` \ (new_pcs_insts, inst_env, local_insts, deriv_binds) ->
+    tcSetInstEnv inst_env                      $
+    
+    -- Interface type signatures
+    -- We tie a knot so that the Ids read out of interfaces are in scope
+    --   when we read their pragmas.
+    -- What we rely on is that pragmas are typechecked lazily; if
+    --   any type errors are found (ie there's an inconsistency)
+    --   we silently discard the pragma
+    traceTc (text "Tc3")                       `thenNF_Tc_`
+    tcInterfaceSigs unf_env tycl_decls         `thenTc` \ sig_ids ->
+    tcExtendGlobalValEnv sig_ids               $
+    
+    
+    tcIfaceRules (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)
+    
+         -- sometimes we're compiling in the context of a package module
+         -- (on the GHCi command line, for example).  In this case, we
+         -- want to treat everything we pulled in as an imported thing.
+        imported_things
+         | isHomeModule this_mod
+         = filter (not . isLocalThing this_mod) all_things
+         | otherwise
+         = all_things
+    
+        new_pte :: PackageTypeEnv
+        new_pte = extendTypeEnvList (pcs_PTE pcs) imported_things
+        
+        new_pcs :: PersistentCompilerState
+        new_pcs = pcs { pcs_PTE   = new_pte,
+                       pcs_insts = new_pcs_insts,
+                       pcs_rules = new_pcs_rules
+                 }
+    in
+    returnTc (unf_env, new_pcs, local_insts, deriv_binds, local_rules)
   where
     tycl_decls  = [d | TyClD d <- decls]
     iface_rules = [d | RuleD d <- decls, isIfaceRuleDecl d]
@@ -444,22 +504,34 @@ noMainErr = hsep [ptext SLIT("Module") <+> quotes (ppr mAIN_Name),
 printTcDump dflags Nothing = return ()
 printTcDump dflags (Just (_, results))
   = do dumpIfSet_dyn dflags Opt_D_dump_types 
-                     "Type signatures" (dump_sigs results)
+                     "Type signatures" (dump_sigs (tc_env results))
        dumpIfSet_dyn dflags Opt_D_dump_tc    
                      "Typechecked" (dump_tc results) 
 
+printIfaceDump dflags Nothing = return ()
+printIfaceDump dflags (Just (_, env, rules))
+  = do dumpIfSet_dyn dflags Opt_D_dump_types 
+                     "Type signatures" (dump_sigs env)
+       dumpIfSet_dyn dflags Opt_D_dump_tc    
+                     "Typechecked" (dump_iface env rules) 
+
 dump_tc results
   = vcat [ppr (tc_binds results),
          pp_rules (tc_rules results),
          ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)]
     ]
 
-dump_sigs results      -- Print type signatures
+dump_iface env rules
+  = vcat [pp_rules rules,
+         ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts env]
+    ]
+
+dump_sigs env  -- Print type signatures
   =    -- Convert to HsType so that we get source-language style printing
        -- And sort by RdrName
     vcat $ map ppr_sig $ sortLt lt_sig $
     [ (toRdrName id, toHsType (idType id))
-    | AnId id <- nameEnvElts (tc_env results),
+    | AnId id <- nameEnvElts env,
       want_sig id
     ]
   where