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