[project @ 2003-02-12 15:01:31 by simonpj]
[ghc-hetmet.git] / ghc / compiler / typecheck / TcRnDriver.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3 %
4 \section[TcModule]{Typechecking a whole module}
5
6 \begin{code}
7 module TcRnDriver (
8 #ifdef GHCI
9         mkGlobalContext, getModuleContents,
10 #endif
11         tcRnModule, checkOldIface, 
12         importSupportingDecls, tcTopSrcDecls,
13         tcRnIface, tcRnExtCore, tcRnStmt, tcRnExpr, tcRnThing
14     ) where
15
16 #include "HsVersions.h"
17
18 #ifdef GHCI
19 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
20 import                DsMeta   ( templateHaskellNames )
21 #endif
22
23 import CmdLineOpts      ( DynFlag(..), opt_PprStyle_Debug, dopt )
24 import HsSyn            ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..),
25                           Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..),
26                           HsGroup(..), SpliceDecl(..),
27                           mkSimpleMatch, placeHolderType, toHsType, andMonoBinds,
28                           isSrcRule, collectStmtsBinders
29                         )
30 import RdrHsSyn         ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr,
31                           emptyGroup, mkGroup, findSplice, addImpDecls )
32
33 import PrelNames        ( iNTERACTIVE, ioTyConName, printName,
34                           returnIOName, bindIOName, failIOName, thenIOName, runIOName, 
35                           dollarMainName, itName, mAIN_Name
36                         )
37 import MkId             ( unsafeCoerceId )
38 import RdrName          ( RdrName, getRdrName, mkRdrUnqual, 
39                           lookupRdrEnv, elemRdrEnv )
40
41 import RnHsSyn          ( RenamedStmt, RenamedTyClDecl, 
42                           ruleDeclFVs, instDeclFVs, tyClDeclFVs )
43 import TcHsSyn          ( TypecheckedHsExpr, TypecheckedRuleDecl,
44                           zonkTopBinds, zonkTopDecls, mkHsLet,
45                           zonkTopExpr, zonkTopBndrs
46                         )
47
48 import TcExpr           ( tcExpr_id )
49 import TcRnMonad
50 import TcMType          ( newTyVarTy, zonkTcType )
51 import TcType           ( Type, liftedTypeKind, 
52                           tyVarsOfType, tcFunResultTy,
53                           mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
54                         )
55 import TcMatches        ( tcStmtsAndThen )
56 import Inst             ( showLIE )
57 import TcBinds          ( tcTopBinds )
58 import TcClassDcl       ( tcClassDecls2 )
59 import TcDefaults       ( tcDefaults )
60 import TcEnv            ( tcExtendGlobalValEnv, 
61                           tcExtendGlobalEnv,
62                           tcExtendInstEnv, tcExtendRules,
63                           tcLookupTyCon, tcLookupGlobal,
64                           tcLookupId 
65                         )
66 import TcRules          ( tcRules )
67 import TcForeign        ( tcForeignImports, tcForeignExports )
68 import TcIfaceSig       ( tcInterfaceSigs, tcCoreBinds )
69 import TcInstDcls       ( tcInstDecls1, tcIfaceInstDecls, tcInstDecls2 )
70 import TcSimplify       ( tcSimplifyTop, tcSimplifyInfer )
71 import TcTyClsDecls     ( tcTyAndClassDecls )
72
73 import RnNames          ( importsFromLocalDecls, rnImports, exportsFromAvail, 
74                           reportUnusedNames, main_RDR_Unqual )
75 import RnIfaces         ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate )
76 import RnHiFiles        ( readIface, loadOldIface )
77 import RnEnv            ( lookupSrcName, lookupOccRn, plusGlobalRdrEnv,
78                           ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs )
79 import RnExpr           ( rnStmts, rnExpr )
80 import RnSource         ( rnSrcDecls, checkModDeprec, rnStats )
81
82 import CoreUnfold       ( unfoldingTemplate )
83 import CoreSyn          ( IdCoreRule, Bind(..) )
84 import PprCore          ( pprIdRules, pprCoreBindings )
85 import TysWiredIn       ( mkListTy, unitTy )
86 import ErrUtils         ( mkDumpDoc, showPass )
87 import Id               ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported )
88 import IdInfo           ( GlobalIdDetails(..) )
89 import Var              ( Var, setGlobalIdDetails )
90 import Module           ( Module, moduleName, moduleUserString, moduleEnvElts )
91 import Name             ( Name, isExternalName, getSrcLoc, nameOccName )
92 import NameEnv          ( delListFromNameEnv )
93 import NameSet
94 import TyCon            ( tyConGenInfo )
95 import BasicTypes       ( EP(..), RecFlag(..) )
96 import SrcLoc           ( noSrcLoc )
97 import Outputable
98 import HscTypes         ( PersistentCompilerState(..), InteractiveContext(..),
99                           ModIface, ModDetails(..), ModGuts(..),
100                           HscEnv(..), 
101                           ModIface(..), ModDetails(..), IfaceDecls(..),
102                           GhciMode(..), noDependencies,
103                           Deprecations(..), plusDeprecs,
104                           emptyGlobalRdrEnv,
105                           GenAvailInfo(Avail), availsToNameSet, 
106                           ForeignStubs(..),
107                           TypeEnv, TyThing, typeEnvTyCons, 
108                           extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
109                           extendLocalRdrEnv, emptyFixityEnv
110                         )
111 #ifdef GHCI
112 import RdrName          ( rdrEnvElts )
113 import RnHiFiles        ( loadInterface )
114 import RnEnv            ( mkGlobalRdrEnv )
115 import HscTypes         ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(..), 
116                           isLocalGRE )
117 #endif
118
119 import Maybe            ( catMaybes )
120 import Panic            ( showException )
121 import List             ( partition )
122 import Util             ( sortLt )
123 \end{code}
124
125
126
127 %************************************************************************
128 %*                                                                      *
129         Typecheck and rename a module
130 %*                                                                      *
131 %************************************************************************
132
133
134 \begin{code}
135 tcRnModule :: HscEnv -> PersistentCompilerState
136            -> RdrNameHsModule 
137            -> IO (PersistentCompilerState, Maybe TcGblEnv)
138
139 tcRnModule hsc_env pcs
140            (HsModule this_mod _ exports import_decls local_decls mod_deprec loc)
141  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
142
143    initTc hsc_env pcs this_mod $ addSrcLoc loc $
144    do {         -- Deal with imports; sets tcg_rdr_env, tcg_imports
145         (rdr_env, imports) <- rnImports import_decls ;
146         updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
147                                    tcg_imports = tcg_imports gbl `plusImportAvails` imports }) 
148                      $ do {
149         traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
150                 -- Fail if there are any errors so far
151                 -- The error printing (if needed) takes advantage 
152                 -- of the tcg_env we have now set
153         failIfErrsM ;
154
155         traceRn (text "rn1a") ;
156                 -- Rename and type check the declarations
157         (tcg_env, src_fvs) <- tcRnSrcDecls local_decls ;
158         setGblEnv tcg_env               $ do {
159         traceRn (text "rn2") ;
160
161                 -- Check for 'main'
162         (tcg_env, main_fvs) <- checkMain ;
163         setGblEnv tcg_env               $ do {
164
165         traceRn (text "rn3") ;
166                 -- Check whether the entire module is deprecated
167                 -- This happens only once per module
168                 -- Returns the full new deprecations; a module deprecation 
169                 --      over-rides the earlier ones
170         let { mod_deprecs = checkModDeprec mod_deprec } ;
171         updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` mod_deprecs })
172                   $ do {
173
174                 -- Process the export list
175         export_avails <- exportsFromAvail exports ;
176         updGblEnv (\gbl -> gbl { tcg_exports = export_avails })
177                   $  do {
178
179                 -- Get any supporting decls for the exports that have not already
180                 -- been sucked in for the declarations in the body of the module.
181                 -- (This can happen if something is imported only to be re-exported.)
182                 --
183                 -- Importing these supporting declarations is required 
184                 --      *only* to gether usage information
185                 --      (see comments with MkIface.mkImportInfo for why)
186                 -- For OneShot compilation we could just throw away the decls
187                 -- but for Batch or Interactive we must put them in the type
188                 -- envt because they've been removed from the holding pen
189         let { export_fvs = availsToNameSet export_avails } ;
190         tcg_env <- importSupportingDecls export_fvs ;
191         setGblEnv tcg_env $ do {
192
193                 -- Report unused names
194         let { used_fvs = src_fvs `plusFV` main_fvs `plusFV` export_fvs } ;
195         reportUnusedNames tcg_env used_fvs ;
196
197                 -- Dump output and return
198         tcDump tcg_env ;
199         return tcg_env
200     }}}}}}}}
201 \end{code}
202
203
204 %*********************************************************
205 %*                                                       *
206 \subsection{Closing up the interface decls}
207 %*                                                       *
208 %*********************************************************
209
210 Suppose we discover we don't need to recompile.   Then we start from the
211 IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need.
212
213 \begin{code}
214 tcRnIface :: HscEnv
215           -> PersistentCompilerState
216           -> ModIface   -- Get the decls from here
217           -> IO (PersistentCompilerState, Maybe ModDetails)
218                                 -- Nothing <=> errors happened
219 tcRnIface hsc_env pcs
220             (ModIface {mi_module = mod, mi_decls = iface_decls})
221   = initTc hsc_env pcs mod $ do {
222
223         -- Get the supporting decls, and typecheck them all together
224         -- so that any mutually recursive types are done right
225     extra_decls <- slurpImpDecls needed ;
226     env <- typecheckIfaceDecls (group `addImpDecls` extra_decls) ;
227
228     returnM (ModDetails { md_types = tcg_type_env env,
229                           md_insts = tcg_insts env,
230                           md_rules = hsCoreRules (tcg_rules env)
231                   -- All the rules from an interface are of the IfaceRuleOut form
232                  }) }
233   where
234         rule_decls = dcl_rules iface_decls
235         inst_decls = dcl_insts iface_decls
236         tycl_decls = dcl_tycl  iface_decls
237         group = emptyGroup { hs_ruleds = rule_decls,
238                              hs_instds = inst_decls,
239                              hs_tyclds = tycl_decls }
240         needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets`
241                  unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets`
242                  unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets`
243                  ubiquitousNames
244                         -- Data type decls with record selectors,
245                         -- which may appear in the decls, need unpackCString
246                         -- and friends. It's easier to just grab them right now.
247
248 hsCoreRules :: [TypecheckedRuleDecl] -> [IdCoreRule]
249 -- All post-typechecking Iface rules have the form IfaceRuleOut
250 hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules]
251 \end{code}
252
253
254 %************************************************************************
255 %*                                                                      *
256                 The interactive interface 
257 %*                                                                      *
258 %************************************************************************
259
260 \begin{code}
261 tcRnStmt :: HscEnv -> PersistentCompilerState
262          -> InteractiveContext
263          -> RdrNameStmt
264          -> IO (PersistentCompilerState, 
265                 Maybe (InteractiveContext, [Name], TypecheckedHsExpr))
266                 -- The returned [Name] is the same as the input except for
267                 -- ExprStmt, in which case the returned [Name] is [itName]
268                 --
269                 -- The returned TypecheckedHsExpr is of type IO [ () ],
270                 -- a list of the bound values, coerced to ().
271
272 tcRnStmt hsc_env pcs ictxt rdr_stmt
273   = initTc hsc_env pcs iNTERACTIVE $ 
274     setInteractiveContext ictxt $ do {
275
276     -- Rename; use CmdLineMode because tcRnStmt is only used interactively
277     ([rn_stmt], fvs) <- initRnInteractive ictxt 
278                                         (rnStmts DoExpr [rdr_stmt]) ;
279     traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
280     failIfErrsM ;
281     
282     -- Suck in the supporting declarations and typecheck them
283     tcg_env <- importSupportingDecls (fvs `plusFV` implicitStmtFVs fvs) ;
284         -- NB: an earlier version deleted (rdrEnvElts local_env) from
285         --     the fvs.  But (a) that isn't necessary, because previously
286         --     bound things in the local_env will be in the TypeEnv, and 
287         --     the renamer doesn't re-slurp such things, and 
288         -- (b) it's WRONG to delete them. Consider in GHCi:
289         --        Mod> let x = e :: T
290         --        Mod> let y = x + 3
291         --     We need to pass 'x' among the fvs to slurpImpDecls, so that
292         --     the latter can see that T is a gate, and hence import the Num T 
293         --     instance decl.  (See the InTypEnv case in RnIfaces.slurpSourceRefs.)
294     setGblEnv tcg_env $ do {
295     
296     -- The real work is done here
297     ((bound_ids, tc_expr), lie) <- getLIE (tcUserStmt rn_stmt) ;
298     
299     traceTc (text "tcs 1") ;
300     let {       -- Make all the bound ids "global" ids, now that
301                 -- they're notionally top-level bindings.  This is
302                 -- important: otherwise when we come to compile an expression
303                 -- using these ids later, the byte code generator will consider
304                 -- the occurrences to be free rather than global.
305         global_ids     = map globaliseId bound_ids ;
306         globaliseId id = setGlobalIdDetails id VanillaGlobal ;
307     
308                 -- Update the interactive context
309         rn_env   = ic_rn_local_env ictxt ;
310         type_env = ic_type_env ictxt ;
311
312         bound_names = map idName global_ids ;
313         new_rn_env  = extendLocalRdrEnv rn_env bound_names ;
314
315                 -- Remove any shadowed bindings from the type_env;
316                 -- they are inaccessible but might, I suppose, cause 
317                 -- a space leak if we leave them there
318         shadowed = [ n | name <- bound_names,
319                          let rdr_name = mkRdrUnqual (nameOccName name),
320                          Just n <- [lookupRdrEnv rn_env rdr_name] ] ;
321
322         filtered_type_env = delListFromNameEnv type_env shadowed ;
323         new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
324
325         new_ic = ictxt { ic_rn_local_env = new_rn_env, 
326                          ic_type_env     = new_type_env }
327     } ;
328
329     dumpOptTcRn Opt_D_dump_tc 
330         (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
331                text "Typechecked expr" <+> ppr tc_expr]) ;
332
333     returnM (new_ic, bound_names, tc_expr)
334     }}
335 \end{code}              
336
337
338 Here is the grand plan, implemented in tcUserStmt
339
340         What you type                   The IO [HValue] that hscStmt returns
341         -------------                   ------------------------------------
342         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
343                                         bindings: [x,y,...]
344
345         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
346                                         bindings: [x,y,...]
347
348         expr (of IO type)       ==>     expr >>= \ v -> return [coerce HVal v]
349           [NB: result not printed]      bindings: [it]
350           
351         expr (of non-IO type,   ==>     let v = expr in print v >> return [coerce HVal v]
352           result showable)              bindings: [it]
353
354         expr (of non-IO type, 
355           result not showable)  ==>     error
356
357
358 \begin{code}
359 ---------------------------
360 tcUserStmt :: RenamedStmt -> TcM ([Id], TypecheckedHsExpr)
361 tcUserStmt (ExprStmt expr _ loc)
362   = newUnique           `thenM` \ uniq ->
363     let 
364         fresh_it = itName uniq
365         the_bind = FunMonoBind fresh_it False 
366                         [ mkSimpleMatch [] expr placeHolderType loc ] loc
367     in
368     tryTcLIE_ (do {     -- Try this if the other fails
369                 traceTc (text "tcs 1b") ;
370                 tc_stmts [
371                     LetStmt (MonoBind the_bind [] NonRecursive),
372                     ExprStmt (HsApp (HsVar printName) (HsVar fresh_it)) 
373                              placeHolderType loc] })
374           (do {         -- Try this first 
375                 traceTc (text "tcs 1a") ;
376                 tc_stmts [BindStmt (VarPat fresh_it) expr loc] })
377
378 tcUserStmt stmt = tc_stmts [stmt]
379
380 ---------------------------
381 tc_stmts stmts
382  = do { io_ids <- mappM tcLookupId 
383                         [returnIOName, failIOName, bindIOName, thenIOName] ;
384         ioTyCon <- tcLookupTyCon ioTyConName ;
385         res_ty  <- newTyVarTy liftedTypeKind ;
386         let {
387             names      = collectStmtsBinders stmts ;
388             return_id  = head io_ids ;  -- Rather gruesome
389
390             io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty) ;
391
392                 -- mk_return builds the expression
393                 --      returnIO @ [()] [coerce () x, ..,  coerce () z]
394             mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy]) 
395                                   (ExplicitList unitTy (map mk_item ids)) ;
396
397             mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
398                                (HsVar id) } ;
399
400         -- OK, we're ready to typecheck the stmts
401         traceTc (text "tcs 2") ;
402         ((ids, tc_stmts), lie) <- 
403                 getLIE $ tcStmtsAndThen combine DoExpr io_ty stmts $ 
404                 do {
405                     -- Look up the names right in the middle,
406                     -- where they will all be in scope
407                     ids <- mappM tcLookupId names ;
408                     return (ids, [ResultStmt (mk_return ids) noSrcLoc])
409                 } ;
410
411         -- Simplify the context right here, so that we fail
412         -- if there aren't enough instances.  Notably, when we see
413         --              e
414         -- we use recoverTc_ to try     it <- e
415         -- and then                     let it = e
416         -- It's the simplify step that rejects the first.
417         traceTc (text "tcs 3") ;
418         const_binds <- tcSimplifyTop lie ;
419
420         -- Build result expression and zonk it
421         let { expr = mkHsLet const_binds $
422                      HsDo DoExpr tc_stmts io_ids
423                           (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc } ;
424         zonked_expr <- zonkTopExpr expr ;
425         zonked_ids  <- zonkTopBndrs ids ;
426
427         return (zonked_ids, zonked_expr)
428         }
429   where
430     combine stmt (ids, stmts) = (ids, stmt:stmts)
431 \end{code}
432
433
434 tcRnExpr just finds the type of an expression
435
436 \begin{code}
437 tcRnExpr :: HscEnv -> PersistentCompilerState
438          -> InteractiveContext
439          -> RdrNameHsExpr
440          -> IO (PersistentCompilerState, Maybe Type)
441 tcRnExpr hsc_env pcs ictxt rdr_expr
442   = initTc hsc_env pcs iNTERACTIVE $ 
443     setInteractiveContext ictxt $ do {
444
445     (rn_expr, fvs) <- initRnInteractive ictxt (rnExpr rdr_expr) ;
446     failIfErrsM ;
447
448         -- Suck in the supporting declarations and typecheck them
449     tcg_env <- importSupportingDecls (fvs `plusFV` ubiquitousNames) ;
450     setGblEnv tcg_env $ do {
451     
452         -- Now typecheck the expression; 
453         -- it might have a rank-2 type (e.g. :t runST)
454         -- Hence the hole type (c.f. TcExpr.tcExpr_id)
455     ((tc_expr, res_ty), lie)       <- getLIE (tcExpr_id rn_expr) ;
456     ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie)  ;
457     tcSimplifyTop lie_top ;
458
459     let { all_expr_ty = mkForAllTys qtvs                $
460                         mkFunTys (map idType dict_ids)  $
461                         res_ty } ;
462     zonkTcType all_expr_ty
463     }}
464   where
465     smpl_doc = ptext SLIT("main expression")
466 \end{code}
467
468
469 \begin{code}
470 tcRnThing :: HscEnv -> PersistentCompilerState
471           -> InteractiveContext
472           -> RdrName
473           -> IO (PersistentCompilerState, Maybe [TyThing])
474 -- Look up a RdrName and return all the TyThings it might be
475 -- We treat a capitalised RdrName as both a data constructor 
476 -- and as a type or class constructor; hence we return up to two results
477 tcRnThing hsc_env pcs ictxt rdr_name
478   = initTc hsc_env pcs iNTERACTIVE $ 
479     setInteractiveContext ictxt $ do {
480
481         -- If the identifier is a constructor (begins with an
482         -- upper-case letter), then we need to consider both
483         -- constructor and type class identifiers.
484     let { rdr_names = dataTcOccs rdr_name } ;
485
486     (msgs_s, mb_names) <- initRnInteractive ictxt
487                             (mapAndUnzipM (tryTc . lookupOccRn) rdr_names) ;
488     let { names = catMaybes mb_names } ;
489
490     if null names then
491         do { addMessages (head msgs_s) ; failM }
492     else do {
493
494         -- Add deprecation warnings
495     mapM_ addMessages msgs_s ;  
496
497         -- Slurp in the supporting declarations
498     tcg_env <- importSupportingDecls (mkFVs names) ;
499     setGblEnv tcg_env $ do {
500
501         -- And lookup up the entities
502     mapM tcLookupGlobal names
503     }}}
504 \end{code}
505
506
507 \begin{code}
508 setInteractiveContext :: InteractiveContext -> TcRn m a -> TcRn m a
509 setInteractiveContext icxt thing_inside 
510   = traceTc (text "setIC" <+> ppr (ic_type_env icxt))   `thenM_`
511     updGblEnv (\ env -> env { tcg_rdr_env  = ic_rn_gbl_env icxt,
512                               tcg_type_env = ic_type_env   icxt })
513               thing_inside
514
515 initRnInteractive :: InteractiveContext -> RnM a -> TcM a
516 -- Set the local RdrEnv from the interactive context
517 initRnInteractive ictxt rn_thing
518   = initRn CmdLineMode $
519     setLocalRdrEnv (ic_rn_local_env ictxt) $
520     rn_thing
521 \end{code}
522
523 %************************************************************************
524 %*                                                                      *
525         Type-checking external-core modules
526 %*                                                                      *
527 %************************************************************************
528
529 \begin{code}
530 tcRnExtCore :: HscEnv -> PersistentCompilerState 
531             -> RdrNameHsModule 
532             -> IO (PersistentCompilerState, Maybe ModGuts)
533         -- Nothing => some error occurred 
534
535 tcRnExtCore hsc_env pcs 
536             (HsModule this_mod _ _ _ local_decls _ loc)
537         -- Rename the (Core) module.  It's a bit like an interface
538         -- file: all names are original names
539  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
540
541    initTc hsc_env pcs this_mod $ addSrcLoc loc $ do {
542
543         -- Rename the source, only in interface mode.
544         -- rnSrcDecls handles fixity decls etc too, which won't occur
545         -- but that doesn't matter
546    let { local_group = mkGroup local_decls } ;
547    (_, rn_local_decls, fvs) <- initRn (InterfaceMode this_mod) 
548                                       (rnSrcDecls local_group) ;
549    failIfErrsM ;
550
551         -- Get the supporting decls, and typecheck them all together
552         -- so that any mutually recursive types are done right
553    extra_decls <- slurpImpDecls fvs ;
554    tcg_env <- typecheckIfaceDecls (rn_local_decls `addImpDecls` extra_decls) ;
555    setGblEnv tcg_env $ do {
556    
557         -- Now the core bindings
558    core_prs <- tcCoreBinds (hs_coreds rn_local_decls) ;
559    tcExtendGlobalValEnv (map fst core_prs) $ do {
560    
561         -- Wrap up
562    let {
563         bndrs      = map fst core_prs ;
564         my_exports = map (Avail . idName) bndrs ;
565                 -- ToDo: export the data types also?
566
567         final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
568
569         mod_guts = ModGuts {    mg_module   = this_mod,
570                                 mg_usages   = [],       -- ToDo: compute usage
571                                 mg_dir_imps = [],       -- ??
572                                 mg_deps     = noDependencies,   -- ??
573                                 mg_exports  = my_exports,
574                                 mg_types    = final_type_env,
575                                 mg_insts    = tcg_insts tcg_env,
576                                 mg_rules    = hsCoreRules (tcg_rules tcg_env),
577                                 mg_binds    = [Rec core_prs],
578
579                                 -- Stubs
580                                 mg_rdr_env  = emptyGlobalRdrEnv,
581                                 mg_fix_env  = emptyFixityEnv,
582                                 mg_deprecs  = NoDeprecs,
583                                 mg_foreign  = NoStubs
584                     } } ;
585
586    tcCoreDump mod_guts ;
587
588    return mod_guts
589    }}}}
590 \end{code}
591
592
593 %************************************************************************
594 %*                                                                      *
595         Type-checking the top level of a module
596 %*                                                                      *
597 %************************************************************************
598
599 \begin{code}
600 tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars)
601         -- Returns the variables free in the decls
602         -- Reason: solely to report unused imports and bindings
603 tcRnSrcDecls [] = do { tcg_env <- getGblEnv ; return (tcg_env, emptyFVs) }
604 tcRnSrcDecls ds
605  = do { let { (first_group, group_tail) = findSplice ds } ;
606
607         -- Type check the decls up to, but not including, the first splice
608         (tcg_env, src_fvs1) <- tcRnGroup first_group ;
609
610         -- Bale out if errors; for example, error recovery when checking
611         -- the RHS of 'main' can mean that 'main' is not in the envt for 
612         -- the subsequent checkMain test
613         failIfErrsM ;
614
615         -- If there is no splice, we're done
616         case group_tail of {
617            Nothing -> return (tcg_env, src_fvs1) ;
618            Just (SpliceDecl splice_expr splice_loc, rest_ds) -> 
619 #ifndef GHCI
620         failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
621 #else
622         setGblEnv tcg_env $ do {
623
624         -- Rename the splice expression, and get its supporting decls
625         (rn_splice_expr, fvs) <- initRn SourceMode $
626                                  addSrcLoc splice_loc $
627                                  rnExpr splice_expr ;
628         tcg_env <- importSupportingDecls (fvs `plusFV` templateHaskellNames) ;
629         setGblEnv tcg_env $ do {
630
631         -- Execute the splice
632         spliced_decls <- tcSpliceDecls rn_splice_expr ;
633
634         -- Glue them on the front of the remaining decls and loop
635         (tcg_env, src_fvs2) <- tcRnSrcDecls (spliced_decls ++ rest_ds) ;
636
637         return (tcg_env, src_fvs1 `plusFV` src_fvs2)
638     }}
639 #endif /* GHCI */
640     }}
641 \end{code}
642
643
644 %************************************************************************
645 %*                                                                      *
646         Type-checking the top level of a module
647 %*                                                                      *
648 %************************************************************************
649
650 tcRnGroup takes a bunch of top-level source-code declarations, and
651  * renames them
652  * gets supporting declarations from interface files
653  * typechecks them
654  * zonks them
655  * and augments the TcGblEnv with the results
656
657 In Template Haskell it may be called repeatedly for each group of
658 declarations.  It expects there to be an incoming TcGblEnv in the
659 monad; it augments it and returns the new TcGblEnv.
660
661 \begin{code}
662 tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, FreeVars)
663         -- Returns the variables free in the decls
664 tcRnGroup decls
665  = do {         -- Rename the declarations
666         (tcg_env, rn_decls, src_fvs) <- rnTopSrcDecls decls ;
667         setGblEnv tcg_env $ do {
668
669                 -- Typecheck the declarations
670         tcg_env <- tcTopSrcDecls rn_decls ;
671         return (tcg_env, src_fvs)
672   }}
673
674 ------------------------------------------------
675 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, FreeVars)
676 rnTopSrcDecls group
677  = do {         -- Bring top level binders into scope
678         (rdr_env, imports) <- importsFromLocalDecls group ;
679         updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv`
680                                                   tcg_rdr_env gbl,
681                                  tcg_imports = imports `plusImportAvails` 
682                                                   tcg_imports gbl }) 
683                      $ do {
684
685         failIfErrsM ;   -- No point in continuing if (say) we have duplicate declarations
686
687                 -- Rename the source decls
688         (tcg_env, rn_src_decls, src_fvs) <- initRn SourceMode (rnSrcDecls group) ;
689         setGblEnv tcg_env $ do {
690
691         failIfErrsM ;
692
693                 -- Import consquential imports
694         rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ;
695         let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ;
696
697                 -- Dump trace of renaming part
698         rnDump (ppr rn_decls) ;
699         rnStats rn_imp_decls ;
700
701         return (tcg_env, rn_decls, src_fvs)
702   }}}
703
704 ------------------------------------------------
705 tcTopSrcDecls :: HsGroup Name -> TcM TcGblEnv
706 tcTopSrcDecls rn_decls
707  = do {                 -- Do the main work
708         ((tcg_env, lcl_env, binds, rules, fords), lie) <- getLIE (
709                 tc_src_decls rn_decls
710             ) ;
711
712              -- tcSimplifyTop deals with constant or ambiguous InstIds.  
713              -- How could there be ambiguous ones?  They can only arise if a
714              -- top-level decl falls under the monomorphism
715              -- restriction, and no subsequent decl instantiates its
716              -- type.  (Usually, ambiguous type variables are resolved
717              -- during the generalisation step.)
718         traceTc (text "Tc8") ;
719         inst_binds <- setGblEnv tcg_env $
720                       setLclTypeEnv lcl_env $
721                       tcSimplifyTop lie ;
722                 -- The setGblEnv exposes the instances to tcSimplifyTop
723                 -- The setLclTypeEnv exposes the local Ids, so that
724                 -- we get better error messages (monomorphism restriction)
725
726             -- Backsubstitution.  This must be done last.
727             -- Even tcSimplifyTop may do some unification.
728         traceTc (text "Tc9") ;
729         (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
730                                                            rules fords ;
731
732         let { tcg_env' = tcg_env { tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) 
733                                                                        bind_ids,
734                                    tcg_binds = tcg_binds tcg_env `andMonoBinds` binds',
735                                    tcg_rules = tcg_rules tcg_env ++ rules',
736                                    tcg_fords = tcg_fords tcg_env ++ fords' } } ;
737         
738         return tcg_env' 
739     }
740
741 tc_src_decls
742         (HsGroup { hs_tyclds = tycl_decls, 
743                    hs_instds = inst_decls,
744                    hs_fords  = foreign_decls,
745                    hs_defds  = default_decls,
746                    hs_ruleds = rule_decls,
747                    hs_valds  = val_binds })
748  = do {         -- Type-check the type and class decls, and all imported decls
749                 -- The latter come in via tycl_decls
750         traceTc (text "Tc2") ;
751         tcg_env <- tcTyClDecls tycl_decls ;
752         setGblEnv tcg_env       $ do {
753
754                 -- Source-language instances, including derivings,
755                 -- and import the supporting declarations
756         traceTc (text "Tc3") ;
757         (tcg_env, inst_infos, deriv_binds, fvs) <- tcInstDecls1 tycl_decls inst_decls ;
758         setGblEnv tcg_env       $ do {
759         tcg_env <- importSupportingDecls fvs ;
760         setGblEnv tcg_env       $ do {
761
762                 -- Foreign import declarations next.  No zonking necessary
763                 -- here; we can tuck them straight into the global environment.
764         traceTc (text "Tc4") ;
765         (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
766         tcExtendGlobalValEnv fi_ids                  $
767         updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls }) 
768                   $ do {
769
770                 -- Default declarations
771         traceTc (text "Tc4a") ;
772         default_tys <- tcDefaults default_decls ;
773         updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
774         
775                 -- Value declarations next
776                 -- We also typecheck any extra binds that came out 
777                 -- of the "deriving" process
778         traceTc (text "Tc5") ;
779         (tc_val_binds, lcl_env) <- tcTopBinds (val_binds `ThenBinds` deriv_binds) ;
780         setLclTypeEnv lcl_env   $ do {
781
782                 -- Second pass over class and instance declarations, 
783                 -- plus rules and foreign exports, to generate bindings
784         traceTc (text "Tc6") ;
785         (cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ;
786         tcExtendGlobalValEnv dm_ids     $ do {
787         inst_binds <- tcInstDecls2 inst_infos ;
788         showLIE "after instDecls2" ;
789
790                 -- Foreign exports
791                 -- They need to be zonked, so we return them
792         traceTc (text "Tc7") ;
793         (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
794
795                 -- Rules
796                 -- Need to partition them because the source rules
797                 -- must be zonked before adding them to tcg_rules
798                 -- NB: built-in rules come in as IfaceRuleOut's, and
799                 --     get added to tcg_rules right here by tcExtendRules
800         rules <- tcRules rule_decls ;
801         let { (src_rules, iface_rules) = partition isSrcRule rules } ;
802         tcExtendRules iface_rules $ do {
803
804                 -- Wrap up
805         tcg_env <- getGblEnv ;
806         let { all_binds = tc_val_binds   `AndMonoBinds`
807                           inst_binds     `AndMonoBinds`
808                           cls_dm_binds   `AndMonoBinds`
809                           foe_binds } ;
810
811         return (tcg_env, lcl_env, all_binds, src_rules, foe_decls)
812      }}}}}}}}}
813 \end{code}
814
815 \begin{code}
816 tcTyClDecls :: [RenamedTyClDecl]
817             -> TcM TcGblEnv
818
819 -- tcTyClDecls deals with 
820 --      type and class decls (some source, some imported)
821 --      interface signatures (checked lazily)
822 --
823 -- It returns the TcGblEnv for this module, and side-effects the
824 -- persistent compiler state to reflect the things imported from
825 -- other modules
826
827 tcTyClDecls tycl_decls
828   = checkNoErrs $
829         -- tcTyAndClassDecls recovers internally, but if anything gave rise to
830         -- an error we'd better stop now, to avoid a cascade
831         
832     traceTc (text "TyCl1")              `thenM_`
833     tcTyAndClassDecls tycl_decls        `thenM` \ tcg_env ->
834         -- Returns the extended environment
835     setGblEnv tcg_env                   $
836
837     traceTc (text "TyCl2")              `thenM_`
838     tcInterfaceSigs tycl_decls          `thenM` \ tcg_env ->
839         -- Returns the extended environment
840
841     returnM tcg_env
842 \end{code}    
843
844
845
846 %************************************************************************
847 %*                                                                      *
848         Load the old interface file for this module (unless
849         we have it aleady), and check whether it is up to date
850         
851 %*                                                                      *
852 %************************************************************************
853
854 \begin{code}
855 checkOldIface :: HscEnv
856               -> PersistentCompilerState
857               -> Module
858               -> FilePath               -- Where the interface file is
859               -> Bool                   -- Source unchanged
860               -> Maybe ModIface         -- Old interface from compilation manager, if any
861               -> IO (PersistentCompilerState, Maybe (RecompileRequired, Maybe ModIface))
862                                 -- Nothing <=> errors happened
863
864 checkOldIface hsc_env pcs mod iface_path source_unchanged maybe_iface
865   = do { showPass (hsc_dflags hsc_env) 
866                   ("Checking old interface for " ++ moduleUserString mod) ;
867
868          initTc hsc_env pcs mod
869                 (check_old_iface iface_path source_unchanged maybe_iface)
870      }
871
872 check_old_iface iface_path source_unchanged maybe_iface
873  =      -- CHECK WHETHER THE SOURCE HAS CHANGED
874     ifM (not source_unchanged)
875         (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
876                                                 `thenM_`
877
878      -- If the source has changed and we're in interactive mode, avoid reading
879      -- an interface; just return the one we might have been supplied with.
880     getGhciMode                                 `thenM` \ ghci_mode ->
881     if (ghci_mode == Interactive) && not source_unchanged then
882          returnM (outOfDate, maybe_iface)
883     else
884
885     case maybe_iface of
886        Just old_iface -> -- Use the one we already have
887                          checkVersions source_unchanged old_iface       `thenM` \ recomp ->
888                          returnM (recomp, Just old_iface)
889
890        Nothing          -- Try and read it from a file
891           -> getModule                                  `thenM` \ this_mod ->
892              readIface this_mod iface_path False        `thenM` \ read_result ->
893              case read_result of
894                Left err -> -- Old interface file not found, or garbled; give up
895                            traceHiDiffs (
896                                 text "Cannot read old interface file:"
897                                    $$ nest 4 (text (showException err))) `thenM_`
898                            returnM (outOfDate, Nothing)
899
900                Right parsed_iface ->
901                          initRn (InterfaceMode this_mod)
902                                 (loadOldIface parsed_iface)     `thenM` \ m_iface ->
903                          checkVersions source_unchanged m_iface `thenM` \ recomp ->
904                          returnM (recomp, Just m_iface)
905 \end{code}
906
907
908 %************************************************************************
909 %*                                                                      *
910         Type-check and rename supporting declarations
911         This is used to deal with the free vars of a splice,
912         or derived code: slurp in the necessary declarations,
913         typecheck them, and add them to the EPS
914 %*                                                                      *
915 %************************************************************************
916
917 \begin{code}
918 importSupportingDecls :: FreeVars -> TcM TcGblEnv
919 -- Completely deal with the supporting imports needed
920 -- by the specified free-var set
921 importSupportingDecls fvs
922  = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ;
923         decls <- slurpImpDecls fvs ;
924         traceRn (text "...namely:" <+> vcat (map ppr decls)) ;
925         typecheckIfaceDecls (mkGroup decls) }
926
927 typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv
928   -- The decls are all interface-file declarations
929   -- Usually they are all from other modules, but when we are reading
930   -- this module's interface from a file, it's possible that some of
931   -- them are for the module being compiled.
932   -- That is why the tcExtendX functions need to do partitioning.
933   --
934   -- If all the decls are from other modules, the returned TcGblEnv
935   -- will have an empty tc_genv, but its tc_inst_env
936   -- cache may have been augmented.
937 typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls,
938                                hs_instds = inst_decls,
939                                hs_ruleds = rule_decls })
940  = do {         -- Typecheck the type, class, and interface-sig decls
941         tcg_env <- tcTyClDecls tycl_decls ;
942         setGblEnv tcg_env               $ do {
943         
944         -- Typecheck the instance decls, and rules
945         -- Note that imported dictionary functions are already
946         -- in scope from the preceding tcTyClDecls
947         tcIfaceInstDecls inst_decls     `thenM` \ dfuns ->
948         tcExtendInstEnv dfuns           $
949         tcRules rule_decls              `thenM` \ rules ->
950         tcExtendRules rules             $
951     
952         getGblEnv               -- Return the environment
953    }}
954 \end{code}
955
956
957
958 %*********************************************************
959 %*                                                       *
960         mkGlobalContext: make up an interactive context
961
962         Used for initialising the lexical environment
963         of the interactive read-eval-print loop
964 %*                                                       *
965 %*********************************************************
966
967 \begin{code}
968 #ifdef GHCI
969 mkGlobalContext
970         :: HscEnv -> PersistentCompilerState
971         -> [Module]     -- Expose these modules' top-level scope
972         -> [Module]     -- Expose these modules' exports only
973         -> IO (PersistentCompilerState, Maybe GlobalRdrEnv)
974
975 mkGlobalContext hsc_env pcs toplevs exports
976   = initTc hsc_env pcs iNTERACTIVE $ do {
977
978     toplev_envs <- mappM getTopLevScope   toplevs ;
979     export_envs <- mappM getModuleExports exports ;
980     returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv
981                    (toplev_envs ++ export_envs))
982     }
983
984 getTopLevScope :: Module -> TcRn m GlobalRdrEnv
985 getTopLevScope mod
986   = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
987          case mi_globals iface of
988                 Nothing  -> panic "getTopLevScope"
989                 Just env -> returnM env }
990
991 getModuleExports :: Module -> TcRn m GlobalRdrEnv
992 getModuleExports mod 
993   = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
994          returnM (foldl add emptyGlobalRdrEnv (mi_exports iface)) }
995   where
996     prov_fn n = NonLocalDef ImplicitImport
997     add env (mod,avails)
998         = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs)
999
1000 contextDoc = text "context for compiling statements"
1001 \end{code}
1002
1003 \begin{code}
1004 getModuleContents
1005   :: HscEnv
1006   -> PersistentCompilerState    -- IN: persistent compiler state
1007   -> Module                     -- module to inspect
1008   -> Bool                       -- grab just the exports, or the whole toplev
1009   -> IO (PersistentCompilerState, Maybe [TyThing])
1010
1011 getModuleContents hsc_env pcs mod exports_only
1012  = initTc hsc_env pcs iNTERACTIVE $ do {   
1013
1014         -- Load the interface if necessary (a home module will certainly
1015         -- alraedy be loaded, but a package module might not be)
1016         iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1017
1018         let { export_names = availsToNameSet export_avails ;
1019               export_avails = [ avail | (mn, avails) <- mi_exports iface, 
1020                                         avail <- avails ] } ;
1021
1022         all_names <- if exports_only then 
1023                         return export_names
1024                      else case mi_globals iface of {
1025                            Just rdr_env -> 
1026                                 return (get_locals rdr_env) ;
1027
1028                            Nothing -> do { addErr (noRdrEnvErr mod) ;
1029                                            return export_names } } ;
1030                                 -- Invariant; we only have (not exports_only) 
1031                                 -- for a home module so it must already be in the HIT
1032                                 -- So the Nothing case is a bug
1033
1034         env <- importSupportingDecls all_names ;
1035         setGblEnv env (mappM tcLookupGlobal (nameSetToList all_names))
1036     }
1037   where
1038         -- Grab all the things from the global env that are locally def'd
1039     get_locals rdr_env = mkNameSet [ gre_name gre
1040                                    | elts <- rdrEnvElts rdr_env, 
1041                                      gre <- elts, 
1042                                      isLocalGRE gre ]
1043         -- Make a set because a name is often in the envt in
1044         -- both qualified and unqualified forms
1045
1046 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module") 
1047                   <+> quotes (ppr mod)
1048 #endif
1049 \end{code}
1050
1051 %************************************************************************
1052 %*                                                                      *
1053         Checking for 'main'
1054 %*                                                                      *
1055 %************************************************************************
1056
1057 \begin{code}
1058 checkMain 
1059   = do { ghci_mode <- getGhciMode ;
1060          tcg_env   <- getGblEnv ;
1061          check_main ghci_mode tcg_env
1062     }
1063
1064 check_main ghci_mode tcg_env
1065      -- If we are in module Main, check that 'main' is defined.
1066      -- It may be imported from another module, in which case 
1067      -- we have to drag in its.
1068      -- 
1069      -- Also form the definition
1070      --         $main = runIO main
1071      -- so we need to slurp in runIO too.
1072      --
1073      -- ToDo: We have to return the main_name separately, because it's a
1074      -- bona fide 'use', and should be recorded as such, but the others
1075      -- aren't 
1076      -- 
1077      -- Blimey: a whole page of code to do this...
1078
1079  | mod_name /= mAIN_Name
1080  = return (tcg_env, emptyFVs)
1081
1082         -- Check that 'main' is in scope
1083         -- It might be imported from another module!
1084         -- 
1085         -- We use a guard for this (rather than letting lookupSrcName fail)
1086         -- because it's not an error in ghci)
1087  | not (main_RDR_Unqual `elemRdrEnv` rdr_env)
1088  = do { complain_no_main; return (tcg_env, emptyFVs) }
1089
1090  | otherwise
1091  = do { main_name <- lookupSrcName main_RDR_Unqual ;
1092
1093         tcg_env <- importSupportingDecls (unitFV runIOName) ;
1094         setGblEnv tcg_env $ do {
1095         
1096         -- $main :: IO () = runIO main
1097         let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ;
1098
1099         (main_bind, top_lie) <- getLIE (
1100                 addSrcLoc (getSrcLoc main_name) $
1101                 addErrCtxt mainCtxt             $ do {
1102                 (main_expr, ty) <- tcExpr_id rhs ;
1103                 let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) } ;
1104                 return (VarMonoBind dollar_main_id main_expr)
1105             }) ;
1106
1107         inst_binds <- tcSimplifyTop top_lie ;
1108
1109         (ids, binds') <- zonkTopBinds (main_bind `andMonoBinds` inst_binds) ;
1110         
1111         let { tcg_env' = tcg_env { 
1112                 tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids,
1113                 tcg_binds = tcg_binds tcg_env `andMonoBinds` binds' } } ;
1114
1115         return (tcg_env', unitFV main_name)
1116     }}
1117   where
1118     mod_name = moduleName (tcg_mod tcg_env) 
1119     rdr_env  = tcg_rdr_env tcg_env
1120  
1121     complain_no_main | ghci_mode == Interactive = return ()
1122                      | otherwise                = failWithTc noMainMsg
1123         -- In interactive mode, don't worry about the absence of 'main'
1124         -- In other modes, fail altogether, so that we don't go on
1125         -- and complain a second time when processing the export list.
1126
1127     mainCtxt  = ptext SLIT("When checking the type of 'main'")
1128     noMainMsg = ptext SLIT("No 'main' defined in module Main")
1129 \end{code}
1130
1131
1132 %************************************************************************
1133 %*                                                                      *
1134                 Degugging output
1135 %*                                                                      *
1136 %************************************************************************
1137
1138 \begin{code}
1139 rnDump :: SDoc -> TcRn m ()
1140 -- Dump, with a banner, if -ddump-rn
1141 rnDump doc = dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc)
1142
1143 tcDump :: TcGblEnv -> TcRn m ()
1144 tcDump env
1145  = do { dflags <- getDOpts ;
1146
1147         -- Dump short output if -ddump-types or -ddump-tc
1148         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1149             (dumpTcRn short_dump) ;
1150
1151         -- Dump bindings if -ddump-tc
1152         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1153    }
1154   where
1155     short_dump = pprTcGblEnv env
1156     full_dump  = ppr (tcg_binds env)
1157         -- NB: foreign x-d's have undefined's in their types; 
1158         --     hence can't show the tc_fords
1159
1160 tcCoreDump mod_guts
1161  = do { dflags <- getDOpts ;
1162         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1163             (dumpTcRn (pprModGuts mod_guts)) ;
1164
1165         -- Dump bindings if -ddump-tc
1166         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1167   where
1168     full_dump = pprCoreBindings (mg_binds mod_guts)
1169
1170 -- It's unpleasant having both pprModGuts and pprModDetails here
1171 pprTcGblEnv :: TcGblEnv -> SDoc
1172 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, 
1173                         tcg_insts    = dfun_ids, 
1174                         tcg_rules    = rules,
1175                         tcg_imports  = imports })
1176   = vcat [ ppr_types dfun_ids type_env
1177          , ppr_insts dfun_ids
1178          , vcat (map ppr rules)
1179          , ppr_gen_tycons (typeEnvTyCons type_env)
1180          , ppr (moduleEnvElts (imp_dep_mods imports))
1181          , ppr (imp_dep_pkgs imports)]
1182
1183 pprModGuts :: ModGuts -> SDoc
1184 pprModGuts (ModGuts { mg_types = type_env,
1185                       mg_rules = rules })
1186   = vcat [ ppr_types [] type_env,
1187            ppr_rules rules ]
1188
1189
1190 ppr_types :: [Var] -> TypeEnv -> SDoc
1191 ppr_types dfun_ids type_env
1192   = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1193   where
1194     ids = [id | id <- typeEnvIds type_env, want_sig id]
1195     want_sig id | opt_PprStyle_Debug = True
1196                 | otherwise          = isLocalId id && 
1197                                        isExternalName (idName id) && 
1198                                        not (id `elem` dfun_ids)
1199         -- isLocalId ignores data constructors, records selectors etc.
1200         -- The isExternalName ignores local dictionary and method bindings
1201         -- that the type checker has invented.  Top-level user-defined things 
1202         -- have External names.
1203
1204 ppr_insts :: [Var] -> SDoc
1205 ppr_insts []       = empty
1206 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1207
1208 ppr_sigs :: [Var] -> SDoc
1209 ppr_sigs ids
1210         -- Print type signatures
1211         -- Convert to HsType so that we get source-language style printing
1212         -- And sort by RdrName
1213   = vcat $ map ppr_sig $ sortLt lt_sig $
1214     [ (getRdrName id, toHsType (idType id))
1215     | id <- ids ]
1216   where
1217     lt_sig (n1,_) (n2,_) = n1 < n2
1218     ppr_sig (n,t)        = ppr n <+> dcolon <+> ppr t
1219
1220
1221 ppr_rules :: [IdCoreRule] -> SDoc
1222 ppr_rules [] = empty
1223 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1224                       nest 4 (pprIdRules rs),
1225                       ptext SLIT("#-}")]
1226
1227 ppr_gen_tycons []  = empty
1228 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
1229                            vcat (map ppr_gen_tycon tcs),
1230                            ptext SLIT("#-}")
1231                      ]
1232
1233 -- x&y are now Id's, not CoreExpr's 
1234 ppr_gen_tycon tycon 
1235   | Just ep <- tyConGenInfo tycon
1236   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
1237
1238   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
1239
1240 ppr_ep (EP from to)
1241   = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
1242            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
1243            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
1244     ]
1245   where
1246     (_,from_tau) = tcSplitForAllTys (idType from)
1247 \end{code}