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