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