a93133dad24e1c0418b5ba9d5ac1f91999d65931
[ghc.git] / compiler / typecheck / TcRnDriver.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5 \section[TcModule]{Typechecking a whole module}
6
7 \begin{code}
8 module TcRnDriver (
9 #ifdef GHCI
10         tcRnStmt, tcRnExpr, tcRnType,
11         tcRnLookupRdrName,
12         tcRnLookupName,
13         tcRnGetInfo,
14         getModuleExports, 
15         tcRnRecoverDataCon,
16 #endif
17         tcRnModule, 
18         tcTopSrcDecls,
19         tcRnExtCore
20     ) where
21
22 #include "HsVersions.h"
23
24 import IO
25 #ifdef GHCI
26 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
27 #endif
28
29 import DynFlags
30 import StaticFlags
31 import HsSyn
32 import RdrHsSyn
33
34 import PrelNames
35 import RdrName
36 import TcHsSyn
37 import TcExpr
38 import TcRnMonad
39 import TcType
40 import Inst
41 import FamInst
42 import InstEnv
43 import FamInstEnv
44 import TcBinds
45 import TcDefaults
46 import TcEnv
47 import TcRules
48 import TcForeign
49 import TcInstDcls
50 import TcIface
51 import MkIface
52 import IfaceSyn
53 import TcSimplify
54 import TcTyClsDecls
55 import LoadIface
56 import RnNames
57 import RnEnv
58 import RnSource
59 import RnHsDoc
60 import PprCore
61 import CoreSyn
62 import ErrUtils
63 import Id
64 import Var
65 import Module
66 import UniqFM
67 import Name
68 import NameSet
69 import TyCon
70 import SrcLoc
71 import HscTypes
72 import Outputable
73
74 #ifdef GHCI
75 import Linker
76 import DataCon
77 import TcHsType
78 import TcMType
79 import TcMatches
80 import TcGadt
81 import RnTypes
82 import RnExpr
83 import IfaceEnv
84 import MkId
85 import TysWiredIn
86 import IdInfo
87 import {- Kind parts of -} Type
88 import BasicTypes
89 import Data.Maybe
90 #endif
91
92 import FastString
93 import Util
94 import Bag
95
96 import Control.Monad    ( unless )
97 import Data.Maybe       ( isJust )
98 \end{code}
99
100
101
102 %************************************************************************
103 %*                                                                      *
104         Typecheck and rename a module
105 %*                                                                      *
106 %************************************************************************
107
108
109 \begin{code}
110 tcRnModule :: HscEnv 
111            -> HscSource
112            -> Bool              -- True <=> save renamed syntax
113            -> Located (HsModule RdrName)
114            -> IO (Messages, Maybe TcGblEnv)
115
116 tcRnModule hsc_env hsc_src save_rn_syntax
117          (L loc (HsModule maybe_mod export_ies 
118                           import_decls local_decls mod_deprec _ module_info maybe_doc))
119  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
120
121    let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
122          this_mod = case maybe_mod of
123                         Nothing  -> mAIN        -- 'module M where' is omitted
124                         Just (L _ mod) -> mkModule this_pkg mod } ;
125                                                 -- The normal case
126                 
127    initTc hsc_env hsc_src this_mod $ 
128    setSrcSpan loc $
129    do {
130                 -- Deal with imports;
131         (rn_imports, rdr_env, imports) <- rnImports import_decls ;
132
133         let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
134             ; dep_mods = imp_dep_mods imports
135
136                 -- We want instance declarations from all home-package
137                 -- modules below this one, including boot modules, except
138                 -- ourselves.  The 'except ourselves' is so that we don't
139                 -- get the instances from this module's hs-boot file
140             ; want_instances :: ModuleName -> Bool
141             ; want_instances mod = mod `elemUFM` dep_mods
142                                    && mod /= moduleName this_mod
143             ; home_insts = hptInstances hsc_env want_instances
144             } ;
145
146                 -- Record boot-file info in the EPS, so that it's 
147                 -- visible to loadHiBootInterface in tcRnSrcDecls,
148                 -- and any other incrementally-performed imports
149         updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
150
151                 -- Update the gbl env
152         updGblEnv ( \ gbl -> 
153                 gbl { tcg_rdr_env  = plusOccEnv (tcg_rdr_env gbl) rdr_env,
154                       tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
155                       tcg_imports  = tcg_imports gbl `plusImportAvails` imports,
156                       tcg_rn_imports = if save_rn_syntax then
157                                          Just rn_imports
158                                        else
159                                          Nothing,
160                       tcg_rn_decls = if save_rn_syntax then
161                                         Just emptyRnGroup
162                                      else
163                                         Nothing })
164                 $ do {
165
166         traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
167                 -- Fail if there are any errors so far
168                 -- The error printing (if needed) takes advantage 
169                 -- of the tcg_env we have now set
170         traceIf (text "rdr_env: " <+> ppr rdr_env) ;
171         failIfErrsM ;
172
173                 -- Load any orphan-module and family instance-module
174                 -- interfaces, so that their rules and instance decls will be
175                 -- found.
176         loadOrphanModules (imp_orphs  imports) False ;
177         loadOrphanModules (imp_finsts imports) True  ;
178
179         traceRn (text "rn1: checking family instance consistency") ;
180         let { directlyImpMods =   map (\(mod, _, _) -> mod) 
181                                 . moduleEnvElts 
182                                 . imp_mods 
183                                 $ imports } ;
184         checkFamInstConsistency (imp_finsts imports) directlyImpMods ;
185
186         traceRn (text "rn1a") ;
187                 -- Rename and type check the declarations
188         tcg_env <- if isHsBoot hsc_src then
189                         tcRnHsBootDecls local_decls
190                    else 
191                         tcRnSrcDecls local_decls ;
192         setGblEnv tcg_env               $ do {
193
194         failIfErrsM ;   -- reportDeprecations crashes sometimes 
195                         -- as a result of typechecker repairs (e.g. unboundNames)
196         traceRn (text "rn3") ;
197
198                 -- Report the use of any deprecated things
199                 -- We do this before processsing the export list so
200                 -- that we don't bleat about re-exporting a deprecated
201                 -- thing (especially via 'module Foo' export item)
202                 -- Only uses in the body of the module are complained about
203         reportDeprecations (hsc_dflags hsc_env) tcg_env ;
204
205                 -- Process the export list
206         (rn_exports, exports) <- rnExports (isJust maybe_mod) export_ies ;
207                  
208         traceRn (text "rn4") ;
209
210                 -- Rename the Haddock documentation header 
211         rn_module_doc <- rnMbHsDoc maybe_doc ;
212
213                 -- Rename the Haddock module info 
214         rn_description <- rnMbHsDoc (hmi_description module_info) ;
215         let { rn_module_info = module_info { hmi_description = rn_description } } ;
216
217                 -- Check whether the entire module is deprecated
218                 -- This happens only once per module
219         let { mod_deprecs = checkModDeprec mod_deprec } ;
220
221                 -- Add exports and deprecations to envt
222         let { final_env  = tcg_env { tcg_exports = exports,
223                                      tcg_rn_exports = if save_rn_syntax then
224                                                          rn_exports
225                                                       else Nothing,
226                                      tcg_dus = tcg_dus tcg_env `plusDU` usesOnly (availsToNameSet exports),
227                                      tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs` 
228                                                    mod_deprecs,
229                                      tcg_doc = rn_module_doc, 
230                                      tcg_hmi = rn_module_info
231                                   }
232                 -- A module deprecation over-rides the earlier ones
233              } ;
234
235                 -- Report unused names
236         reportUnusedNames export_ies final_env ;
237
238                 -- Dump output and return
239         tcDump final_env ;
240         return final_env
241     }}}}
242 \end{code}
243
244
245 %************************************************************************
246 %*                                                                      *
247         Type-checking external-core modules
248 %*                                                                      *
249 %************************************************************************
250
251 \begin{code}
252 tcRnExtCore :: HscEnv 
253             -> HsExtCore RdrName
254             -> IO (Messages, Maybe ModGuts)
255         -- Nothing => some error occurred 
256
257 tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
258         -- The decls are IfaceDecls; all names are original names
259  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
260
261    initTc hsc_env ExtCoreFile this_mod $ do {
262
263    let { ldecls  = map noLoc decls } ;
264
265         -- Deal with the type declarations; first bring their stuff
266         -- into scope, then rname them, then type check them
267    tcg_env  <- importsFromLocalDecls (mkFakeGroup ldecls) ;
268
269    setGblEnv tcg_env $ do {
270
271    rn_decls <- rnTyClDecls ldecls ;
272    failIfErrsM ;
273
274         -- Dump trace of renaming part
275    rnDump (ppr rn_decls) ;
276
277         -- Typecheck them all together so that
278         -- any mutually recursive types are done right
279    tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails rn_decls) ;
280         -- Make the new type env available to stuff slurped from interface files
281
282    setGblEnv tcg_env $ do {
283    
284         -- Now the core bindings
285    core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
286
287         -- Wrap up
288    let {
289         bndrs      = bindersOfBinds core_binds ;
290         my_exports = map (Avail . idName) bndrs ;
291                 -- ToDo: export the data types also?
292
293         final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
294
295         mod_guts = ModGuts {    mg_module    = this_mod,
296                                 mg_boot      = False,
297                                 mg_usages    = [],              -- ToDo: compute usage
298                                 mg_dir_imps  = [],              -- ??
299                                 mg_deps      = noDependencies,  -- ??
300                                 mg_exports   = my_exports,
301                                 mg_types     = final_type_env,
302                                 mg_insts     = tcg_insts tcg_env,
303                                 mg_fam_insts = tcg_fam_insts tcg_env,
304                                 mg_rules     = [],
305                                 mg_binds     = core_binds,
306
307                                 -- Stubs
308                                 mg_rdr_env   = emptyGlobalRdrEnv,
309                                 mg_fix_env   = emptyFixityEnv,
310                                 mg_deprecs   = NoDeprecs,
311                                 mg_foreign   = NoStubs,
312                                 mg_hpc_info  = noHpcInfo
313                     } } ;
314
315    tcCoreDump mod_guts ;
316
317    return mod_guts
318    }}}}
319
320 mkFakeGroup decls -- Rather clumsy; lots of unused fields
321   = emptyRdrGroup { hs_tyclds = decls }
322 \end{code}
323
324
325 %************************************************************************
326 %*                                                                      *
327         Type-checking the top level of a module
328 %*                                                                      *
329 %************************************************************************
330
331 \begin{code}
332 tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
333         -- Returns the variables free in the decls
334         -- Reason: solely to report unused imports and bindings
335 tcRnSrcDecls decls
336  = do {         -- Load the hi-boot interface for this module, if any
337                 -- We do this now so that the boot_names can be passed
338                 -- to tcTyAndClassDecls, because the boot_names are 
339                 -- automatically considered to be loop breakers
340         mod <- getModule ;
341         boot_iface <- tcHiBootIface mod ;
342
343                 -- Do all the declarations
344         (tc_envs, lie) <- getLIE $ tc_rn_src_decls boot_iface decls ;
345
346              --         Finish simplifying class constraints
347              -- 
348              -- tcSimplifyTop deals with constant or ambiguous InstIds.  
349              -- How could there be ambiguous ones?  They can only arise if a
350              -- top-level decl falls under the monomorphism restriction
351              -- and no subsequent decl instantiates its type.
352              --
353              -- We do this after checkMain, so that we use the type info 
354              -- thaat checkMain adds
355              -- 
356              -- We do it with both global and local env in scope:
357              --  * the global env exposes the instances to tcSimplifyTop
358              --  * the local env exposes the local Ids to tcSimplifyTop, 
359              --    so that we get better error messages (monomorphism restriction)
360         traceTc (text "Tc8") ;
361         inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
362
363             -- Backsubstitution.  This must be done last.
364             -- Even tcSimplifyTop may do some unification.
365         traceTc (text "Tc9") ;
366         let { (tcg_env, _) = tc_envs
367             ; TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, 
368                          tcg_rules = rules, tcg_fords = fords } = tcg_env
369             ; all_binds = binds `unionBags` inst_binds } ;
370
371         (bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ;
372
373         let { final_type_env = extendTypeEnvWithIds type_env bind_ids
374             ; tcg_env' = tcg_env { tcg_type_env = final_type_env,
375                                    tcg_binds = binds',
376                                    tcg_rules = rules', 
377                                    tcg_fords = fords' } } ;
378
379         -- Make the new type env available to stuff slurped from interface files
380         writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
381
382         -- Compare the hi-boot iface (if any) with the real thing
383         dfun_binds <- checkHiBootIface tcg_env' boot_iface ;
384
385         return (tcg_env' { tcg_binds = tcg_binds tcg_env' `unionBags` dfun_binds }) 
386    }
387
388 tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
389 -- Loops around dealing with each top level inter-splice group 
390 -- in turn, until it's dealt with the entire module
391 tc_rn_src_decls boot_details ds
392  = do { let { (first_group, group_tail) = findSplice ds } ;
393                 -- If ds is [] we get ([], Nothing)
394
395         -- Deal with decls up to, but not including, the first splice
396         (tcg_env, rn_decls) <- checkNoErrs $ rnTopSrcDecls first_group ;
397                 -- checkNoErrs: don't typecheck if renaming failed
398         tc_envs <- setGblEnv tcg_env $ 
399                    tcTopSrcDecls boot_details rn_decls ;
400
401         -- If there is no splice, we're nearly done
402         setEnvs tc_envs $ 
403         case group_tail of {
404            Nothing -> do { tcg_env <- checkMain ;       -- Check for `main'
405                            return (tcg_env, snd tc_envs) 
406                       } ;
407
408         -- If there's a splice, we must carry on
409            Just (SpliceDecl splice_expr, rest_ds) -> do {
410 #ifndef GHCI
411         failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
412 #else
413
414         -- Rename the splice expression, and get its supporting decls
415         (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;
416                 -- checkNoErrs: don't typecheck if renaming failed
417         rnDump (ppr rn_splice_expr) ;
418
419         -- Execute the splice
420         spliced_decls <- tcSpliceDecls rn_splice_expr ;
421
422         -- Glue them on the front of the remaining decls and loop
423         setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
424         tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
425 #endif /* GHCI */
426     } } }
427 \end{code}
428
429 %************************************************************************
430 %*                                                                      *
431         Compiling hs-boot source files, and
432         comparing the hi-boot interface with the real thing
433 %*                                                                      *
434 %************************************************************************
435
436 \begin{code}
437 tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
438 tcRnHsBootDecls decls
439    = do { let { (first_group, group_tail) = findSplice decls }
440
441         ; case group_tail of
442              Just stuff -> spliceInHsBootErr stuff
443              Nothing    -> return ()
444
445                 -- Rename the declarations
446         ; (tcg_env, rn_group) <- rnTopSrcDecls first_group
447         ; setGblEnv tcg_env $ do {
448
449         -- Todo: check no foreign decls, no rules, no default decls
450
451                 -- Typecheck type/class decls
452         ; traceTc (text "Tc2")
453         ; let tycl_decls = hs_tyclds rn_group
454         ; tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails tycl_decls)
455         ; setGblEnv tcg_env     $ do {
456
457                 -- Typecheck instance decls
458         ; traceTc (text "Tc3")
459         ; (tcg_env, inst_infos, _binds) 
460             <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group)
461         ; setGblEnv tcg_env     $ do {
462
463                 -- Typecheck value declarations
464         ; traceTc (text "Tc5") 
465         ; val_ids <- tcHsBootSigs (hs_valds rn_group)
466
467                 -- Wrap up
468                 -- No simplification or zonking to do
469         ; traceTc (text "Tc7a")
470         ; gbl_env <- getGblEnv 
471         
472                 -- Make the final type-env
473                 -- Include the dfun_ids so that their type sigs
474                 -- are written into the interface file
475         ; let { type_env0 = tcg_type_env gbl_env
476               ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
477               ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids 
478               ; dfun_ids = map iDFunId inst_infos }
479         ; return (gbl_env { tcg_type_env = type_env2 }) 
480    }}}}
481
482 spliceInHsBootErr (SpliceDecl (L loc _), _)
483   = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files"))
484 \end{code}
485
486 Once we've typechecked the body of the module, we want to compare what
487 we've found (gathered in a TypeEnv) with the hi-boot details (if any).
488
489 \begin{code}
490 checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id)
491 -- Compare the hi-boot file for this module (if there is one)
492 -- with the type environment we've just come up with
493 -- In the common case where there is no hi-boot file, the list
494 -- of boot_names is empty.
495 --
496 -- The bindings we return give bindings for the dfuns defined in the
497 -- hs-boot file, such as        $fbEqT = $fEqT
498
499 checkHiBootIface
500         (TcGblEnv { tcg_insts = local_insts, tcg_fam_insts = local_fam_insts,
501                     tcg_type_env = local_type_env })
502         (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
503                       md_types = boot_type_env })
504   = do  { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts)) ;
505         ; mapM_ check_one (typeEnvElts boot_type_env)
506         ; dfun_binds <- mapM check_inst boot_insts
507         ; unless (null boot_fam_insts) $
508             panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
509                    "instances in boot files yet...")
510             -- FIXME: Why?  The actual comparison is not hard, but what would
511             --        be the equivalent to the dfun bindings returned for class
512             --        instances?  We can't easily equate tycons...
513         ; return (unionManyBags dfun_binds) }
514   where
515     check_one boot_thing
516       | isImplicitTyThing boot_thing = return ()
517       | name `elem` dfun_names       = return ()        
518       | isWiredInName name           = return ()        -- No checking for wired-in names.  In particular,
519                                                         -- 'error' is handled by a rather gross hack
520                                                         -- (see comments in GHC.Err.hs-boot)
521       | Just real_thing <- lookupTypeEnv local_type_env name
522       = do { let boot_decl = tyThingToIfaceDecl boot_thing
523                  real_decl = tyThingToIfaceDecl real_thing
524            ; checkTc (checkBootDecl boot_decl real_decl)
525                      (bootMisMatch boot_thing boot_decl real_decl) }
526                 -- The easiest way to check compatibility is to convert to
527                 -- iface syntax, where we already have good comparison functions
528       | otherwise
529       = addErrTc (missingBootThing boot_thing)
530       where
531         name = getName boot_thing
532
533     dfun_names = map getName boot_insts
534
535     check_inst boot_inst
536         = case [dfun | inst <- local_insts, 
537                        let dfun = instanceDFunId inst,
538                        idType dfun `tcEqType` boot_inst_ty ] of
539             [] -> do { addErrTc (instMisMatch boot_inst); return emptyBag }
540             (dfun:_) -> return (unitBag $ noLoc $ VarBind local_boot_dfun (nlHsVar dfun))
541         where
542           boot_dfun = instanceDFunId boot_inst
543           boot_inst_ty = idType boot_dfun
544           local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
545
546 ----------------
547 missingBootThing thing
548   = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
549 bootMisMatch thing boot_decl real_decl
550   = vcat [ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file"),
551           ptext SLIT("Decl") <+> ppr real_decl,
552           ptext SLIT("Boot file:") <+> ppr boot_decl]
553 instMisMatch inst
554   = hang (ppr inst)
555        2 (ptext SLIT("is defined in the hs-boot file, but not in the module"))
556 \end{code}
557
558
559 %************************************************************************
560 %*                                                                      *
561         Type-checking the top level of a module
562 %*                                                                      *
563 %************************************************************************
564
565 tcRnGroup takes a bunch of top-level source-code declarations, and
566  * renames them
567  * gets supporting declarations from interface files
568  * typechecks them
569  * zonks them
570  * and augments the TcGblEnv with the results
571
572 In Template Haskell it may be called repeatedly for each group of
573 declarations.  It expects there to be an incoming TcGblEnv in the
574 monad; it augments it and returns the new TcGblEnv.
575
576 \begin{code}
577 ------------------------------------------------
578 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
579 rnTopSrcDecls group
580  = do {         -- Bring top level binders into scope
581         tcg_env <- importsFromLocalDecls group ;
582         setGblEnv tcg_env $ do {
583
584         failIfErrsM ;   -- No point in continuing if (say) we have duplicate declarations
585
586                 -- Rename the source decls
587         (tcg_env, rn_decls) <- rnSrcDecls group ;
588         failIfErrsM ;
589
590                 -- save the renamed syntax, if we want it
591         let { tcg_env'
592                 | Just grp <- tcg_rn_decls tcg_env
593                   = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
594                 | otherwise
595                    = tcg_env };
596
597                 -- Dump trace of renaming part
598         rnDump (ppr rn_decls) ;
599
600         return (tcg_env', rn_decls)
601    }}
602
603 ------------------------------------------------
604 tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
605 tcTopSrcDecls boot_details
606         (HsGroup { hs_tyclds = tycl_decls, 
607                    hs_instds = inst_decls,
608                    hs_derivds = deriv_decls,
609                    hs_fords  = foreign_decls,
610                    hs_defds  = default_decls,
611                    hs_ruleds = rule_decls,
612                    hs_valds  = val_binds })
613  = do {         -- Type-check the type and class decls, and all imported decls
614                 -- The latter come in via tycl_decls
615         traceTc (text "Tc2") ;
616
617         tcg_env <- checkNoErrs (tcTyAndClassDecls boot_details tycl_decls) ;
618         -- tcTyAndClassDecls recovers internally, but if anything gave rise to
619         -- an error we'd better stop now, to avoid a cascade
620         
621         -- Make these type and class decls available to stuff slurped from interface files
622         writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
623
624
625         setGblEnv tcg_env       $ do {
626                 -- Source-language instances, including derivings,
627                 -- and import the supporting declarations
628         traceTc (text "Tc3") ;
629         (tcg_env, inst_infos, deriv_binds) 
630             <- tcInstDecls1 tycl_decls inst_decls deriv_decls;
631         setGblEnv tcg_env       $ do {
632
633                 -- Foreign import declarations next.  No zonking necessary
634                 -- here; we can tuck them straight into the global environment.
635         traceTc (text "Tc4") ;
636         (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
637         tcExtendGlobalValEnv fi_ids     $ do {
638
639                 -- Default declarations
640         traceTc (text "Tc4a") ;
641         default_tys <- tcDefaults default_decls ;
642         updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
643         
644                 -- Value declarations next
645                 -- We also typecheck any extra binds that came out 
646                 -- of the "deriving" process (deriv_binds)
647         traceTc (text "Tc5") ;
648         (tc_val_binds, tcl_env) <- tcTopBinds (val_binds `plusHsValBinds` deriv_binds) ;
649         setLclTypeEnv tcl_env   $ do {
650
651                 -- Second pass over class and instance declarations, 
652         traceTc (text "Tc6") ;
653         (inst_binds, tcl_env) <- tcInstDecls2 tycl_decls inst_infos ;
654         showLIE (text "after instDecls2") ;
655
656                 -- Foreign exports
657                 -- They need to be zonked, so we return them
658         traceTc (text "Tc7") ;
659         (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
660
661                 -- Rules
662         rules <- tcRules rule_decls ;
663
664                 -- Wrap up
665         traceTc (text "Tc7a") ;
666         tcg_env <- getGblEnv ;
667         let { all_binds = tc_val_binds   `unionBags`
668                           inst_binds     `unionBags`
669                           foe_binds  ;
670
671                 -- Extend the GblEnv with the (as yet un-zonked) 
672                 -- bindings, rules, foreign decls
673               tcg_env' = tcg_env {  tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
674                                     tcg_rules = tcg_rules tcg_env ++ rules,
675                                     tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
676         return (tcg_env', tcl_env)
677     }}}}}}
678 \end{code}
679
680
681 %************************************************************************
682 %*                                                                      *
683         Checking for 'main'
684 %*                                                                      *
685 %************************************************************************
686
687 \begin{code}
688 checkMain :: TcM TcGblEnv
689 -- If we are in module Main, check that 'main' is defined.
690 checkMain 
691   = do { ghc_mode <- getGhcMode ;
692          tcg_env   <- getGblEnv ;
693          dflags    <- getDOpts ;
694          let { main_mod = mainModIs dflags ;
695                main_fn  = case mainFunIs dflags of {
696                                 Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ;
697                                 Nothing -> main_RDR_Unqual } } ;
698         
699          check_main ghc_mode tcg_env main_mod main_fn
700     }
701
702
703 check_main ghc_mode tcg_env main_mod main_fn
704  | mod /= main_mod
705  = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
706    return tcg_env
707
708  | otherwise
709  = addErrCtxt mainCtxt                  $
710    do   { mb_main <- lookupSrcOcc_maybe main_fn
711                 -- Check that 'main' is in scope
712                 -- It might be imported from another module!
713         ; case mb_main of {
714              Nothing -> do { traceTc (text "checkMain fail" <+> ppr main_mod <+> ppr main_fn)
715                            ; complain_no_main   
716                            ; return tcg_env } ;
717              Just main_name -> do
718         { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn)
719         ; let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) }
720                         -- :Main.main :: IO () = runMainIO main 
721
722         ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
723                              tcInferRho rhs
724
725         -- The function that the RTS invokes is always :Main.main,
726         -- which we call root_main_id.  
727         -- (Because GHC allows the user to have a module not called 
728         -- Main as the main module, we can't rely on the main function
729         -- being called "Main.main".  That's why root_main_id has a fixed
730         -- module ":Main".)
731         -- We also make root_main_id an implicit Id, by making main_name
732         -- its parent (hence (Just main_name)).  That has the effect
733         -- of preventing its type and unfolding from getting out into
734         -- the interface file. Otherwise we can end up with two defns
735         -- for 'main' in the interface file!
736
737         ; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN 
738                                    (mkVarOccFS FSLIT("main")) 
739                                    (getSrcLoc main_name)
740               ; root_main_id = Id.mkExportedLocalId root_main_name ty
741               ; main_bind    = noLoc (VarBind root_main_id main_expr) }
742
743         ; return (tcg_env { tcg_binds = tcg_binds tcg_env 
744                                         `snocBag` main_bind,
745                             tcg_dus   = tcg_dus tcg_env
746                                         `plusDU` usesOnly (unitFV main_name)
747                         -- Record the use of 'main', so that we don't 
748                         -- complain about it being defined but not used
749                  }) 
750     }}}
751   where
752     mod = tcg_mod tcg_env
753  
754     complain_no_main | ghc_mode == Interactive = return ()
755                      | otherwise                = failWithTc noMainMsg
756         -- In interactive mode, don't worry about the absence of 'main'
757         -- In other modes, fail altogether, so that we don't go on
758         -- and complain a second time when processing the export list.
759
760     mainCtxt  = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
761     noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn) 
762                 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
763 \end{code}
764
765 %*********************************************************
766 %*                                                       *
767                 GHCi stuff
768 %*                                                       *
769 %*********************************************************
770
771 \begin{code}
772 #ifdef GHCI
773 setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
774 setInteractiveContext hsc_env icxt thing_inside 
775   = let 
776         -- Initialise the tcg_inst_env with instances 
777         -- from all home modules.  This mimics the more selective
778         -- call to hptInstances in tcRnModule
779         dfuns = hptInstances hsc_env (\mod -> True)
780     in
781     updGblEnv (\env -> env { 
782         tcg_rdr_env  = ic_rn_gbl_env icxt,
783         tcg_type_env = ic_type_env   icxt,
784         tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $
785
786     updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt })  $
787
788     do  { traceTc (text "setIC" <+> ppr (ic_type_env icxt))
789         ; thing_inside }
790 \end{code}
791
792
793 \begin{code}
794 tcRnStmt :: HscEnv
795          -> InteractiveContext
796          -> LStmt RdrName
797          -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
798                 -- The returned [Name] is the same as the input except for
799                 -- ExprStmt, in which case the returned [Name] is [itName]
800                 --
801                 -- The returned TypecheckedHsExpr is of type IO [ () ],
802                 -- a list of the bound values, coerced to ().
803
804 tcRnStmt hsc_env ictxt rdr_stmt
805   = initTcPrintErrors hsc_env iNTERACTIVE $ 
806     setInteractiveContext hsc_env ictxt $ do {
807
808     -- Rename; use CmdLineMode because tcRnStmt is only used interactively
809     (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ;
810     traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
811     failIfErrsM ;
812     
813     -- The real work is done here
814     (bound_ids, tc_expr) <- mkPlan rn_stmt ;
815     zonked_expr <- zonkTopLExpr tc_expr ;
816     zonked_ids  <- zonkTopBndrs bound_ids ;
817     
818         -- None of the Ids should be of unboxed type, because we
819         -- cast them all to HValues in the end!
820     mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
821
822     traceTc (text "tcs 1") ;
823     let {       -- (a) Make all the bound ids "global" ids, now that
824                 --     they're notionally top-level bindings.  This is
825                 --     important: otherwise when we come to compile an expression
826                 --     using these ids later, the byte code generator will consider
827                 --     the occurrences to be free rather than global.
828                 -- 
829                 -- (b) Tidy their types; this is important, because :info may
830                 --     ask to look at them, and :info expects the things it looks
831                 --     up to have tidy types
832         global_ids = map globaliseAndTidy zonked_ids ;
833     
834                 -- Update the interactive context
835         rn_env   = ic_rn_local_env ictxt ;
836         type_env = ic_type_env ictxt ;
837
838         bound_names = map idName global_ids ;
839         new_rn_env  = extendLocalRdrEnv rn_env bound_names ;
840
841 {- ---------------------------------------------
842    At one stage I removed any shadowed bindings from the type_env;
843    they are inaccessible but might, I suppose, cause a space leak if we leave them there.
844    However, with Template Haskell they aren't necessarily inaccessible.  Consider this
845    GHCi session
846          Prelude> let f n = n * 2 :: Int
847          Prelude> fName <- runQ [| f |]
848          Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
849          14
850          Prelude> let f n = n * 3 :: Int
851          Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
852    In the last line we use 'fName', which resolves to the *first* 'f'
853    in scope. If we delete it from the type env, GHCi crashes because
854    it doesn't expect that.
855  
856    Hence this code is commented out
857
858         shadowed = [ n | name <- bound_names,
859                          let rdr_name = mkRdrUnqual (nameOccName name),
860                          Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
861         filtered_type_env = delListFromNameEnv type_env shadowed ;
862 -------------------------------------------------- -}
863
864         new_type_env = extendTypeEnvWithIds type_env global_ids ;
865         new_ic = ictxt { ic_rn_local_env = new_rn_env, 
866                          ic_type_env     = new_type_env }
867     } ;
868
869     dumpOptTcRn Opt_D_dump_tc 
870         (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
871                text "Typechecked expr" <+> ppr zonked_expr]) ;
872
873     returnM (new_ic, bound_names, zonked_expr)
874     }
875   where
876     bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
877                                   nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
878
879 globaliseAndTidy :: Id -> Id
880 globaliseAndTidy id
881 -- Give the Id a Global Name, and tidy its type
882   = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
883   where
884     tidy_type = tidyTopType (idType id)
885 \end{code}
886
887 Here is the grand plan, implemented in tcUserStmt
888
889         What you type                   The IO [HValue] that hscStmt returns
890         -------------                   ------------------------------------
891         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
892                                         bindings: [x,y,...]
893
894         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
895                                         bindings: [x,y,...]
896
897         expr (of IO type)       ==>     expr >>= \ it -> return [coerce HVal it]
898           [NB: result not printed]      bindings: [it]
899           
900         expr (of non-IO type,   ==>     let it = expr in print it >> return [coerce HVal it]
901           result showable)              bindings: [it]
902
903         expr (of non-IO type, 
904           result not showable)  ==>     error
905
906
907 \begin{code}
908 ---------------------------
909 type PlanResult = ([Id], LHsExpr Id)
910 type Plan = TcM PlanResult
911
912 runPlans :: [Plan] -> TcM PlanResult
913 -- Try the plans in order.  If one fails (by raising an exn), try the next.
914 -- If one succeeds, take it.
915 runPlans []     = panic "runPlans"
916 runPlans [p]    = p
917 runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
918
919 --------------------
920 mkPlan :: LStmt Name -> TcM PlanResult
921 mkPlan (L loc (ExprStmt expr _ _))      -- An expression typed at the prompt 
922   = do  { uniq <- newUnique             -- is treated very specially
923         ; let fresh_it  = itName uniq
924               the_bind  = L loc $ mkFunBind (L loc fresh_it) matches
925               matches   = [mkMatch [] expr emptyLocalBinds]
926               let_stmt  = L loc $ LetStmt (HsValBinds (ValBindsOut [(NonRecursive,unitBag the_bind)] []))
927               bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
928                                            (HsVar bindIOName) noSyntaxExpr 
929               print_it  = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
930                                            (HsVar thenIOName) placeHolderType
931
932         -- The plans are:
933         --      [it <- e; print it]     but not if it::()
934         --      [it <- e]               
935         --      [let it = e; print it]  
936         ; runPlans [    -- Plan A
937                     do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
938                        ; it_ty <- zonkTcType (idType it_id)
939                        ; ifM (isUnitTy it_ty) failM
940                        ; return stuff },
941
942                         -- Plan B; a naked bind statment
943                     tcGhciStmts [bind_stmt],    
944
945                         -- Plan C; check that the let-binding is typeable all by itself.
946                         -- If not, fail; if so, try to print it.
947                         -- The two-step process avoids getting two errors: one from
948                         -- the expression itself, and one from the 'print it' part
949                         -- This two-step story is very clunky, alas
950                     do { checkNoErrs (tcGhciStmts [let_stmt]) 
951                                 --- checkNoErrs defeats the error recovery of let-bindings
952                        ; tcGhciStmts [let_stmt, print_it] }
953           ]}
954
955 mkPlan stmt@(L loc (BindStmt {}))
956   | [L _ v] <- collectLStmtBinders stmt         -- One binder, for a bind stmt 
957   = do  { let print_v  = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
958                                            (HsVar thenIOName) placeHolderType
959
960         ; print_bind_result <- doptM Opt_PrintBindResult
961         ; let print_plan = do
962                   { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
963                   ; v_ty <- zonkTcType (idType v_id)
964                   ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM
965                   ; return stuff }
966
967         -- The plans are:
968         --      [stmt; print v]         but not if v::()
969         --      [stmt]
970         ; runPlans ((if print_bind_result then [print_plan] else []) ++
971                     [tcGhciStmts [stmt]])
972         }
973
974 mkPlan stmt
975   = tcGhciStmts [stmt]
976
977 ---------------------------
978 tcGhciStmts :: [LStmt Name] -> TcM PlanResult
979 tcGhciStmts stmts
980  = do { ioTyCon <- tcLookupTyCon ioTyConName ;
981         ret_id  <- tcLookupId returnIOName ;            -- return @ IO
982         let {
983             io_ty     = mkTyConApp ioTyCon [] ;
984             ret_ty    = mkListTy unitTy ;
985             io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
986             tc_io_stmts stmts = tcStmts DoExpr (tcDoStmt io_ty) stmts 
987                                         (emptyRefinement, io_ret_ty) ;
988
989             names = map unLoc (collectLStmtsBinders stmts) ;
990
991                 -- mk_return builds the expression
992                 --      returnIO @ [()] [coerce () x, ..,  coerce () z]
993                 --
994                 -- Despite the inconvenience of building the type applications etc,
995                 -- this *has* to be done in type-annotated post-typecheck form
996                 -- because we are going to return a list of *polymorphic* values
997                 -- coerced to type (). If we built a *source* stmt
998                 --      return [coerce x, ..., coerce z]
999                 -- then the type checker would instantiate x..z, and we wouldn't
1000                 -- get their *polymorphic* values.  (And we'd get ambiguity errs
1001                 -- if they were overloaded, since they aren't applied to anything.)
1002             mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty]) 
1003                                     (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
1004             mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
1005                                  (nlHsVar id) 
1006          } ;
1007
1008         -- OK, we're ready to typecheck the stmts
1009         traceTc (text "tcs 2") ;
1010         ((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ ->
1011                                            mappM tcLookupId names ;
1012                                         -- Look up the names right in the middle,
1013                                         -- where they will all be in scope
1014
1015         -- Simplify the context
1016         const_binds <- checkNoErrs (tcSimplifyInteractive lie) ;
1017                 -- checkNoErrs ensures that the plan fails if context redn fails
1018
1019         return (ids, mkHsDictLet const_binds $
1020                      noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty))
1021     }
1022 \end{code}
1023
1024
1025 tcRnExpr just finds the type of an expression
1026
1027 \begin{code}
1028 tcRnExpr :: HscEnv
1029          -> InteractiveContext
1030          -> LHsExpr RdrName
1031          -> IO (Maybe Type)
1032 tcRnExpr hsc_env ictxt rdr_expr
1033   = initTcPrintErrors hsc_env iNTERACTIVE $ 
1034     setInteractiveContext hsc_env ictxt $ do {
1035
1036     (rn_expr, fvs) <- rnLExpr rdr_expr ;
1037     failIfErrsM ;
1038
1039         -- Now typecheck the expression; 
1040         -- it might have a rank-2 type (e.g. :t runST)
1041     ((tc_expr, res_ty), lie)       <- getLIE (tcInferRho rn_expr) ;
1042     ((qtvs, dict_insts, _), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie)  ;
1043     tcSimplifyInteractive lie_top ;
1044
1045     let { all_expr_ty = mkForAllTys qtvs $
1046                         mkFunTys (map (idType . instToId) dict_insts)   $
1047                         res_ty } ;
1048     zonkTcType all_expr_ty
1049     }
1050   where
1051     smpl_doc = ptext SLIT("main expression")
1052 \end{code}
1053
1054 tcRnType just finds the kind of a type
1055
1056 \begin{code}
1057 tcRnType :: HscEnv
1058          -> InteractiveContext
1059          -> LHsType RdrName
1060          -> IO (Maybe Kind)
1061 tcRnType hsc_env ictxt rdr_type
1062   = initTcPrintErrors hsc_env iNTERACTIVE $ 
1063     setInteractiveContext hsc_env ictxt $ do {
1064
1065     rn_type <- rnLHsType doc rdr_type ;
1066     failIfErrsM ;
1067
1068         -- Now kind-check the type
1069     (ty', kind) <- kcHsType rn_type ;
1070     return kind
1071     }
1072   where
1073     doc = ptext SLIT("In GHCi input")
1074
1075 #endif /* GHCi */
1076 \end{code}
1077
1078
1079 %************************************************************************
1080 %*                                                                      *
1081         More GHCi stuff, to do with browsing and getting info
1082 %*                                                                      *
1083 %************************************************************************
1084
1085 \begin{code}
1086 #ifdef GHCI
1087 -- ASSUMES that the module is either in the HomePackageTable or is
1088 -- a package module with an interface on disk.  If neither of these is
1089 -- true, then the result will be an error indicating the interface
1090 -- could not be found.
1091 getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo])
1092 getModuleExports hsc_env mod
1093   = initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod)
1094
1095 tcGetModuleExports :: Module -> TcM [AvailInfo]
1096 tcGetModuleExports mod = do
1097   let doc = ptext SLIT("context for compiling statements")
1098   iface <- initIfaceTcRn $ loadSysInterface doc mod
1099   loadOrphanModules (dep_orphs (mi_deps iface)) False 
1100                 -- Load any orphan-module interfaces,
1101                 -- so their instances are visible
1102   loadOrphanModules (dep_finsts (mi_deps iface)) True
1103                 -- Load any family instance-module interfaces,
1104                 -- so all family instances are visible
1105   ifaceExportNames (mi_exports iface)
1106
1107 tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
1108 tcRnLookupRdrName hsc_env rdr_name 
1109   = initTcPrintErrors hsc_env iNTERACTIVE $ 
1110     setInteractiveContext hsc_env (hsc_IC hsc_env) $ 
1111     lookup_rdr_name rdr_name
1112
1113 lookup_rdr_name rdr_name = do {
1114         -- If the identifier is a constructor (begins with an
1115         -- upper-case letter), then we need to consider both
1116         -- constructor and type class identifiers.
1117     let { rdr_names = dataTcOccs rdr_name } ;
1118
1119         -- results :: [Either Messages Name]
1120     results <- mapM (tryTcErrs . lookupOccRn) rdr_names ;
1121
1122     traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
1123         -- The successful lookups will be (Just name)
1124     let { (warns_s, good_names) = unzip [ (msgs, name) 
1125                                         | (msgs, Just name) <- results] ;
1126           errs_s = [msgs | (msgs, Nothing) <- results] } ;
1127
1128         -- Fail if nothing good happened, else add warnings
1129     if null good_names then
1130                 -- No lookup succeeded, so
1131                 -- pick the first error message and report it
1132                 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
1133                 --       while the other is "X is not in scope", 
1134                 --       we definitely want the former; but we might pick the latter
1135         do { addMessages (head errs_s) ; failM }
1136       else                      -- Add deprecation warnings
1137         mapM_ addMessages warns_s ;
1138     
1139     return good_names
1140  }
1141
1142 tcRnRecoverDataCon :: HscEnv -> a -> IO (Maybe DataCon) 
1143 tcRnRecoverDataCon hsc_env a
1144   = initTcPrintErrors hsc_env iNTERACTIVE $ 
1145     setInteractiveContext hsc_env (hsc_IC hsc_env) $
1146      do name    <- recoverDataCon a
1147         tcLookupDataCon name
1148
1149 tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
1150 tcRnLookupName hsc_env name
1151   = initTcPrintErrors hsc_env iNTERACTIVE $ 
1152     setInteractiveContext hsc_env (hsc_IC hsc_env) $
1153     tcLookupGlobal name
1154
1155
1156 tcRnGetInfo :: HscEnv
1157             -> Name
1158             -> IO (Maybe (TyThing, Fixity, [Instance]))
1159
1160 -- Used to implemnent :info in GHCi
1161 --
1162 -- Look up a RdrName and return all the TyThings it might be
1163 -- A capitalised RdrName is given to us in the DataName namespace,
1164 -- but we want to treat it as *both* a data constructor 
1165 --  *and* as a type or class constructor; 
1166 -- hence the call to dataTcOccs, and we return up to two results
1167 tcRnGetInfo hsc_env name
1168   = initTcPrintErrors hsc_env iNTERACTIVE $ 
1169     let ictxt = hsc_IC hsc_env in
1170     setInteractiveContext hsc_env ictxt $ do
1171
1172         -- Load the interface for all unqualified types and classes
1173         -- That way we will find all the instance declarations
1174         -- (Packages have not orphan modules, and we assume that
1175         --  in the home package all relevant modules are loaded.)
1176     loadUnqualIfaces ictxt
1177
1178     thing  <- tcLookupGlobal name
1179     fixity <- lookupFixityRn name
1180     ispecs <- lookupInsts (icPrintUnqual ictxt) thing
1181     return (thing, fixity, ispecs)
1182
1183 lookupInsts :: PrintUnqualified -> TyThing -> TcM [Instance]
1184 -- Filter the instances by the ones whose tycons (or clases resp) 
1185 -- are in scope unqualified.  Otherwise we list a whole lot too many!
1186 lookupInsts print_unqual (AClass cls)
1187   = do  { inst_envs <- tcGetInstEnvs
1188         ; return [ ispec
1189                  | ispec <- classInstances inst_envs cls
1190                  , plausibleDFun print_unqual (instanceDFunId ispec) ] }
1191
1192 lookupInsts print_unqual (ATyCon tc)
1193   = do  { eps <- getEps -- Load all instances for all classes that are
1194                         -- in the type environment (which are all the ones
1195                         -- we've seen in any interface file so far)
1196         ; (pkg_ie, home_ie) <- tcGetInstEnvs    -- Search all
1197         ; return [ ispec
1198                  | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
1199                  , let dfun = instanceDFunId ispec
1200                  , relevant dfun
1201                  , plausibleDFun print_unqual dfun ] }
1202   where
1203     relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
1204     tc_name     = tyConName tc            
1205
1206 lookupInsts print_unqual other = return []
1207
1208 plausibleDFun print_unqual dfun -- Dfun involving only names that print unqualified
1209   = all ok (nameSetToList (tyClsNamesOfType (idType dfun)))
1210   where
1211     ok name | isBuiltInSyntax name = True
1212             | isExternalName name  = 
1213                 isNothing $ fst print_unqual (nameModule name) 
1214                                              (nameOccName name)
1215             | otherwise            = True
1216
1217 loadUnqualIfaces :: InteractiveContext -> TcM ()
1218 -- Load the home module for everything that is in scope unqualified
1219 -- This is so that we can accurately report the instances for 
1220 -- something
1221 loadUnqualIfaces ictxt
1222   = initIfaceTcRn $
1223     mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
1224   where
1225     unqual_mods = [ nameModule name
1226                   | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt),
1227                     let name = gre_name gre,
1228                     not (isInternalName name),
1229                     isTcOcc (nameOccName name),  -- Types and classes only
1230                     unQualOK gre ]               -- In scope unqualified
1231     doc = ptext SLIT("Need interface for module whose export(s) are in scope unqualified")
1232 #endif /* GHCI */
1233 \end{code}
1234
1235 %************************************************************************
1236 %*                                                                      *
1237                 Degugging output
1238 %*                                                                      *
1239 %************************************************************************
1240
1241 \begin{code}
1242 rnDump :: SDoc -> TcRn ()
1243 -- Dump, with a banner, if -ddump-rn
1244 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1245
1246 tcDump :: TcGblEnv -> TcRn ()
1247 tcDump env
1248  = do { dflags <- getDOpts ;
1249
1250         -- Dump short output if -ddump-types or -ddump-tc
1251         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1252             (dumpTcRn short_dump) ;
1253
1254         -- Dump bindings if -ddump-tc
1255         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1256    }
1257   where
1258     short_dump = pprTcGblEnv env
1259     full_dump  = pprLHsBinds (tcg_binds env)
1260         -- NB: foreign x-d's have undefined's in their types; 
1261         --     hence can't show the tc_fords
1262
1263 tcCoreDump mod_guts
1264  = do { dflags <- getDOpts ;
1265         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1266             (dumpTcRn (pprModGuts mod_guts)) ;
1267
1268         -- Dump bindings if -ddump-tc
1269         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1270   where
1271     full_dump = pprCoreBindings (mg_binds mod_guts)
1272
1273 -- It's unpleasant having both pprModGuts and pprModDetails here
1274 pprTcGblEnv :: TcGblEnv -> SDoc
1275 pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env, 
1276                         tcg_insts     = insts, 
1277                         tcg_fam_insts = fam_insts, 
1278                         tcg_rules     = rules,
1279                         tcg_imports   = imports })
1280   = vcat [ ppr_types insts type_env
1281          , ppr_tycons fam_insts type_env
1282          , ppr_insts insts
1283          , ppr_fam_insts fam_insts
1284          , vcat (map ppr rules)
1285          , ppr_gen_tycons (typeEnvTyCons type_env)
1286          , ptext SLIT("Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports))
1287          , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1288
1289 pprModGuts :: ModGuts -> SDoc
1290 pprModGuts (ModGuts { mg_types = type_env,
1291                       mg_rules = rules })
1292   = vcat [ ppr_types [] type_env,
1293            ppr_rules rules ]
1294
1295 ppr_types :: [Instance] -> TypeEnv -> SDoc
1296 ppr_types insts type_env
1297   = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1298   where
1299     dfun_ids = map instanceDFunId insts
1300     ids = [id | id <- typeEnvIds type_env, want_sig id]
1301     want_sig id | opt_PprStyle_Debug = True
1302                 | otherwise          = isLocalId id && 
1303                                        isExternalName (idName id) && 
1304                                        not (id `elem` dfun_ids)
1305         -- isLocalId ignores data constructors, records selectors etc.
1306         -- The isExternalName ignores local dictionary and method bindings
1307         -- that the type checker has invented.  Top-level user-defined things 
1308         -- have External names.
1309
1310 ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
1311 ppr_tycons fam_insts type_env
1312   = text "TYPE CONSTRUCTORS" $$ nest 4 (ppr_tydecls tycons)
1313   where
1314     fi_tycons = map famInstTyCon fam_insts
1315     tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
1316     want_tycon tycon | opt_PprStyle_Debug = True
1317                      | otherwise          = not (isImplicitTyCon tycon) &&
1318                                             isExternalName (tyConName tycon) &&
1319                                             not (tycon `elem` fi_tycons)
1320
1321 ppr_insts :: [Instance] -> SDoc
1322 ppr_insts []     = empty
1323 ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
1324
1325 ppr_fam_insts :: [FamInst] -> SDoc
1326 ppr_fam_insts []        = empty
1327 ppr_fam_insts fam_insts = 
1328   text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts)
1329
1330 ppr_sigs :: [Var] -> SDoc
1331 ppr_sigs ids
1332         -- Print type signatures; sort by OccName 
1333   = vcat (map ppr_sig (sortLe le_sig ids))
1334   where
1335     le_sig id1 id2 = getOccName id1 <= getOccName id2
1336     ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
1337
1338 ppr_tydecls :: [TyCon] -> SDoc
1339 ppr_tydecls tycons
1340         -- Print type constructor info; sort by OccName 
1341   = vcat (map ppr_tycon (sortLe le_sig tycons))
1342   where
1343     le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
1344     ppr_tycon tycon 
1345       | isCoercionTyCon tycon = ptext SLIT("coercion") <+> ppr tycon
1346       | otherwise             = ppr (tyThingToIfaceDecl (ATyCon tycon))
1347
1348 ppr_rules :: [CoreRule] -> SDoc
1349 ppr_rules [] = empty
1350 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1351                       nest 4 (pprRules rs),
1352                       ptext SLIT("#-}")]
1353
1354 ppr_gen_tycons []  = empty
1355 ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"),
1356                            nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]
1357 \end{code}