Major refactoring of CoAxioms
[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[TcMovectle]{Typechecking a whole module}
6
7 \begin{code}
8 {-# OPTIONS -fno-warn-tabs #-}
9 -- The above warning supression flag is a temporary kludge.
10 -- While working on this module you are encouraged to remove it and
11 -- detab the module (please do the detabbing in a separate patch). See
12 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
13 -- for details
14
15 module TcRnDriver (
16 #ifdef GHCI
17         tcRnStmt, tcRnExpr, tcRnType,
18         tcRnImportDecls,
19         tcRnLookupRdrName,
20         getModuleInterface,
21         tcRnDeclsi,
22 #endif
23         tcRnLookupName,
24         tcRnGetInfo,
25         tcRnModule, 
26         tcTopSrcDecls,
27         tcRnExtCore
28     ) where
29
30 #ifdef GHCI
31 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
32 #endif
33
34 import DynFlags
35 import StaticFlags
36 import HsSyn
37 import PrelNames
38 import RdrName
39 import TcHsSyn
40 import TcExpr
41 import TcRnMonad
42 import TcEvidence
43 import Coercion( pprCoAxiom )
44 import FamInst
45 import InstEnv
46 import FamInstEnv
47 import TcAnnotations
48 import TcBinds
49 import HeaderInfo       ( mkPrelImports )
50 import TcType   ( tidyTopType )
51 import TcDefaults
52 import TcEnv
53 import TcRules
54 import TcForeign
55 import TcInstDcls
56 import TcIface
57 import TcMType
58 import MkIface
59 import IfaceSyn
60 import TcSimplify
61 import TcTyClsDecls
62 import LoadIface
63 import RnNames
64 import RnEnv
65 import RnSource
66 import PprCore
67 import CoreSyn
68 import ErrUtils
69 import Id
70 import VarEnv
71 import Var
72 import Module
73 import UniqFM
74 import Name
75 import NameEnv
76 import NameSet
77 import Avail
78 import TyCon
79 import SrcLoc
80 import HscTypes
81 import ListSetOps
82 import Outputable
83 import DataCon
84 import Type
85 import Class
86 import TcType   ( orphNamesOfDFunHead )
87 import Inst     ( tcGetInstEnvs )
88 import Data.List ( sortBy )
89 import Data.IORef ( readIORef )
90
91 #ifdef GHCI
92 import TcType   ( isUnitTy, isTauTy )
93 import TcHsType
94 import TcMatches
95 import RnTypes
96 import RnExpr
97 import MkId
98 import BasicTypes
99 import TidyPgm    ( globaliseAndTidyId )
100 import TysWiredIn ( unitTy, mkListTy )
101 #endif
102
103 import FastString
104 import Maybes
105 import Util
106 import Bag
107
108 import Control.Monad
109
110 #include "HsVersions.h"
111 \end{code}
112
113 %************************************************************************
114 %*                                                                      *
115         Typecheck and rename a module
116 %*                                                                      *
117 %************************************************************************
118
119
120 \begin{code}
121 -- | Top level entry point for typechecker and renamer
122 tcRnModule :: HscEnv 
123            -> HscSource
124            -> Bool              -- True <=> save renamed syntax
125            -> HsParsedModule
126            -> IO (Messages, Maybe TcGblEnv)
127
128 tcRnModule hsc_env hsc_src save_rn_syntax
129    HsParsedModule {
130       hpm_module =
131          (L loc (HsModule maybe_mod export_ies
132                           import_decls local_decls mod_deprec
133                           maybe_doc_hdr)),
134       hpm_src_files =
135          src_files
136    }
137  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
138
139    let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
140          (this_mod, prel_imp_loc) 
141             = case maybe_mod of
142                 Nothing -- 'module M where' is omitted  
143                     ->  (mAIN, srcLocSpan (srcSpanStart loc))   
144                                    
145                 Just (L mod_loc mod)  -- The normal case
146                     -> (mkModule this_pkg mod, mod_loc) } ;
147                 
148    initTc hsc_env hsc_src save_rn_syntax this_mod $ 
149    setSrcSpan loc $
150    do {         -- Deal with imports; first add implicit prelude
151         implicit_prelude <- xoptM Opt_ImplicitPrelude;
152         let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc
153                                          implicit_prelude import_decls } ;
154
155         ifWOptM Opt_WarnImplicitPrelude $
156              when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ;
157
158         tcg_env <- {-# SCC "tcRnImports" #-}
159                    tcRnImports hsc_env this_mod (prel_imports ++ import_decls) ;
160         setGblEnv tcg_env               $ do {
161
162                 -- Load the hi-boot interface for this module, if any
163                 -- We do this now so that the boot_names can be passed
164                 -- to tcTyAndClassDecls, because the boot_names are 
165                 -- automatically considered to be loop breakers
166                 --
167                 -- Do this *after* tcRnImports, so that we know whether
168                 -- a module that we import imports us; and hence whether to
169                 -- look for a hi-boot file
170         boot_iface <- tcHiBootIface hsc_src this_mod ;
171
172                 -- Rename and type check the declarations
173         traceRn (text "rn1a") ;
174         tcg_env <- if isHsBoot hsc_src then
175                         tcRnHsBootDecls local_decls
176                    else 
177                         {-# SCC "tcRnSrcDecls" #-}
178                         tcRnSrcDecls boot_iface local_decls ;
179         setGblEnv tcg_env               $ do {
180
181                 -- Report the use of any deprecated things
182                 -- We do this *before* processsing the export list so
183                 -- that we don't bleat about re-exporting a deprecated
184                 -- thing (especially via 'module Foo' export item)
185                 -- That is, only uses in the *body* of the module are complained about
186         traceRn (text "rn3") ;
187         failIfErrsM ;   -- finishWarnings crashes sometimes 
188                         -- as a result of typechecker repairs (e.g. unboundNames)
189         tcg_env <- finishWarnings (hsc_dflags hsc_env) mod_deprec tcg_env ;
190
191                 -- Process the export list
192         traceRn (text "rn4a: before exports");
193         tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ;
194         traceRn (text "rn4b: after exportss") ;
195
196                 -- Check that main is exported (must be after rnExports)
197         checkMainExported tcg_env ;
198
199         -- Compare the hi-boot iface (if any) with the real thing
200         -- Must be done after processing the exports
201         tcg_env <- checkHiBootIface tcg_env boot_iface ;
202
203         -- The new type env is already available to stuff slurped from 
204         -- interface files, via TcEnv.updateGlobalTypeEnv
205         -- It's important that this includes the stuff in checkHiBootIface, 
206         -- because the latter might add new bindings for boot_dfuns, 
207         -- which may be mentioned in imported unfoldings
208
209                 -- Don't need to rename the Haddock documentation,
210                 -- it's not parsed by GHC anymore.
211         tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ;
212
213                 -- Report unused names
214         reportUnusedNames export_ies tcg_env ;
215
216                 -- add extra source files to tcg_dependent_files
217         addDependentFiles src_files ;
218
219                 -- Dump output and return
220         tcDump tcg_env ;
221         return tcg_env
222     }}}}
223
224
225 implicitPreludeWarn :: SDoc
226 implicitPreludeWarn
227   = ptext (sLit "Module `Prelude' implicitly imported")
228 \end{code}
229
230
231 %************************************************************************
232 %*                                                                      *
233                 Import declarations
234 %*                                                                      *
235 %************************************************************************
236
237 \begin{code}
238 tcRnImports :: HscEnv -> Module 
239             -> [LImportDecl RdrName] -> TcM TcGblEnv
240 tcRnImports hsc_env this_mod import_decls
241   = do  { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ;
242
243         ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
244                 -- Make sure we record the dependencies from the DynFlags in the EPS or we
245                 -- end up hitting the sanity check in LoadIface.loadInterface that
246                 -- checks for unknown home-package modules being loaded. We put
247                 -- these dependencies on the left so their (non-source) imports
248                 -- take precedence over the (possibly-source) imports on the right.
249                 -- We don't add them to any other field (e.g. the imp_dep_mods of
250                 -- imports) because we don't want to load their instances etc.
251               ; dep_mods = listToUFM [(mod_nm, (mod_nm, False)) | mod_nm <- dynFlagDependencies (hsc_dflags hsc_env)]
252                                 `plusUFM` imp_dep_mods imports
253
254                 -- We want instance declarations from all home-package
255                 -- modules below this one, including boot modules, except
256                 -- ourselves.  The 'except ourselves' is so that we don't
257                 -- get the instances from this module's hs-boot file
258               ; want_instances :: ModuleName -> Bool
259               ; want_instances mod = mod `elemUFM` dep_mods
260                                    && mod /= moduleName this_mod
261               ; (home_insts, home_fam_insts) = hptInstances hsc_env 
262                                                             want_instances
263               } ;
264
265                 -- Record boot-file info in the EPS, so that it's 
266                 -- visible to loadHiBootInterface in tcRnSrcDecls,
267                 -- and any other incrementally-performed imports
268         ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
269
270                 -- Update the gbl env
271         ; updGblEnv ( \ gbl -> 
272             gbl { 
273               tcg_rdr_env      = plusOccEnv (tcg_rdr_env gbl) rdr_env,
274               tcg_imports      = tcg_imports gbl `plusImportAvails` imports,
275               tcg_rn_imports   = rn_imports,
276               tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,
277               tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) 
278                                                       home_fam_insts,
279               tcg_hpc          = hpc_info
280             }) $ do {
281
282         ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports))
283                 -- Fail if there are any errors so far
284                 -- The error printing (if needed) takes advantage 
285                 -- of the tcg_env we have now set
286 --      ; traceIf (text "rdr_env: " <+> ppr rdr_env)
287         ; failIfErrsM
288
289                 -- Load any orphan-module and family instance-module
290                 -- interfaces, so that their rules and instance decls will be
291                 -- found.
292         ; loadModuleInterfaces (ptext (sLit "Loading orphan modules")) 
293                                (imp_orphs imports)
294
295                 -- Check type-family consistency
296         ; traceRn (text "rn1: checking family instance consistency")
297         ; let { dir_imp_mods = moduleEnvKeys
298                              . imp_mods 
299                              $ imports }
300         ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;
301
302         ; getGblEnv } }
303 \end{code}
304
305
306 %************************************************************************
307 %*                                                                      *
308         Type-checking external-core modules
309 %*                                                                      *
310 %************************************************************************
311
312 \begin{code}
313 tcRnExtCore :: HscEnv 
314             -> HsExtCore RdrName
315             -> IO (Messages, Maybe ModGuts)
316         -- Nothing => some error occurred 
317
318 tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
319         -- The decls are IfaceDecls; all names are original names
320  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
321
322    initTc hsc_env ExtCoreFile False this_mod $ do {
323
324    let { ldecls  = map noLoc decls } ;
325
326        -- Bring the type and class decls into scope
327        -- ToDo: check that this doesn't need to extract the val binds.
328        --       It seems that only the type and class decls need to be in scope below because
329        --          (a) tcTyAndClassDecls doesn't need the val binds, and 
330        --          (b) tcExtCoreBindings doesn't need anything
331        --              (in fact, it might not even need to be in the scope of
332        --               this tcg_env at all)
333    (tc_envs, _bndrs) <- getLocalNonValBinders emptyFsEnv {- no fixity decls -} 
334                                               (mkFakeGroup ldecls) ;
335    setEnvs tc_envs $ do {
336
337    (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [] [ldecls] ;
338    -- The empty list is for extra dependencies coming from .hs-boot files
339    -- See Note [Extra dependencies from .hs-boot files] in RnSource
340
341         -- Dump trace of renaming part
342    rnDump (ppr rn_decls) ;
343
344         -- Typecheck them all together so that
345         -- any mutually recursive types are done right
346         -- Just discard the auxiliary bindings; they are generated 
347         -- only for Haskell source code, and should already be in Core
348    tcg_env   <- tcTyAndClassDecls emptyModDetails rn_decls ;
349    dep_files <- liftIO $ readIORef (tcg_dependent_files tcg_env) ;
350
351    setGblEnv tcg_env $ do {
352         -- Make the new type env available to stuff slurped from interface files
353    
354         -- Now the core bindings
355    core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
356
357
358         -- Wrap up
359    let {
360         bndrs      = bindersOfBinds core_binds ;
361         my_exports = map (Avail . idName) bndrs ;
362                 -- ToDo: export the data types also?
363
364         mod_guts = ModGuts {    mg_module    = this_mod,
365                                 mg_boot      = False,
366                                 mg_used_names = emptyNameSet, -- ToDo: compute usage
367                                 mg_used_th   = False,
368                                 mg_dir_imps  = emptyModuleEnv, -- ??
369                                 mg_deps      = noDependencies,  -- ??
370                                 mg_exports   = my_exports,
371                                 mg_tcs       = tcg_tcs tcg_env,
372                                 mg_insts     = tcg_insts tcg_env,
373                                 mg_fam_insts = tcg_fam_insts tcg_env,
374                                 mg_inst_env  = tcg_inst_env tcg_env,
375                                 mg_fam_inst_env = tcg_fam_inst_env tcg_env,
376                                 mg_rules     = [],
377                                 mg_vect_decls = [],
378                                 mg_anns      = [],
379                                 mg_binds     = core_binds,
380
381                                 -- Stubs
382                                 mg_rdr_env   = emptyGlobalRdrEnv,
383                                 mg_fix_env   = emptyFixityEnv,
384                                 mg_warns     = NoWarnings,
385                                 mg_foreign   = NoStubs,
386                                 mg_hpc_info  = emptyHpcInfo False,
387                                 mg_modBreaks = emptyModBreaks,
388                                 mg_vect_info = noVectInfo,
389                                 mg_trust_pkg = False,
390                                 mg_dependent_files = dep_files
391                             } } ;
392
393    tcCoreDump mod_guts ;
394
395    return mod_guts
396    }}}}
397
398 mkFakeGroup :: [LTyClDecl a] -> HsGroup a
399 mkFakeGroup decls -- Rather clumsy; lots of unused fields
400   = emptyRdrGroup { hs_tyclds = [decls] }
401 \end{code}
402
403
404 %************************************************************************
405 %*                                                                      *
406         Type-checking the top level of a module
407 %*                                                                      *
408 %************************************************************************
409
410 \begin{code}
411 tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv
412         -- Returns the variables free in the decls
413         -- Reason: solely to report unused imports and bindings
414 tcRnSrcDecls boot_iface decls
415  = do {         -- Do all the declarations
416         ((tcg_env, tcl_env), lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ;
417       ; traceTc "Tc8" empty ;
418       ; setEnvs (tcg_env, tcl_env) $ 
419    do { 
420
421              --         Finish simplifying class constraints
422              -- 
423              -- simplifyTop deals with constant or ambiguous InstIds.  
424              -- How could there be ambiguous ones?  They can only arise if a
425              -- top-level decl falls under the monomorphism restriction
426              -- and no subsequent decl instantiates its type.
427              --
428              -- We do this after checkMain, so that we use the type info 
429              -- that checkMain adds
430              -- 
431              -- We do it with both global and local env in scope:
432              --  * the global env exposes the instances to simplifyTop
433              --  * the local env exposes the local Ids to simplifyTop, 
434              --    so that we get better error messages (monomorphism restriction)
435         new_ev_binds <- {-# SCC "simplifyTop" #-}
436                         simplifyTop lie ;
437         traceTc "Tc9" empty ;
438
439         failIfErrsM ;   -- Don't zonk if there have been errors
440                         -- It's a waste of time; and we may get debug warnings
441                         -- about strangely-typed TyCons!
442
443         -- Zonk the final code.  This must be done last.
444         -- Even simplifyTop may do some unification.
445         -- This pass also warns about missing type signatures
446         let { TcGblEnv { tcg_type_env  = type_env,
447                          tcg_binds     = binds,
448                          tcg_sigs      = sig_ns,
449                          tcg_ev_binds  = cur_ev_binds,
450                          tcg_imp_specs = imp_specs,
451                          tcg_rules     = rules,
452                          tcg_vects     = vects,
453                          tcg_fords     = fords } = tcg_env
454             ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
455
456         (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') 
457             <- {-# SCC "zonkTopDecls" #-}
458                zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords ;
459         
460         let { final_type_env = extendTypeEnvWithIds type_env bind_ids
461             ; tcg_env' = tcg_env { tcg_binds    = binds',
462                                    tcg_ev_binds = ev_binds',
463                                    tcg_imp_specs = imp_specs',
464                                    tcg_rules    = rules', 
465                                    tcg_vects    = vects', 
466                                    tcg_fords    = fords' } } ;
467
468         setGlobalTypeEnv tcg_env' final_type_env
469    } }
470
471 tc_rn_src_decls :: ModDetails 
472                     -> [LHsDecl RdrName] 
473                     -> TcM (TcGblEnv, TcLclEnv)
474 -- Loops around dealing with each top level inter-splice group 
475 -- in turn, until it's dealt with the entire module
476 tc_rn_src_decls boot_details ds
477  = {-# SCC "tc_rn_src_decls" #-}
478    do { (first_group, group_tail) <- findSplice ds  ;
479                 -- If ds is [] we get ([], Nothing)
480         
481         -- The extra_deps are needed while renaming type and class declarations 
482         -- See Note [Extra dependencies from .hs-boot files] in RnSource
483         let { extra_deps = map tyConName (typeEnvTyCons (md_types boot_details)) } ;
484         -- Deal with decls up to, but not including, the first splice
485         (tcg_env, rn_decls) <- rnTopSrcDecls extra_deps first_group ;
486                 -- rnTopSrcDecls fails if there are any errors
487         
488         (tcg_env, tcl_env) <- setGblEnv tcg_env $ 
489                               tcTopSrcDecls boot_details rn_decls ;
490
491         -- If there is no splice, we're nearly done
492         setEnvs (tcg_env, tcl_env) $ 
493         case group_tail of {
494            Nothing -> do { tcg_env <- checkMain ;       -- Check for `main'
495                            return (tcg_env, tcl_env) 
496                       } ;
497
498 #ifndef GHCI
499         -- There shouldn't be a splice
500            Just (SpliceDecl {}, _) -> do {
501         failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
502 #else
503         -- If there's a splice, we must carry on
504            Just (SpliceDecl splice_expr _, rest_ds) -> do {
505
506         -- Rename the splice expression, and get its supporting decls
507         (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;
508                 -- checkNoErrs: don't typecheck if renaming failed
509         rnDump (ppr rn_splice_expr) ;
510
511         -- Execute the splice
512         spliced_decls <- tcSpliceDecls rn_splice_expr ;
513
514         -- Glue them on the front of the remaining decls and loop
515         setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
516         tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
517 #endif /* GHCI */
518     } } }
519 \end{code}
520
521 %************************************************************************
522 %*                                                                      *
523         Compiling hs-boot source files, and
524         comparing the hi-boot interface with the real thing
525 %*                                                                      *
526 %************************************************************************
527
528 \begin{code}
529 tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
530 tcRnHsBootDecls decls
531    = do { (first_group, group_tail) <- findSplice decls
532
533                 -- Rename the declarations
534         ; (tcg_env, HsGroup { 
535                    hs_tyclds = tycl_decls, 
536                    hs_instds = inst_decls,
537                    hs_derivds = deriv_decls,
538                    hs_fords  = for_decls,
539                    hs_defds  = def_decls,  
540                    hs_ruleds = rule_decls, 
541                    hs_vects  = vect_decls, 
542                    hs_annds  = _,
543                    hs_valds  = val_binds }) <- rnTopSrcDecls [] first_group
544         -- The empty list is for extra dependencies coming from .hs-boot files
545         -- See Note [Extra dependencies from .hs-boot files] in RnSource
546         ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
547
548
549                 -- Check for illegal declarations
550         ; case group_tail of
551              Just (SpliceDecl d _, _) -> badBootDecl "splice" d
552              Nothing                  -> return ()
553         ; mapM_ (badBootDecl "foreign") for_decls
554         ; mapM_ (badBootDecl "default") def_decls
555         ; mapM_ (badBootDecl "rule")    rule_decls
556         ; mapM_ (badBootDecl "vect")    vect_decls
557
558                 -- Typecheck type/class decls
559         ; traceTc "Tc2" empty
560         ; tcg_env <- tcTyAndClassDecls emptyModDetails tycl_decls
561         ; setGblEnv tcg_env    $ do {
562
563                 -- Typecheck instance decls
564                 -- Family instance declarations are rejected here
565         ; traceTc "Tc3" empty
566         ; (tcg_env, inst_infos, _deriv_binds) 
567             <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls
568
569         ; setGblEnv tcg_env     $ do {
570
571                 -- Typecheck value declarations
572         ; traceTc "Tc5" empty 
573         ; val_ids <- tcHsBootSigs val_binds
574
575                 -- Wrap up
576                 -- No simplification or zonking to do
577         ; traceTc "Tc7a" empty
578         ; gbl_env <- getGblEnv 
579         
580                 -- Make the final type-env
581                 -- Include the dfun_ids so that their type sigs
582                 -- are written into the interface file. 
583         ; let { type_env0 = tcg_type_env gbl_env
584               ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
585               ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids 
586               ; dfun_ids = map iDFunId inst_infos
587               }
588
589         ; setGlobalTypeEnv gbl_env type_env2
590    }}}
591    ; traceTc "boot" (ppr lie); return gbl_env }
592
593 badBootDecl :: String -> Located decl -> TcM ()
594 badBootDecl what (L loc _) 
595   = addErrAt loc (char 'A' <+> text what 
596       <+> ptext (sLit "declaration is not (currently) allowed in a hs-boot file"))
597 \end{code}
598
599 Once we've typechecked the body of the module, we want to compare what
600 we've found (gathered in a TypeEnv) with the hi-boot details (if any).
601
602 \begin{code}
603 checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv
604 -- Compare the hi-boot file for this module (if there is one)
605 -- with the type environment we've just come up with
606 -- In the common case where there is no hi-boot file, the list
607 -- of boot_names is empty.
608 --
609 -- The bindings we return give bindings for the dfuns defined in the
610 -- hs-boot file, such as        $fbEqT = $fEqT
611
612 checkHiBootIface
613         tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds,
614                             tcg_insts = local_insts, 
615                             tcg_type_env = local_type_env, tcg_exports = local_exports })
616         (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
617                       md_types = boot_type_env, md_exports = boot_exports })
618   | isHsBoot hs_src     -- Current module is already a hs-boot file!
619   = return tcg_env      
620
621   | otherwise
622   = do  { traceTc "checkHiBootIface" $ vcat
623              [ ppr boot_type_env, ppr boot_insts, ppr boot_exports]
624
625                 -- Check the exports of the boot module, one by one
626         ; mapM_ check_export boot_exports
627
628                 -- Check for no family instances
629         ; unless (null boot_fam_insts) $
630             panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
631                    "instances in boot files yet...")
632             -- FIXME: Why?  The actual comparison is not hard, but what would
633             --        be the equivalent to the dfun bindings returned for class
634             --        instances?  We can't easily equate tycons...
635
636                 -- Check instance declarations
637         ; mb_dfun_prs <- mapM check_inst boot_insts
638         ; let dfun_prs   = catMaybes mb_dfun_prs
639               boot_dfuns = map fst dfun_prs
640               dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
641                                      | (boot_dfun, dfun) <- dfun_prs ]
642               type_env'  = extendTypeEnvWithIds local_type_env boot_dfuns
643               tcg_env'   = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
644
645         ; failIfErrsM
646         ; setGlobalTypeEnv tcg_env' type_env' }
647              -- Update the global type env *including* the knot-tied one
648              -- so that if the source module reads in an interface unfolding
649              -- mentioning one of the dfuns from the boot module, then it
650              -- can "see" that boot dfun.   See Trac #4003
651   where
652     check_export boot_avail     -- boot_avail is exported by the boot iface
653       | name `elem` dfun_names = return ()      
654       | isWiredInName name     = return ()      -- No checking for wired-in names.  In particular,
655                                                 -- 'error' is handled by a rather gross hack
656                                                 -- (see comments in GHC.Err.hs-boot)
657
658         -- Check that the actual module exports the same thing
659       | not (null missing_names)
660       = addErrAt (nameSrcSpan (head missing_names)) 
661                  (missingBootThing (head missing_names) "exported by")
662
663         -- If the boot module does not *define* the thing, we are done
664         -- (it simply re-exports it, and names match, so nothing further to do)
665       | isNothing mb_boot_thing = return ()
666
667         -- Check that the actual module also defines the thing, and 
668         -- then compare the definitions
669       | Just real_thing <- lookupTypeEnv local_type_env name,
670         Just boot_thing <- mb_boot_thing
671       = when (not (checkBootDecl boot_thing real_thing))
672             $ addErrAt (nameSrcSpan (getName boot_thing))
673                        (let boot_decl = tyThingToIfaceDecl 
674                                                (fromJust mb_boot_thing)
675                             real_decl = tyThingToIfaceDecl real_thing
676                         in bootMisMatch real_thing boot_decl real_decl)
677
678       | otherwise
679       = addErrTc (missingBootThing name "defined in")
680       where
681         name          = availName boot_avail
682         mb_boot_thing = lookupTypeEnv boot_type_env name
683         missing_names = case lookupNameEnv local_export_env name of
684                           Nothing    -> [name]
685                           Just avail -> availNames boot_avail `minusList` availNames avail
686                  
687     dfun_names = map getName boot_insts
688
689     local_export_env :: NameEnv AvailInfo
690     local_export_env = availsToNameEnv local_exports
691
692     check_inst :: ClsInst -> TcM (Maybe (Id, Id))
693         -- Returns a pair of the boot dfun in terms of the equivalent real dfun
694     check_inst boot_inst
695         = case [dfun | inst <- local_insts, 
696                        let dfun = instanceDFunId inst,
697                        idType dfun `eqType` boot_inst_ty ] of
698             [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts)
699                                                   , text "boot_inst"   <+> ppr boot_inst
700                                                   , text "boot_inst_ty" <+> ppr boot_inst_ty
701                                                   ]) 
702                      ; addErrTc (instMisMatch boot_inst); return Nothing }
703             (dfun:_) -> return (Just (local_boot_dfun, dfun))
704         where
705           boot_dfun = instanceDFunId boot_inst
706           boot_inst_ty = idType boot_dfun
707           local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
708
709
710 -- This has to compare the TyThing from the .hi-boot file to the TyThing
711 -- in the current source file.  We must be careful to allow alpha-renaming
712 -- where appropriate, and also the boot declaration is allowed to omit
713 -- constructors and class methods.
714 --
715 -- See rnfail055 for a good test of this stuff.
716
717 checkBootDecl :: TyThing -> TyThing -> Bool
718
719 checkBootDecl (AnId id1) (AnId id2)
720   = ASSERT(id1 == id2) 
721     (idType id1 `eqType` idType id2)
722
723 checkBootDecl (ATyCon tc1) (ATyCon tc2)
724   = checkBootTyCon tc1 tc2
725
726 checkBootDecl (ADataCon dc1) (ADataCon _)
727   = pprPanic "checkBootDecl" (ppr dc1)
728
729 checkBootDecl _ _ = False -- probably shouldn't happen
730
731 ----------------
732 checkBootTyCon :: TyCon -> TyCon -> Bool
733 checkBootTyCon tc1 tc2
734   | not (eqKind (tyConKind tc1) (tyConKind tc2))
735   = False       -- First off, check the kind
736
737   | Just c1 <- tyConClass_maybe tc1
738   , Just c2 <- tyConClass_maybe tc2
739   = let 
740        (clas_tyvars1, clas_fds1, sc_theta1, _, ats1, op_stuff1) 
741           = classExtraBigSig c1
742        (clas_tyvars2, clas_fds2, sc_theta2, _, ats2, op_stuff2) 
743           = classExtraBigSig c2
744
745        env0 = mkRnEnv2 emptyInScopeSet
746        env = rnBndrs2 env0 clas_tyvars1 clas_tyvars2
747
748        eqSig (id1, def_meth1) (id2, def_meth2)
749          = idName id1 == idName id2 &&
750            eqTypeX env op_ty1 op_ty2 &&
751            def_meth1 == def_meth2
752          where
753           (_, rho_ty1) = splitForAllTys (idType id1)
754           op_ty1 = funResultTy rho_ty1
755           (_, rho_ty2) = splitForAllTys (idType id2)
756           op_ty2 = funResultTy rho_ty2
757
758        eqAT (tc1, def_ats1) (tc2, def_ats2)
759          = checkBootTyCon tc1 tc2 &&
760            eqListBy eqATDef def_ats1 def_ats2
761
762        -- Ignore the location of the defaults
763        eqATDef (ATD tvs1 ty_pats1 ty1 _loc1) (ATD tvs2 ty_pats2 ty2 _loc2)
764          = eqListBy same_kind tvs1 tvs2 &&
765            eqListBy (eqTypeX env) ty_pats1 ty_pats2 &&
766            eqTypeX env ty1 ty2
767          where env = rnBndrs2 env0 tvs1 tvs2
768
769        eqFD (as1,bs1) (as2,bs2) = 
770          eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
771          eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
772
773        same_kind tv1 tv2 = eqKind (tyVarKind tv1) (tyVarKind tv2)
774     in
775        eqListBy same_kind clas_tyvars1 clas_tyvars2 &&
776              -- Checks kind of class
777        eqListBy eqFD clas_fds1 clas_fds2 &&
778        (null sc_theta1 && null op_stuff1 && null ats1
779         ||   -- Above tests for an "abstract" class
780         eqListBy (eqPredX env) sc_theta1 sc_theta2 &&
781         eqListBy eqSig op_stuff1 op_stuff2 &&
782         eqListBy eqAT ats1 ats2) 
783
784   | isSynTyCon tc1 && isSynTyCon tc2
785   = ASSERT(tc1 == tc2)
786     let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2
787         env = rnBndrs2 env0 tvs1 tvs2
788
789         eqSynRhs SynFamilyTyCon SynFamilyTyCon
790             = True
791         eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
792             = eqTypeX env t1 t2
793         eqSynRhs _ _ = False
794     in
795     equalLength tvs1 tvs2 &&
796     eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2)
797
798   | isAlgTyCon tc1 && isAlgTyCon tc2
799   = ASSERT(tc1 == tc2)
800     eqKind (tyConKind tc1) (tyConKind tc2) &&
801     eqListBy eqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
802     eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
803
804   | isForeignTyCon tc1 && isForeignTyCon tc2
805   = eqKind (tyConKind tc1) (tyConKind tc2) &&
806     tyConExtName tc1 == tyConExtName tc2
807
808   | otherwise = False
809   where 
810         env0 = mkRnEnv2 emptyInScopeSet
811
812         eqAlgRhs (AbstractTyCon dis1) rhs2 
813           | dis1      = isDistinctAlgRhs rhs2   --Check compatibility
814           | otherwise = True
815         eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True
816         eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} =
817             eqListBy eqCon (data_cons tc1) (data_cons tc2)
818         eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} =
819             eqCon (data_con tc1) (data_con tc2)
820         eqAlgRhs _ _ = False
821
822         eqCon c1 c2
823           =  dataConName c1 == dataConName c2
824           && dataConIsInfix c1 == dataConIsInfix c2
825           && dataConStrictMarks c1 == dataConStrictMarks c2
826           && dataConFieldLabels c1 == dataConFieldLabels c2
827           && eqType (dataConUserType c1) (dataConUserType c2)
828
829 ----------------
830 missingBootThing :: Name -> String -> SDoc
831 missingBootThing name what
832   = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not") 
833               <+> text what <+> ptext (sLit "the module")
834
835 bootMisMatch :: TyThing -> IfaceDecl -> IfaceDecl -> SDoc
836 bootMisMatch thing boot_decl real_decl
837   = vcat [ppr thing <+> ptext (sLit "has conflicting definitions in the module and its hs-boot file"),
838           ptext (sLit "Main module:") <+> ppr real_decl,
839           ptext (sLit "Boot file:  ") <+> ppr boot_decl]
840
841 instMisMatch :: ClsInst -> SDoc
842 instMisMatch inst
843   = hang (ppr inst)
844        2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself"))
845 \end{code}
846
847
848 %************************************************************************
849 %*                                                                      *
850         Type-checking the top level of a module
851 %*                                                                      *
852 %************************************************************************
853
854 tcRnGroup takes a bunch of top-level source-code declarations, and
855  * renames them
856  * gets supporting declarations from interface files
857  * typechecks them
858  * zonks them
859  * and augments the TcGblEnv with the results
860
861 In Template Haskell it may be called repeatedly for each group of
862 declarations.  It expects there to be an incoming TcGblEnv in the
863 monad; it augments it and returns the new TcGblEnv.
864
865 \begin{code}
866 ------------------------------------------------
867 rnTopSrcDecls :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
868 -- Fails if there are any errors
869 rnTopSrcDecls extra_deps group
870  = do { -- Rename the source decls
871         traceTc "rn12" empty ;
872         (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls extra_deps group ;
873         traceTc "rn13" empty ;
874
875         -- save the renamed syntax, if we want it
876         let { tcg_env'
877                 | Just grp <- tcg_rn_decls tcg_env
878                   = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
879                 | otherwise
880                    = tcg_env };
881
882                 -- Dump trace of renaming part
883         rnDump (ppr rn_decls) ;
884
885         return (tcg_env', rn_decls)
886    }
887
888 ------------------------------------------------
889 tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
890 tcTopSrcDecls boot_details 
891         (HsGroup { hs_tyclds = tycl_decls, 
892                    hs_instds = inst_decls,
893                    hs_derivds = deriv_decls,
894                    hs_fords  = foreign_decls,
895                    hs_defds  = default_decls,
896                    hs_annds  = annotation_decls,
897                    hs_ruleds = rule_decls,
898                    hs_vects  = vect_decls,
899                    hs_valds  = val_binds })
900  = do {         -- Type-check the type and class decls, and all imported decls
901                 -- The latter come in via tycl_decls
902         traceTc "Tc2" empty ;
903
904         tcg_env <- tcTyAndClassDecls boot_details tycl_decls ;
905         setGblEnv tcg_env       $ do {
906
907                 -- Source-language instances, including derivings,
908                 -- and import the supporting declarations
909         traceTc "Tc3" empty ;
910         (tcg_env, inst_infos, deriv_binds) 
911             <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls;
912         setGblEnv tcg_env       $ do {
913
914                 -- Foreign import declarations next. 
915         traceTc "Tc4" empty ;
916         (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
917         tcExtendGlobalValEnv fi_ids     $ do {
918
919                 -- Default declarations
920         traceTc "Tc4a" empty ;
921         default_tys <- tcDefaults default_decls ;
922         updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
923         
924                 -- Now GHC-generated derived bindings, generics, and selectors
925                 -- Do not generate warnings from compiler-generated code;
926                 -- hence the use of discardWarnings
927         tc_envs <- discardWarnings (tcTopBinds deriv_binds) ;
928         setEnvs tc_envs $ do {
929
930                 -- Value declarations next
931         traceTc "Tc5" empty ;
932         tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds;
933         setEnvs tc_envs $ do {  -- Environment doesn't change now
934
935                 -- Second pass over class and instance declarations, 
936                 -- now using the kind-checked decls
937         traceTc "Tc6" empty ;
938         inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
939
940                 -- Foreign exports
941         traceTc "Tc7" empty ;
942         (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
943
944                 -- Annotations
945         annotations <- tcAnnotations annotation_decls ;
946
947                 -- Rules
948         rules <- tcRules rule_decls ;
949
950                 -- Vectorisation declarations
951         vects <- tcVectDecls vect_decls ;
952
953                 -- Wrap up
954         traceTc "Tc7a" empty ;
955         let { all_binds = inst_binds     `unionBags`
956                           foe_binds
957
958             ; sig_names = mkNameSet (collectHsValBinders val_binds) 
959                           `minusNameSet` getTypeSigNames val_binds
960
961                 -- Extend the GblEnv with the (as yet un-zonked) 
962                 -- bindings, rules, foreign decls
963             ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds
964                                  , tcg_sigs  = tcg_sigs tcg_env `unionNameSets` sig_names
965                                  , tcg_rules = tcg_rules tcg_env ++ rules
966                                  , tcg_vects = tcg_vects tcg_env ++ vects
967                                  , tcg_anns  = tcg_anns tcg_env ++ annotations
968                                  , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
969
970         return (tcg_env', tcl_env)
971     }}}}}}}
972 \end{code}
973
974
975 %************************************************************************
976 %*                                                                      *
977         Checking for 'main'
978 %*                                                                      *
979 %************************************************************************
980
981 \begin{code}
982 checkMain :: TcM TcGblEnv
983 -- If we are in module Main, check that 'main' is defined.
984 checkMain 
985   = do { tcg_env   <- getGblEnv ;
986          dflags    <- getDOpts ;
987          check_main dflags tcg_env
988     }
989
990 check_main :: DynFlags -> TcGblEnv -> TcM TcGblEnv
991 check_main dflags tcg_env
992  | mod /= main_mod
993  = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>
994    return tcg_env
995
996  | otherwise
997  = do   { mb_main <- lookupGlobalOccRn_maybe main_fn
998                 -- Check that 'main' is in scope
999                 -- It might be imported from another module!
1000         ; case mb_main of {
1001              Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn)
1002                            ; complain_no_main   
1003                            ; return tcg_env } ;
1004              Just main_name -> do
1005
1006         { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)
1007         ; let loc = srcLocSpan (getSrcLoc main_name)
1008         ; ioTyCon <- tcLookupTyCon ioTyConName
1009         ; res_ty <- newFlexiTyVarTy liftedTypeKind
1010         ; main_expr
1011                 <- addErrCtxt mainCtxt    $
1012                    tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty])
1013
1014                 -- See Note [Root-main Id]
1015                 -- Construct the binding
1016                 --      :Main.main :: IO res_ty = runMainIO res_ty main 
1017         ; run_main_id <- tcLookupId runMainIOName
1018         ; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN 
1019                                    (mkVarOccFS (fsLit "main")) 
1020                                    (getSrcSpan main_name)
1021               ; root_main_id = Id.mkExportedLocalId root_main_name 
1022                                                     (mkTyConApp ioTyCon [res_ty])
1023               ; co  = mkWpTyApps [res_ty]
1024               ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
1025               ; main_bind = mkVarBind root_main_id rhs }
1026
1027         ; return (tcg_env { tcg_main  = Just main_name,
1028                             tcg_binds = tcg_binds tcg_env
1029                                         `snocBag` main_bind,
1030                             tcg_dus   = tcg_dus tcg_env
1031                                         `plusDU` usesOnly (unitFV main_name)
1032                         -- Record the use of 'main', so that we don't 
1033                         -- complain about it being defined but not used
1034                  })
1035     }}}
1036   where
1037     mod          = tcg_mod tcg_env
1038     main_mod     = mainModIs dflags
1039     main_fn      = getMainFun dflags
1040
1041     complain_no_main | ghcLink dflags == LinkInMemory = return ()
1042                      | otherwise = failWithTc noMainMsg
1043         -- In interactive mode, don't worry about the absence of 'main'
1044         -- In other modes, fail altogether, so that we don't go on
1045         -- and complain a second time when processing the export list.
1046
1047     mainCtxt  = ptext (sLit "When checking the type of the") <+> pp_main_fn
1048     noMainMsg = ptext (sLit "The") <+> pp_main_fn
1049                 <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod)
1050     pp_main_fn = ppMainFn main_fn
1051
1052 ppMainFn :: RdrName -> SDoc
1053 ppMainFn main_fn
1054   | main_fn == main_RDR_Unqual
1055   = ptext (sLit "function") <+> quotes (ppr main_fn)
1056   | otherwise
1057   = ptext (sLit "main function") <+> quotes (ppr main_fn)
1058                
1059 -- | Get the unqualified name of the function to use as the \"main\" for the main module.
1060 -- Either returns the default name or the one configured on the command line with -main-is
1061 getMainFun :: DynFlags -> RdrName
1062 getMainFun dflags = case (mainFunIs dflags) of
1063     Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))
1064     Nothing -> main_RDR_Unqual
1065
1066 checkMainExported :: TcGblEnv -> TcM ()
1067 checkMainExported tcg_env = do
1068   dflags    <- getDOpts
1069   case tcg_main tcg_env of
1070     Nothing -> return () -- not the main module
1071     Just main_name -> do
1072       let main_mod = mainModIs dflags
1073       checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $
1074               ptext (sLit "The") <+> ppMainFn (nameRdrName main_name) <+>
1075               ptext (sLit "is not exported by module") <+> quotes (ppr main_mod)
1076 \end{code}
1077
1078 Note [Root-main Id]
1079 ~~~~~~~~~~~~~~~~~~~
1080 The function that the RTS invokes is always :Main.main, which we call
1081 root_main_id.  (Because GHC allows the user to have a module not
1082 called Main as the main module, we can't rely on the main function
1083 being called "Main.main".  That's why root_main_id has a fixed module
1084 ":Main".)  
1085
1086 This is unusual: it's a LocalId whose Name has a Module from another
1087 module.  Tiresomely, we must filter it out again in MkIface, les we
1088 get two defns for 'main' in the interface file!
1089
1090
1091 %*********************************************************
1092 %*                                                       *
1093                 GHCi stuff
1094 %*                                                       *
1095 %*********************************************************
1096
1097 \begin{code}
1098 setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
1099 setInteractiveContext hsc_env icxt thing_inside 
1100   = let -- Initialise the tcg_inst_env with instances from all home modules.  
1101         -- This mimics the more selective call to hptInstances in tcRnModule.
1102         (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True)
1103         (ic_insts, ic_finsts) = ic_instances icxt
1104
1105         -- Note [GHCi temporary Ids]
1106         -- Ideally we would just make a type_env from ic_tythings
1107         -- and ic_sys_vars, adding in implicit things.  However, Ids
1108         -- bound interactively might have some free type variables
1109         -- (RuntimeUnk things), and if we don't register these free
1110         -- TyVars as global TyVars then the typechecker will try to
1111         -- quantify over them and fall over in zonkQuantifiedTyVar.
1112         --
1113         -- So we must add any free TyVars to the typechecker's global
1114         -- TyVar set.  This is what happens when the local environment
1115         -- is extended, so we use tcExtendGhciEnv below which extends
1116         -- the local environment with the Ids.
1117         --
1118         -- However, any Ids bound this way will shadow other Ids in
1119         -- the GlobalRdrEnv, so we have to be careful to only add Ids
1120         -- which are visible in the GlobalRdrEnv.
1121         --
1122         -- Perhaps it would be better to just extend the global TyVar
1123         -- list from the free tyvars in the Ids here?  Anyway, at least
1124         -- this hack is localised.
1125         --
1126         -- Note [delete shadowed tcg_rdr_env entries]
1127         -- We also *delete* entries from tcg_rdr_env that we have
1128         -- shadowed in the local env (see above).  This isn't strictly
1129         -- necessary, but in an out-of-scope error when GHC suggests
1130         -- names it can be confusing to see multiple identical
1131         -- entries. (#5564)
1132         --
1133         (tmp_ids, types_n_classes) = partitionWith sel_id (ic_tythings icxt)
1134           where sel_id (AnId id) = Left id
1135                 sel_id other     = Right other
1136
1137         type_env = mkTypeEnvWithImplicits
1138                        (map AnId (ic_sys_vars icxt) ++ types_n_classes)
1139
1140         visible_tmp_ids = filter visible tmp_ids
1141           where visible id = not (null (lookupGRE_Name (ic_rn_gbl_env icxt)
1142                                                        (idName id)))
1143
1144         con_fields = [ (dataConName c, dataConFieldLabels c)
1145                      | ATyCon t <- types_n_classes
1146                      , c <- tyConDataCons t ]
1147     in
1148     updGblEnv (\env -> env {
1149           tcg_rdr_env      = delListFromOccEnv (ic_rn_gbl_env icxt)
1150                                                (map getOccName visible_tmp_ids)
1151                                  -- Note [delete shadowed tcg_rdr_env entries]
1152         , tcg_type_env     = type_env
1153         , tcg_inst_env     = extendInstEnvList
1154                               (extendInstEnvList (tcg_inst_env env) ic_insts)
1155                               home_insts
1156         , tcg_fam_inst_env = extendFamInstEnvList
1157                               (extendFamInstEnvList (tcg_fam_inst_env env)
1158                                                     ic_finsts)
1159                               home_fam_insts
1160         , tcg_field_env    = RecFields (mkNameEnv con_fields)
1161                                        (mkNameSet (concatMap snd con_fields))
1162              -- setting tcg_field_env is necessary to make RecordWildCards work
1163              -- (test: ghci049)
1164         }) $
1165
1166         tcExtendGhciEnv visible_tmp_ids $ -- Note [GHCi temporary Ids]
1167           thing_inside
1168 \end{code}
1169
1170
1171 \begin{code}
1172 #ifdef GHCI
1173 tcRnStmt :: HscEnv
1174          -> InteractiveContext
1175          -> LStmt RdrName
1176          -> IO (Messages, Maybe ([Id], LHsExpr Id))
1177                 -- The returned [Id] is the list of new Ids bound by
1178                 -- this statement.  It can be used to extend the
1179                 -- InteractiveContext via extendInteractiveContext.
1180                 --
1181                 -- The returned TypecheckedHsExpr is of type IO [ () ],
1182                 -- a list of the bound values, coerced to ().
1183
1184 tcRnStmt hsc_env ictxt rdr_stmt
1185   = initTcPrintErrors hsc_env iNTERACTIVE $ 
1186     setInteractiveContext hsc_env ictxt $ do {
1187
1188     -- Rename; use CmdLineMode because tcRnStmt is only used interactively
1189     (([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] $ \_ ->
1190                              return ((), emptyFVs) ;
1191     traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
1192     failIfErrsM ;
1193     rnDump (ppr rn_stmt) ;
1194     
1195     -- The real work is done here
1196     (bound_ids, tc_expr) <- mkPlan rn_stmt ;
1197     zonked_expr <- zonkTopLExpr tc_expr ;
1198     zonked_ids  <- zonkTopBndrs bound_ids ;
1199     
1200         -- None of the Ids should be of unboxed type, because we
1201         -- cast them all to HValues in the end!
1202     mapM_ bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
1203
1204     traceTc "tcs 1" empty ;
1205     let { global_ids = map globaliseAndTidyId zonked_ids } ;
1206         -- Note [Interactively-bound Ids in GHCi]
1207
1208 {- ---------------------------------------------
1209    At one stage I removed any shadowed bindings from the type_env;
1210    they are inaccessible but might, I suppose, cause a space leak if we leave them there.
1211    However, with Template Haskell they aren't necessarily inaccessible.  Consider this
1212    GHCi session
1213          Prelude> let f n = n * 2 :: Int
1214          Prelude> fName <- runQ [| f |]
1215          Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
1216          14
1217          Prelude> let f n = n * 3 :: Int
1218          Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
1219    In the last line we use 'fName', which resolves to the *first* 'f'
1220    in scope. If we delete it from the type env, GHCi crashes because
1221    it doesn't expect that.
1222  
1223    Hence this code is commented out
1224
1225 -------------------------------------------------- -}
1226
1227     dumpOptTcRn Opt_D_dump_tc 
1228         (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
1229                text "Typechecked expr" <+> ppr zonked_expr]) ;
1230
1231     return (global_ids, zonked_expr)
1232     }
1233   where
1234     bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"),
1235                                   nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
1236 \end{code}
1237
1238 Note [Interactively-bound Ids in GHCi]
1239 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1240 The Ids bound by previous Stmts in GHCi are currently
1241         a) GlobalIds
1242         b) with an Internal Name (not External)
1243         c) and a tidied type
1244
1245  (a) They must be GlobalIds (not LocalIds) otherwise when we come to
1246      compile an expression using these ids later, the byte code
1247      generator will consider the occurrences to be free rather than
1248      global.
1249
1250  (b) They retain their Internal names becuase we don't have a suitable
1251      Module to name them with.  We could revisit this choice.
1252
1253  (c) Their types are tidied.  This is important, because :info may ask
1254      to look at them, and :info expects the things it looks up to have
1255      tidy types
1256         
1257
1258 --------------------------------------------------------------------------
1259                 Typechecking Stmts in GHCi
1260
1261 Here is the grand plan, implemented in tcUserStmt
1262
1263         What you type                   The IO [HValue] that hscStmt returns
1264         -------------                   ------------------------------------
1265         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
1266                                         bindings: [x,y,...]
1267
1268         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
1269                                         bindings: [x,y,...]
1270
1271         expr (of IO type)       ==>     expr >>= \ it -> return [coerce HVal it]
1272           [NB: result not printed]      bindings: [it]
1273           
1274         expr (of non-IO type,   ==>     let it = expr in print it >> return [coerce HVal it]
1275           result showable)              bindings: [it]
1276
1277         expr (of non-IO type, 
1278           result not showable)  ==>     error
1279
1280
1281 \begin{code}
1282 ---------------------------
1283 type PlanResult = ([Id], LHsExpr Id)
1284 type Plan = TcM PlanResult
1285
1286 runPlans :: [Plan] -> TcM PlanResult
1287 -- Try the plans in order.  If one fails (by raising an exn), try the next.
1288 -- If one succeeds, take it.
1289 runPlans []     = panic "runPlans"
1290 runPlans [p]    = p
1291 runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
1292
1293 --------------------
1294 mkPlan :: LStmt Name -> TcM PlanResult
1295 mkPlan (L loc (ExprStmt expr _ _ _))    -- An expression typed at the prompt 
1296   = do  { uniq <- newUnique             -- is treated very specially
1297         ; let fresh_it  = itName uniq loc
1298               the_bind  = L loc $ mkTopFunBind (L loc fresh_it) matches
1299               matches   = [mkMatch [] expr emptyLocalBinds]
1300               let_stmt  = L loc $ LetStmt $ HsValBinds $
1301                           ValBindsOut [(NonRecursive,unitBag the_bind)] []
1302               bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it)) expr
1303                                            (HsVar bindIOName) noSyntaxExpr 
1304               print_it  = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
1305                                            (HsVar thenIOName) noSyntaxExpr placeHolderType
1306
1307         -- The plans are:
1308         --      [it <- e; print it]     but not if it::()
1309         --      [it <- e]               
1310         --      [let it = e; print it]  
1311         ; runPlans [    -- Plan A
1312                     do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
1313                        ; it_ty <- zonkTcType (idType it_id)
1314                        ; when (isUnitTy it_ty) failM
1315                        ; return stuff },
1316
1317                         -- Plan B; a naked bind statment
1318                     tcGhciStmts [bind_stmt],    
1319
1320                         -- Plan C; check that the let-binding is typeable all by itself.
1321                         -- If not, fail; if so, try to print it.
1322                         -- The two-step process avoids getting two errors: one from
1323                         -- the expression itself, and one from the 'print it' part
1324                         -- This two-step story is very clunky, alas
1325                     do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) 
1326                                 --- checkNoErrs defeats the error recovery of let-bindings
1327                        ; tcGhciStmts [let_stmt, print_it] }
1328           ]}
1329
1330 mkPlan stmt@(L loc (BindStmt {}))
1331   | [v] <- collectLStmtBinders stmt             -- One binder, for a bind stmt 
1332   = do  { let print_v  = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
1333                                           (HsVar thenIOName) noSyntaxExpr placeHolderType
1334
1335         ; print_bind_result <- doptM Opt_PrintBindResult
1336         ; let print_plan = do
1337                   { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
1338                   ; v_ty <- zonkTcType (idType v_id)
1339                   ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM
1340                   ; return stuff }
1341
1342         -- The plans are:
1343         --      [stmt; print v]         but not if v::()
1344         --      [stmt]
1345         ; runPlans ((if print_bind_result then [print_plan] else []) ++
1346                     [tcGhciStmts [stmt]])
1347         }
1348
1349 mkPlan stmt
1350   = tcGhciStmts [stmt]
1351
1352 ---------------------------
1353 tcGhciStmts :: [LStmt Name] -> TcM PlanResult
1354 tcGhciStmts stmts
1355  = do { ioTyCon <- tcLookupTyCon ioTyConName ;
1356         ret_id  <- tcLookupId returnIOName ;            -- return @ IO
1357         let {
1358             ret_ty    = mkListTy unitTy ;
1359             io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
1360             tc_io_stmts stmts = tcStmtsAndThen GhciStmt tcDoStmt stmts io_ret_ty ;
1361             names = collectLStmtsBinders stmts ;
1362          } ;
1363
1364         -- OK, we're ready to typecheck the stmts
1365         traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
1366         ((tc_stmts, ids), lie) <- captureConstraints $ 
1367                                   tc_io_stmts stmts  $ \ _ ->
1368                                   mapM tcLookupId names  ;
1369                         -- Look up the names right in the middle,
1370                         -- where they will all be in scope
1371
1372         -- Simplify the context
1373         traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
1374         const_binds <- checkNoErrs (simplifyInteractive lie) ;
1375                 -- checkNoErrs ensures that the plan fails if context redn fails
1376
1377         traceTc "TcRnDriver.tcGhciStmts: done" empty ;
1378         let {   -- mk_return builds the expression
1379                 --      returnIO @ [()] [coerce () x, ..,  coerce () z]
1380                 --
1381                 -- Despite the inconvenience of building the type applications etc,
1382                 -- this *has* to be done in type-annotated post-typecheck form
1383                 -- because we are going to return a list of *polymorphic* values
1384                 -- coerced to type (). If we built a *source* stmt
1385                 --      return [coerce x, ..., coerce z]
1386                 -- then the type checker would instantiate x..z, and we wouldn't
1387                 -- get their *polymorphic* values.  (And we'd get ambiguity errs
1388                 -- if they were overloaded, since they aren't applied to anything.)
1389             ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) 
1390                        (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
1391             mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
1392                                  (nlHsVar id) ;
1393             stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
1394         } ;
1395         return (ids, mkHsDictLet (EvBinds const_binds) $
1396                      noLoc (HsDo GhciStmt stmts io_ret_ty))
1397     }
1398 \end{code}
1399
1400
1401 tcRnExpr just finds the type of an expression
1402
1403 \begin{code}
1404 tcRnExpr :: HscEnv
1405          -> InteractiveContext
1406          -> LHsExpr RdrName
1407          -> IO (Messages, Maybe Type)
1408 tcRnExpr hsc_env ictxt rdr_expr
1409   = initTcPrintErrors hsc_env iNTERACTIVE $
1410     setInteractiveContext hsc_env ictxt $ do {
1411
1412     (rn_expr, _fvs) <- rnLExpr rdr_expr ;
1413     failIfErrsM ;
1414
1415         -- Now typecheck the expression; 
1416         -- it might have a rank-2 type (e.g. :t runST)
1417     uniq <- newUnique ;
1418     let { fresh_it  = itName uniq (getLoc rdr_expr) } ;
1419     ((_tc_expr, res_ty), lie)   <- captureConstraints (tcInferRho rn_expr) ;
1420     ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ 
1421                                       {-# SCC "simplifyInfer" #-}
1422                                       simplifyInfer True {- Free vars are closed -}
1423                                                     False {- No MR for now -}
1424                                                     [(fresh_it, res_ty)]
1425                                                     lie  ;
1426     _ <- simplifyInteractive lie_top ;       -- Ignore the dicionary bindings
1427
1428     let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
1429     zonkTcType all_expr_ty
1430     }
1431
1432 --------------------------
1433 tcRnImportDecls :: HscEnv
1434                 -> [LImportDecl RdrName]
1435                 -> IO (Messages, Maybe GlobalRdrEnv)
1436 tcRnImportDecls hsc_env import_decls
1437  =  initTcPrintErrors hsc_env iNTERACTIVE $ 
1438     do { gbl_env <- tcRnImports hsc_env iNTERACTIVE import_decls
1439        ; return (tcg_rdr_env gbl_env) }
1440 \end{code}
1441
1442 tcRnType just finds the kind of a type
1443
1444 \begin{code}
1445 tcRnType :: HscEnv
1446          -> InteractiveContext
1447          -> Bool        -- Normalise the returned type
1448          -> LHsType RdrName
1449          -> IO (Messages, Maybe (Type, Kind))
1450 tcRnType hsc_env ictxt normalise rdr_type
1451   = initTcPrintErrors hsc_env iNTERACTIVE $ 
1452     setInteractiveContext hsc_env ictxt $ do {
1453
1454     rn_type <- rnLHsType GHCiCtx rdr_type ;
1455     failIfErrsM ;
1456
1457         -- Now kind-check the type
1458         -- It can have any rank or kind
1459     ty <- tcHsSigType GhciCtxt rn_type ;
1460
1461     ty' <- if normalise 
1462            then do { fam_envs <- tcGetFamInstEnvs 
1463                    ; return (snd (normaliseType fam_envs ty)) }
1464                    -- normaliseType returns a coercion
1465                    -- which we discard
1466            else return ty ;
1467             
1468     return (ty', typeKind ty)
1469     }
1470
1471 \end{code}
1472
1473 tcRnDeclsi exists to allow class, data, and other declarations in GHCi.
1474
1475 \begin{code}
1476 tcRnDeclsi :: HscEnv 
1477            -> InteractiveContext
1478            -> [LHsDecl RdrName]
1479            -> IO (Messages, Maybe TcGblEnv)
1480
1481 tcRnDeclsi hsc_env ictxt local_decls =
1482     initTcPrintErrors hsc_env iNTERACTIVE $
1483     setInteractiveContext hsc_env ictxt $ do
1484     
1485     ((tcg_env, tclcl_env), lie) <- 
1486         captureConstraints $ tc_rn_src_decls emptyModDetails local_decls
1487     setEnvs (tcg_env, tclcl_env) $ do
1488
1489     new_ev_binds <- simplifyTop lie
1490     failIfErrsM
1491     let TcGblEnv { tcg_type_env  = type_env,
1492                    tcg_binds     = binds,
1493                    tcg_sigs      = sig_ns,
1494                    tcg_ev_binds  = cur_ev_binds,
1495                    tcg_imp_specs = imp_specs,
1496                    tcg_rules     = rules,
1497                    tcg_vects     = vects,
1498                    tcg_fords     = fords } = tcg_env
1499         all_ev_binds = cur_ev_binds `unionBags` new_ev_binds
1500
1501     (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') 
1502         <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords
1503     
1504     let --global_ids = map globaliseAndTidyId bind_ids
1505         final_type_env = extendTypeEnvWithIds type_env bind_ids --global_ids
1506         tcg_env' = tcg_env { tcg_binds     = binds',
1507                              tcg_ev_binds  = ev_binds',
1508                              tcg_imp_specs = imp_specs',
1509                              tcg_rules     = rules', 
1510                              tcg_vects     = vects', 
1511                              tcg_fords     = fords' }
1512
1513     tcg_env'' <- setGlobalTypeEnv tcg_env' final_type_env
1514
1515     return tcg_env''
1516
1517
1518 #endif /* GHCi */
1519 \end{code}
1520
1521
1522 %************************************************************************
1523 %*                                                                      *
1524         More GHCi stuff, to do with browsing and getting info
1525 %*                                                                      *
1526 %************************************************************************
1527
1528 \begin{code}
1529 #ifdef GHCI
1530 -- | ASSUMES that the module is either in the 'HomePackageTable' or is
1531 -- a package module with an interface on disk.  If neither of these is
1532 -- true, then the result will be an error indicating the interface
1533 -- could not be found.
1534 getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface)
1535 getModuleInterface hsc_env mod
1536   = initTc hsc_env HsSrcFile False iNTERACTIVE $
1537     loadModuleInterface (ptext (sLit "getModuleInterface")) mod
1538
1539 tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name])
1540 tcRnLookupRdrName hsc_env rdr_name
1541   = initTcPrintErrors hsc_env iNTERACTIVE $
1542     setInteractiveContext hsc_env (hsc_IC hsc_env) $ 
1543     lookup_rdr_name rdr_name
1544
1545 lookup_rdr_name :: RdrName -> TcM [Name]
1546 lookup_rdr_name rdr_name = do
1547         -- If the identifier is a constructor (begins with an
1548         -- upper-case letter), then we need to consider both
1549         -- constructor and type class identifiers.
1550     let rdr_names = dataTcOccs rdr_name
1551
1552         -- results :: [Either Messages Name]
1553     results <- mapM (tryTcErrs . lookupOccRn) rdr_names
1554
1555     traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)])
1556         -- The successful lookups will be (Just name)
1557     let (warns_s, good_names) = unzip [ (msgs, name) 
1558                                       | (msgs, Just name) <- results]
1559         errs_s = [msgs | (msgs, Nothing) <- results]
1560
1561         -- Fail if nothing good happened, else add warnings
1562     if null good_names
1563       then  addMessages (head errs_s) >> failM
1564                 -- No lookup succeeded, so
1565                 -- pick the first error message and report it
1566                 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
1567                 --       while the other is "X is not in scope", 
1568                 --       we definitely want the former; but we might pick the latter
1569       else      mapM_ addMessages warns_s
1570                 -- Add deprecation warnings
1571     return good_names
1572
1573 #endif
1574
1575 tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
1576 tcRnLookupName hsc_env name
1577   = initTcPrintErrors hsc_env iNTERACTIVE $
1578     setInteractiveContext hsc_env (hsc_IC hsc_env) $
1579     tcRnLookupName' name
1580
1581 -- To look up a name we have to look in the local environment (tcl_lcl)
1582 -- as well as the global environment, which is what tcLookup does. 
1583 -- But we also want a TyThing, so we have to convert:
1584
1585 tcRnLookupName' :: Name -> TcRn TyThing
1586 tcRnLookupName' name = do
1587    tcthing <- tcLookup name
1588    case tcthing of
1589      AGlobal thing    -> return thing
1590      ATcId{tct_id=id} -> return (AnId id)
1591      _ -> panic "tcRnLookupName'"
1592
1593 tcRnGetInfo :: HscEnv
1594             -> Name
1595             -> IO (Messages, Maybe (TyThing, Fixity, [ClsInst]))
1596
1597 -- Used to implement :info in GHCi
1598 --
1599 -- Look up a RdrName and return all the TyThings it might be
1600 -- A capitalised RdrName is given to us in the DataName namespace,
1601 -- but we want to treat it as *both* a data constructor 
1602 --  *and* as a type or class constructor; 
1603 -- hence the call to dataTcOccs, and we return up to two results
1604 tcRnGetInfo hsc_env name
1605   = initTcPrintErrors hsc_env iNTERACTIVE $
1606     tcRnGetInfo' hsc_env name
1607
1608 tcRnGetInfo' :: HscEnv
1609              -> Name
1610              -> TcRn (TyThing, Fixity, [ClsInst])
1611 tcRnGetInfo' hsc_env name
1612   = let ictxt = hsc_IC hsc_env in
1613     setInteractiveContext hsc_env ictxt $ do
1614
1615         -- Load the interface for all unqualified types and classes
1616         -- That way we will find all the instance declarations
1617         -- (Packages have not orphan modules, and we assume that
1618         --  in the home package all relevant modules are loaded.)
1619     loadUnqualIfaces hsc_env ictxt
1620
1621     thing  <- tcRnLookupName' name
1622     fixity <- lookupFixityRn name
1623     ispecs <- lookupInsts thing
1624     return (thing, fixity, ispecs)
1625
1626 lookupInsts :: TyThing -> TcM [ClsInst]
1627 lookupInsts (ATyCon tc)
1628   | Just cls <- tyConClass_maybe tc
1629   = do  { inst_envs <- tcGetInstEnvs
1630         ; return (classInstances inst_envs cls) }
1631
1632   | otherwise
1633   = do  { (pkg_ie, home_ie) <- tcGetInstEnvs
1634                 -- Load all instances for all classes that are
1635                 -- in the type environment (which are all the ones
1636                 -- we've seen in any interface file so far)
1637         ; return [ ispec        -- Search all
1638                  | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
1639                  , let dfun = instanceDFunId ispec
1640                  , relevant dfun ] } 
1641   where
1642     relevant df = tc_name `elemNameSet` orphNamesOfDFunHead (idType df)
1643     tc_name     = tyConName tc            
1644
1645 lookupInsts _ = return []
1646
1647 loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM ()
1648 -- Load the interface for everything that is in scope unqualified
1649 -- This is so that we can accurately report the instances for 
1650 -- something
1651 loadUnqualIfaces hsc_env ictxt
1652   = initIfaceTcRn $ do
1653     mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
1654   where
1655     this_pkg = thisPackage (hsc_dflags hsc_env)
1656
1657     unqual_mods = filter ((/= this_pkg) . modulePackageId)
1658                   [ nameModule name
1659                   | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt),
1660                     let name = gre_name gre,
1661                     not (isInternalName name),
1662                     isTcOcc (nameOccName name),  -- Types and classes only
1663                     unQualOK gre ]               -- In scope unqualified
1664     doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified")
1665 \end{code}
1666
1667 %************************************************************************
1668 %*                                                                      *
1669                 Degugging output
1670 %*                                                                      *
1671 %************************************************************************
1672
1673 \begin{code}
1674 rnDump :: SDoc -> TcRn ()
1675 -- Dump, with a banner, if -ddump-rn
1676 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1677
1678 tcDump :: TcGblEnv -> TcRn ()
1679 tcDump env
1680  = do { dflags <- getDOpts ;
1681
1682         -- Dump short output if -ddump-types or -ddump-tc
1683         when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1684              (dumpTcRn short_dump) ;
1685
1686         -- Dump bindings if -ddump-tc
1687         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1688    }
1689   where
1690     short_dump = pprTcGblEnv env
1691     full_dump  = pprLHsBinds (tcg_binds env)
1692         -- NB: foreign x-d's have undefined's in their types; 
1693         --     hence can't show the tc_fords
1694
1695 tcCoreDump :: ModGuts -> TcM ()
1696 tcCoreDump mod_guts
1697  = do { dflags <- getDOpts ;
1698         when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1699              (dumpTcRn (pprModGuts mod_guts)) ;
1700
1701         -- Dump bindings if -ddump-tc
1702         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1703   where
1704     full_dump = pprCoreBindings (mg_binds mod_guts)
1705
1706 -- It's unpleasant having both pprModGuts and pprModDetails here
1707 pprTcGblEnv :: TcGblEnv -> SDoc
1708 pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env, 
1709                         tcg_insts     = insts, 
1710                         tcg_fam_insts = fam_insts, 
1711                         tcg_rules     = rules,
1712                         tcg_vects     = vects,
1713                         tcg_imports   = imports })
1714   = vcat [ ppr_types insts type_env
1715          , ppr_tycons fam_insts type_env
1716          , ppr_insts insts
1717          , ppr_fam_insts fam_insts
1718          , vcat (map ppr rules)
1719          , vcat (map ppr vects)
1720          , ptext (sLit "Dependent modules:") <+> 
1721                 ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
1722          , ptext (sLit "Dependent packages:") <+> 
1723                 ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)]
1724   where         -- The two uses of sortBy are just to reduce unnecessary
1725                 -- wobbling in testsuite output
1726     cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2)
1727         = (mod_name1 `stableModuleNameCmp` mod_name2)
1728                   `thenCmp`     
1729           (is_boot1 `compare` is_boot2)
1730
1731 pprModGuts :: ModGuts -> SDoc
1732 pprModGuts (ModGuts { mg_tcs = tcs
1733                     , mg_rules = rules })
1734   = vcat [ ppr_types [] (mkTypeEnv (map ATyCon tcs)),
1735            ppr_rules rules ]
1736
1737 ppr_types :: [ClsInst] -> TypeEnv -> SDoc
1738 ppr_types insts type_env
1739   = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1740   where
1741     dfun_ids = map instanceDFunId insts
1742     ids = [id | id <- typeEnvIds type_env, want_sig id]
1743     want_sig id | opt_PprStyle_Debug = True
1744                 | otherwise          = isLocalId id && 
1745                                        isExternalName (idName id) && 
1746                                        not (id `elem` dfun_ids)
1747         -- isLocalId ignores data constructors, records selectors etc.
1748         -- The isExternalName ignores local dictionary and method bindings
1749         -- that the type checker has invented.  Top-level user-defined things 
1750         -- have External names.
1751
1752 ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
1753 ppr_tycons fam_insts type_env
1754   = vcat [ text "TYPE CONSTRUCTORS"
1755          ,   nest 2 (ppr_tydecls tycons)
1756          , text "COERCION AXIOMS" 
1757          ,   nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ]
1758   where
1759     fi_tycons = famInstsRepTyCons fam_insts
1760     tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
1761     want_tycon tycon | opt_PprStyle_Debug = True
1762                      | otherwise          = not (isImplicitTyCon tycon) &&
1763                                             isExternalName (tyConName tycon) &&
1764                                             not (tycon `elem` fi_tycons)
1765
1766 ppr_insts :: [ClsInst] -> SDoc
1767 ppr_insts []     = empty
1768 ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
1769
1770 ppr_fam_insts :: [FamInst] -> SDoc
1771 ppr_fam_insts []        = empty
1772 ppr_fam_insts fam_insts = 
1773   text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts)
1774
1775 ppr_sigs :: [Var] -> SDoc
1776 ppr_sigs ids
1777         -- Print type signatures; sort by OccName 
1778   = vcat (map ppr_sig (sortLe le_sig ids))
1779   where
1780     le_sig id1 id2 = getOccName id1 <= getOccName id2
1781     ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
1782
1783 ppr_tydecls :: [TyCon] -> SDoc
1784 ppr_tydecls tycons
1785         -- Print type constructor info; sort by OccName 
1786   = vcat (map ppr_tycon (sortLe le_sig tycons))
1787   where
1788     le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
1789     ppr_tycon tycon = ppr (tyThingToIfaceDecl (ATyCon tycon))
1790
1791 ppr_rules :: [CoreRule] -> SDoc
1792 ppr_rules [] = empty
1793 ppr_rules rs = vcat [ptext (sLit "{-# RULES"),
1794                       nest 2 (pprRules rs),
1795                       ptext (sLit "#-}")]
1796 \end{code}