Merge branch 'master' of darcs.haskell.org:/srv/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 TypeRep
29 import DynFlags
30 import StaticFlags
31 import HsSyn
32 import PrelNames
33 import RdrName
34 import TcHsSyn
35 import TcExpr
36 import TcRnMonad
37 import TcEvidence
38 import Coercion( pprCoAxiom )
39 import FamInst
40 import InstEnv
41 import FamInstEnv
42 import TcAnnotations
43 import TcBinds
44 import HeaderInfo       ( mkPrelImports )
45 import TcType   ( tidyTopType )
46 import TcDefaults
47 import TcEnv
48 import TcRules
49 import TcForeign
50 import TcInstDcls
51 import TcIface
52 import TcMType
53 import MkIface
54 import IfaceSyn
55 import TcSimplify
56 import TcTyClsDecls
57 import LoadIface
58 import RnNames
59 import RnEnv
60 import RnSource
61 import PprCore
62 import CoreSyn
63 import ErrUtils
64 import Id
65 import VarEnv
66 import Module
67 import UniqFM
68 import Name
69 import NameEnv
70 import NameSet
71 import Avail
72 import TyCon
73 import SrcLoc
74 import HscTypes
75 import ListSetOps
76 import Outputable
77 import DataCon
78 import Type
79 import Class
80 import TcType   ( orphNamesOfDFunHead )
81 import Inst     ( tcGetInstEnvs )
82 import Data.List ( sortBy )
83 import Data.IORef ( readIORef )
84 import Data.Ord
85
86 #ifdef GHCI
87 import TcType   ( isUnitTy, isTauTy )
88 import TcHsType
89 import TcMatches
90 import RnTypes
91 import RnExpr
92 import MkId
93 import BasicTypes
94 import TidyPgm    ( globaliseAndTidyId )
95 import TysWiredIn ( unitTy, mkListTy )
96 #endif
97
98 import FastString
99 import Maybes
100 import Util
101 import Bag
102
103 import Control.Monad
104
105 #include "HsVersions.h"
106 \end{code}
107
108 %************************************************************************
109 %*                                                                      *
110         Typecheck and rename a module
111 %*                                                                      *
112 %************************************************************************
113
114
115 \begin{code}
116 -- | Top level entry point for typechecker and renamer
117 tcRnModule :: HscEnv
118            -> HscSource
119            -> Bool              -- True <=> save renamed syntax
120            -> HsParsedModule
121            -> IO (Messages, Maybe TcGblEnv)
122
123 tcRnModule hsc_env hsc_src save_rn_syntax
124    HsParsedModule {
125       hpm_module =
126          (L loc (HsModule maybe_mod export_ies
127                           import_decls local_decls mod_deprec
128                           maybe_doc_hdr)),
129       hpm_src_files =
130          src_files
131    }
132  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
133
134    let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
135          (this_mod, prel_imp_loc)
136             = case maybe_mod of
137                 Nothing -- 'module M where' is omitted
138                     ->  (mAIN, srcLocSpan (srcSpanStart loc))
139
140                 Just (L mod_loc mod)  -- The normal case
141                     -> (mkModule this_pkg mod, mod_loc) } ;
142
143    initTc hsc_env hsc_src save_rn_syntax this_mod $
144    setSrcSpan loc $
145    do {         -- Deal with imports; first add implicit prelude
146         implicit_prelude <- xoptM Opt_ImplicitPrelude;
147         let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc
148                                          implicit_prelude import_decls } ;
149
150         whenWOptM Opt_WarnImplicitPrelude $
151              when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ;
152
153         tcg_env <- {-# SCC "tcRnImports" #-}
154                    tcRnImports hsc_env this_mod (prel_imports ++ import_decls) ;
155
156           -- If the whole module is warned about or deprecated 
157           -- (via mod_deprec) record that in tcg_warns. If we do thereby add
158           -- a WarnAll, it will override any subseqent depracations added to tcg_warns
159         let { tcg_env1 = case mod_deprec of 
160                          Just txt -> tcg_env { tcg_warns = WarnAll txt } 
161                          Nothing  -> tcg_env 
162             } ;
163  
164         setGblEnv tcg_env1 $ do {
165
166                 -- Load the hi-boot interface for this module, if any
167                 -- We do this now so that the boot_names can be passed
168                 -- to tcTyAndClassDecls, because the boot_names are
169                 -- automatically considered to be loop breakers
170                 --
171                 -- Do this *after* tcRnImports, so that we know whether
172                 -- a module that we import imports us; and hence whether to
173                 -- look for a hi-boot file
174         boot_iface <- tcHiBootIface hsc_src this_mod ;
175
176                 -- Rename and type check the declarations
177         traceRn (text "rn1a") ;
178         tcg_env <- if isHsBoot hsc_src then
179                         tcRnHsBootDecls local_decls
180                    else
181                         {-# SCC "tcRnSrcDecls" #-}
182                         tcRnSrcDecls boot_iface local_decls ;
183         setGblEnv tcg_env               $ do {
184
185                 -- Process the export list
186         traceRn (text "rn4a: before exports");
187         tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ;
188         traceRn (text "rn4b: after exports") ;
189
190                 -- Check that main is exported (must be after rnExports)
191         checkMainExported tcg_env ;
192
193         -- Compare the hi-boot iface (if any) with the real thing
194         -- Must be done after processing the exports
195         tcg_env <- checkHiBootIface tcg_env boot_iface ;
196
197         -- The new type env is already available to stuff slurped from
198         -- interface files, via TcEnv.updateGlobalTypeEnv
199         -- It's important that this includes the stuff in checkHiBootIface,
200         -- because the latter might add new bindings for boot_dfuns,
201         -- which may be mentioned in imported unfoldings
202
203                 -- Don't need to rename the Haddock documentation,
204                 -- it's not parsed by GHC anymore.
205         tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ;
206
207                 -- Report unused names
208         reportUnusedNames export_ies tcg_env ;
209
210                 -- add extra source files to tcg_dependent_files
211         addDependentFiles src_files ;
212
213                 -- Dump output and return
214         tcDump tcg_env ;
215         return tcg_env
216     }}}}
217
218
219 implicitPreludeWarn :: SDoc
220 implicitPreludeWarn
221   = ptext (sLit "Module `Prelude' implicitly imported")
222 \end{code}
223
224
225 %************************************************************************
226 %*                                                                      *
227                 Import declarations
228 %*                                                                      *
229 %************************************************************************
230
231 \begin{code}
232 tcRnImports :: HscEnv -> Module
233             -> [LImportDecl RdrName] -> TcM TcGblEnv
234 tcRnImports hsc_env this_mod import_decls
235   = do  { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ;
236
237         ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
238                 -- Make sure we record the dependencies from the DynFlags in the EPS or we
239                 -- end up hitting the sanity check in LoadIface.loadInterface that
240                 -- checks for unknown home-package modules being loaded. We put
241                 -- these dependencies on the left so their (non-source) imports
242                 -- take precedence over the (possibly-source) imports on the right.
243                 -- We don't add them to any other field (e.g. the imp_dep_mods of
244                 -- imports) because we don't want to load their instances etc.
245               ; dep_mods = listToUFM [(mod_nm, (mod_nm, False)) | mod_nm <- dynFlagDependencies (hsc_dflags hsc_env)]
246                                 `plusUFM` imp_dep_mods imports
247
248                 -- We want instance declarations from all home-package
249                 -- modules below this one, including boot modules, except
250                 -- ourselves.  The 'except ourselves' is so that we don't
251                 -- get the instances from this module's hs-boot file
252               ; want_instances :: ModuleName -> Bool
253               ; want_instances mod = mod `elemUFM` dep_mods
254                                    && mod /= moduleName this_mod
255               ; (home_insts, home_fam_insts) = hptInstances hsc_env
256                                                             want_instances
257               } ;
258
259                 -- Record boot-file info in the EPS, so that it's
260                 -- visible to loadHiBootInterface in tcRnSrcDecls,
261                 -- and any other incrementally-performed imports
262         ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
263
264                 -- Update the gbl env
265         ; updGblEnv ( \ gbl ->
266             gbl {
267               tcg_rdr_env      = plusOccEnv (tcg_rdr_env gbl) rdr_env,
268               tcg_imports      = tcg_imports gbl `plusImportAvails` imports,
269               tcg_rn_imports   = rn_imports,
270               tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,
271               tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl)
272                                                       home_fam_insts,
273               tcg_hpc          = hpc_info
274             }) $ do {
275
276         ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports))
277                 -- Fail if there are any errors so far
278                 -- The error printing (if needed) takes advantage
279                 -- of the tcg_env we have now set
280 --      ; traceIf (text "rdr_env: " <+> ppr rdr_env)
281         ; failIfErrsM
282
283                 -- Load any orphan-module and family instance-module
284                 -- interfaces, so that their rules and instance decls will be
285                 -- found.
286         ; loadModuleInterfaces (ptext (sLit "Loading orphan modules"))
287                                (imp_orphs imports)
288
289                 -- Check type-family consistency
290         ; traceRn (text "rn1: checking family instance consistency")
291         ; let { dir_imp_mods = moduleEnvKeys
292                              . imp_mods
293                              $ imports }
294         ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;
295
296         ; getGblEnv } }
297 \end{code}
298
299
300 %************************************************************************
301 %*                                                                      *
302         Type-checking external-core modules
303 %*                                                                      *
304 %************************************************************************
305
306 \begin{code}
307 tcRnExtCore :: HscEnv
308             -> HsExtCore RdrName
309             -> IO (Messages, Maybe ModGuts)
310         -- Nothing => some error occurred
311
312 tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
313         -- The decls are IfaceDecls; all names are original names
314  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
315
316    initTc hsc_env ExtCoreFile False this_mod $ do {
317
318    let { ldecls  = map noLoc decls } ;
319
320        -- Bring the type and class decls into scope
321        -- ToDo: check that this doesn't need to extract the val binds.
322        --       It seems that only the type and class decls need to be in scope below because
323        --          (a) tcTyAndClassDecls doesn't need the val binds, and
324        --          (b) tcExtCoreBindings doesn't need anything
325        --              (in fact, it might not even need to be in the scope of
326        --               this tcg_env at all)
327    (tc_envs, _bndrs) <- getLocalNonValBinders emptyFsEnv {- no fixity decls -}
328                                               (mkFakeGroup ldecls) ;
329    setEnvs tc_envs $ do {
330
331    (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [] [ldecls] ;
332    -- The empty list is for extra dependencies coming from .hs-boot files
333    -- See Note [Extra dependencies from .hs-boot files] in RnSource
334
335         -- Dump trace of renaming part
336    rnDump (ppr rn_decls) ;
337
338         -- Typecheck them all together so that
339         -- any mutually recursive types are done right
340         -- Just discard the auxiliary bindings; they are generated
341         -- only for Haskell source code, and should already be in Core
342    tcg_env   <- tcTyAndClassDecls emptyModDetails rn_decls ;
343    safe_mode <- liftIO $ finalSafeMode (hsc_dflags hsc_env) tcg_env ;
344    dep_files <- liftIO $ readIORef (tcg_dependent_files tcg_env) ;
345
346    setGblEnv tcg_env $ do {
347         -- Make the new type env available to stuff slurped from interface files
348
349         -- Now the core bindings
350    core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
351
352
353         -- Wrap up
354    let {
355         bndrs      = bindersOfBinds core_binds ;
356         my_exports = map (Avail . idName) bndrs ;
357                 -- ToDo: export the data types also?
358
359         mod_guts = ModGuts {    mg_module    = this_mod,
360                                 mg_boot      = False,
361                                 mg_used_names = emptyNameSet, -- ToDo: compute usage
362                                 mg_used_th   = False,
363                                 mg_dir_imps  = emptyModuleEnv, -- ??
364                                 mg_deps      = noDependencies,  -- ??
365                                 mg_exports   = my_exports,
366                                 mg_tcs       = tcg_tcs tcg_env,
367                                 mg_insts     = tcg_insts tcg_env,
368                                 mg_fam_insts = tcg_fam_insts tcg_env,
369                                 mg_inst_env  = tcg_inst_env tcg_env,
370                                 mg_fam_inst_env = tcg_fam_inst_env tcg_env,
371                                 mg_rules        = [],
372                                 mg_vect_decls   = [],
373                                 mg_anns         = [],
374                                 mg_binds        = core_binds,
375
376                                 -- Stubs
377                                 mg_rdr_env      = emptyGlobalRdrEnv,
378                                 mg_fix_env      = emptyFixityEnv,
379                                 mg_warns        = NoWarnings,
380                                 mg_foreign      = NoStubs,
381                                 mg_hpc_info     = emptyHpcInfo False,
382                                 mg_modBreaks    = emptyModBreaks,
383                                 mg_vect_info    = noVectInfo,
384                                 mg_safe_haskell = safe_mode,
385                                 mg_trust_pkg    = False,
386                                 mg_dependent_files = dep_files
387                             } } ;
388
389    tcCoreDump mod_guts ;
390
391    return mod_guts
392    }}}}
393
394 mkFakeGroup :: [LTyClDecl a] -> HsGroup a
395 mkFakeGroup decls -- Rather clumsy; lots of unused fields
396   = emptyRdrGroup { hs_tyclds = [decls] }
397 \end{code}
398
399
400 %************************************************************************
401 %*                                                                      *
402         Type-checking the top level of a module
403 %*                                                                      *
404 %************************************************************************
405
406 \begin{code}
407 tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv
408         -- Returns the variables free in the decls
409         -- Reason: solely to report unused imports and bindings
410 tcRnSrcDecls boot_iface decls
411  = do {         -- Do all the declarations
412         ((tcg_env, tcl_env), lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ;
413       ; traceTc "Tc8" empty ;
414       ; setEnvs (tcg_env, tcl_env) $
415    do {
416
417              --         Finish simplifying class constraints
418              --
419              -- simplifyTop deals with constant or ambiguous InstIds.
420              -- How could there be ambiguous ones?  They can only arise if a
421              -- top-level decl falls under the monomorphism restriction
422              -- and no subsequent decl instantiates its type.
423              --
424              -- We do this after checkMain, so that we use the type info
425              -- that checkMain adds
426              --
427              -- We do it with both global and local env in scope:
428              --  * the global env exposes the instances to simplifyTop
429              --  * the local env exposes the local Ids to simplifyTop,
430              --    so that we get better error messages (monomorphism restriction)
431         new_ev_binds <- {-# SCC "simplifyTop" #-}
432                         simplifyTop lie ;
433         traceTc "Tc9" empty ;
434
435         failIfErrsM ;   -- Don't zonk if there have been errors
436                         -- It's a waste of time; and we may get debug warnings
437                         -- about strangely-typed TyCons!
438
439         -- Zonk the final code.  This must be done last.
440         -- Even simplifyTop may do some unification.
441         -- This pass also warns about missing type signatures
442         let { TcGblEnv { tcg_type_env  = type_env,
443                          tcg_binds     = binds,
444                          tcg_sigs      = sig_ns,
445                          tcg_ev_binds  = cur_ev_binds,
446                          tcg_imp_specs = imp_specs,
447                          tcg_rules     = rules,
448                          tcg_vects     = vects,
449                          tcg_fords     = fords } = tcg_env
450             ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
451
452         (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
453             <- {-# SCC "zonkTopDecls" #-}
454                zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords ;
455
456         let { final_type_env = extendTypeEnvWithIds type_env bind_ids
457             ; tcg_env' = tcg_env { tcg_binds    = binds',
458                                    tcg_ev_binds = ev_binds',
459                                    tcg_imp_specs = imp_specs',
460                                    tcg_rules    = rules',
461                                    tcg_vects    = vects',
462                                    tcg_fords    = fords' } } ;
463
464         setGlobalTypeEnv tcg_env' final_type_env
465    } }
466
467 tc_rn_src_decls :: ModDetails
468                     -> [LHsDecl RdrName]
469                     -> TcM (TcGblEnv, TcLclEnv)
470 -- Loops around dealing with each top level inter-splice group
471 -- in turn, until it's dealt with the entire module
472 tc_rn_src_decls boot_details ds
473  = {-# SCC "tc_rn_src_decls" #-}
474    do { (first_group, group_tail) <- findSplice ds  ;
475                 -- If ds is [] we get ([], Nothing)
476
477         -- The extra_deps are needed while renaming type and class declarations
478         -- See Note [Extra dependencies from .hs-boot files] in RnSource
479         let { extra_deps = map tyConName (typeEnvTyCons (md_types boot_details)) } ;
480         -- Deal with decls up to, but not including, the first splice
481         (tcg_env, rn_decls) <- rnTopSrcDecls extra_deps first_group ;
482                 -- rnTopSrcDecls fails if there are any errors
483
484         (tcg_env, tcl_env) <- setGblEnv tcg_env $
485                               tcTopSrcDecls boot_details rn_decls ;
486
487         -- If there is no splice, we're nearly done
488         setEnvs (tcg_env, tcl_env) $
489         case group_tail of {
490            Nothing -> do { tcg_env <- checkMain ;       -- Check for `main'
491                            traceTc "returning from tc_rn_src_decls: " $
492                              ppr $ nameEnvElts $ tcg_type_env tcg_env ; -- RAE
493                            return (tcg_env, tcl_env)
494                       } ;
495
496 #ifndef GHCI
497         -- There shouldn't be a splice
498            Just (SpliceDecl {}, _) -> do {
499         failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
500 #else
501         -- If there's a splice, we must carry on
502            Just (SpliceDecl splice_expr _, rest_ds) -> do {
503
504         -- Rename the splice expression, and get its supporting decls
505         (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;
506                 -- checkNoErrs: don't typecheck if renaming failed
507         rnDump (ppr rn_splice_expr) ;
508
509         -- Execute the splice
510         spliced_decls <- tcSpliceDecls rn_splice_expr ;
511
512         -- Glue them on the front of the remaining decls and loop
513         setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
514         tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
515 #endif /* GHCI */
516     } } }
517 \end{code}
518
519 %************************************************************************
520 %*                                                                      *
521         Compiling hs-boot source files, and
522         comparing the hi-boot interface with the real thing
523 %*                                                                      *
524 %************************************************************************
525
526 \begin{code}
527 tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
528 tcRnHsBootDecls decls
529    = do { (first_group, group_tail) <- findSplice decls
530
531                 -- Rename the declarations
532         ; (tcg_env, HsGroup {
533                    hs_tyclds = tycl_decls,
534                    hs_instds = inst_decls,
535                    hs_derivds = deriv_decls,
536                    hs_fords  = for_decls,
537                    hs_defds  = def_decls,
538                    hs_ruleds = rule_decls,
539                    hs_vects  = vect_decls,
540                    hs_annds  = _,
541                    hs_valds  = val_binds }) <- rnTopSrcDecls [] first_group
542         -- The empty list is for extra dependencies coming from .hs-boot files
543         -- See Note [Extra dependencies from .hs-boot files] in RnSource
544         ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
545
546
547                 -- Check for illegal declarations
548         ; case group_tail of
549              Just (SpliceDecl d _, _) -> badBootDecl "splice" d
550              Nothing                  -> return ()
551         ; mapM_ (badBootDecl "foreign") for_decls
552         ; mapM_ (badBootDecl "default") def_decls
553         ; mapM_ (badBootDecl "rule")    rule_decls
554         ; mapM_ (badBootDecl "vect")    vect_decls
555
556                 -- Typecheck type/class/isntance decls
557         ; traceTc "Tc2 (boot)" empty
558         ; (tcg_env, inst_infos, _deriv_binds)
559              <- tcTyClsInstDecls emptyModDetails tycl_decls inst_decls deriv_decls
560         ; setGblEnv tcg_env     $ do {
561
562                 -- Typecheck value declarations
563         ; traceTc "Tc5" empty
564         ; val_ids <- tcHsBootSigs val_binds
565
566                 -- Wrap up
567                 -- No simplification or zonking to do
568         ; traceTc "Tc7a" empty
569         ; gbl_env <- getGblEnv
570
571                 -- Make the final type-env
572                 -- Include the dfun_ids so that their type sigs
573                 -- are written into the interface file.
574         ; let { type_env0 = tcg_type_env gbl_env
575               ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
576               ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
577               ; dfun_ids = map iDFunId inst_infos
578               }
579
580         ; setGlobalTypeEnv gbl_env type_env2
581    }}
582    ; traceTc "boot" (ppr lie); return gbl_env }
583
584 badBootDecl :: String -> Located decl -> TcM ()
585 badBootDecl what (L loc _)
586   = addErrAt loc (char 'A' <+> text what
587       <+> ptext (sLit "declaration is not (currently) allowed in a hs-boot file"))
588 \end{code}
589
590 Once we've typechecked the body of the module, we want to compare what
591 we've found (gathered in a TypeEnv) with the hi-boot details (if any).
592
593 \begin{code}
594 checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv
595 -- Compare the hi-boot file for this module (if there is one)
596 -- with the type environment we've just come up with
597 -- In the common case where there is no hi-boot file, the list
598 -- of boot_names is empty.
599 --
600 -- The bindings we return give bindings for the dfuns defined in the
601 -- hs-boot file, such as        $fbEqT = $fEqT
602
603 checkHiBootIface
604         tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds,
605                             tcg_insts = local_insts,
606                             tcg_type_env = local_type_env, tcg_exports = local_exports })
607         (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
608                       md_types = boot_type_env, md_exports = boot_exports })
609   | isHsBoot hs_src     -- Current module is already a hs-boot file!
610   = return tcg_env
611
612   | otherwise
613   = do  { traceTc "checkHiBootIface" $ vcat
614              [ ppr boot_type_env, ppr boot_insts, ppr boot_exports]
615
616                 -- Check the exports of the boot module, one by one
617         ; mapM_ check_export boot_exports
618
619                 -- Check for no family instances
620         ; unless (null boot_fam_insts) $
621             panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
622                    "instances in boot files yet...")
623             -- FIXME: Why?  The actual comparison is not hard, but what would
624             --        be the equivalent to the dfun bindings returned for class
625             --        instances?  We can't easily equate tycons...
626
627                 -- Check instance declarations
628         ; mb_dfun_prs <- mapM check_inst boot_insts
629         ; let dfun_prs   = catMaybes mb_dfun_prs
630               boot_dfuns = map fst dfun_prs
631               dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
632                                      | (boot_dfun, dfun) <- dfun_prs ]
633               type_env'  = extendTypeEnvWithIds local_type_env boot_dfuns
634               tcg_env'   = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
635
636         ; failIfErrsM
637         ; setGlobalTypeEnv tcg_env' type_env' }
638              -- Update the global type env *including* the knot-tied one
639              -- so that if the source module reads in an interface unfolding
640              -- mentioning one of the dfuns from the boot module, then it
641              -- can "see" that boot dfun.   See Trac #4003
642   where
643     check_export boot_avail     -- boot_avail is exported by the boot iface
644       | name `elem` dfun_names = return ()
645       | isWiredInName name     = return ()      -- No checking for wired-in names.  In particular,
646                                                 -- 'error' is handled by a rather gross hack
647                                                 -- (see comments in GHC.Err.hs-boot)
648
649         -- Check that the actual module exports the same thing
650       | not (null missing_names)
651       = addErrAt (nameSrcSpan (head missing_names))
652                  (missingBootThing (head missing_names) "exported by")
653
654         -- If the boot module does not *define* the thing, we are done
655         -- (it simply re-exports it, and names match, so nothing further to do)
656       | isNothing mb_boot_thing = return ()
657
658         -- Check that the actual module also defines the thing, and
659         -- then compare the definitions
660       | Just real_thing <- lookupTypeEnv local_type_env name,
661         Just boot_thing <- mb_boot_thing
662       = when (not (checkBootDecl boot_thing real_thing))
663             $ addErrAt (nameSrcSpan (getName boot_thing))
664                        (let boot_decl = tyThingToIfaceDecl
665                                                (fromJust mb_boot_thing)
666                             real_decl = tyThingToIfaceDecl real_thing
667                         in bootMisMatch real_thing boot_decl real_decl)
668
669       | otherwise
670       = addErrTc (missingBootThing name "defined in")
671       where
672         name          = availName boot_avail
673         mb_boot_thing = lookupTypeEnv boot_type_env name
674         missing_names = case lookupNameEnv local_export_env name of
675                           Nothing    -> [name]
676                           Just avail -> availNames boot_avail `minusList` availNames avail
677
678     dfun_names = map getName boot_insts
679
680     local_export_env :: NameEnv AvailInfo
681     local_export_env = availsToNameEnv local_exports
682
683     check_inst :: ClsInst -> TcM (Maybe (Id, Id))
684         -- Returns a pair of the boot dfun in terms of the equivalent real dfun
685     check_inst boot_inst
686         = case [dfun | inst <- local_insts,
687                        let dfun = instanceDFunId inst,
688                        idType dfun `eqType` boot_inst_ty ] of
689             [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts)
690                                                   , text "boot_inst"   <+> ppr boot_inst
691                                                   , text "boot_inst_ty" <+> ppr boot_inst_ty
692                                                   ])
693                      ; addErrTc (instMisMatch boot_inst); return Nothing }
694             (dfun:_) -> return (Just (local_boot_dfun, dfun))
695         where
696           boot_dfun = instanceDFunId boot_inst
697           boot_inst_ty = idType boot_dfun
698           local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
699
700
701 -- This has to compare the TyThing from the .hi-boot file to the TyThing
702 -- in the current source file.  We must be careful to allow alpha-renaming
703 -- where appropriate, and also the boot declaration is allowed to omit
704 -- constructors and class methods.
705 --
706 -- See rnfail055 for a good test of this stuff.
707
708 checkBootDecl :: TyThing -> TyThing -> Bool
709
710 checkBootDecl (AnId id1) (AnId id2)
711   = ASSERT(id1 == id2)
712     (idType id1 `eqType` idType id2)
713
714 checkBootDecl (ATyCon tc1) (ATyCon tc2)
715   = checkBootTyCon tc1 tc2
716
717 checkBootDecl (ADataCon dc1) (ADataCon _)
718   = pprPanic "checkBootDecl" (ppr dc1)
719
720 checkBootDecl _ _ = False -- probably shouldn't happen
721
722 ----------------
723 checkBootTyCon :: TyCon -> TyCon -> Bool
724 checkBootTyCon tc1 tc2
725   | not (eqKind (tyConKind tc1) (tyConKind tc2))
726   = False       -- First off, check the kind
727
728   | Just c1 <- tyConClass_maybe tc1
729   , Just c2 <- tyConClass_maybe tc2
730   , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1)
731           = classExtraBigSig c1
732         (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2)
733           = classExtraBigSig c2
734   , Just env <- eqTyVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2
735   = let
736        eqSig (id1, def_meth1) (id2, def_meth2)
737          = idName id1 == idName id2 &&
738            eqTypeX env op_ty1 op_ty2 &&
739            def_meth1 == def_meth2
740          where
741           (_, rho_ty1) = splitForAllTys (idType id1)
742           op_ty1 = funResultTy rho_ty1
743           (_, rho_ty2) = splitForAllTys (idType id2)
744           op_ty2 = funResultTy rho_ty2
745
746        eqAT (tc1, def_ats1) (tc2, def_ats2)
747          = checkBootTyCon tc1 tc2 &&
748            eqListBy eqATDef def_ats1 def_ats2
749
750        -- Ignore the location of the defaults
751        eqATDef (ATD tvs1 ty_pats1 ty1 _loc1) (ATD tvs2 ty_pats2 ty2 _loc2)
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 becuase 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 (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 = TyConApp 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 tcRnExpr hsc_env ictxt rdr_expr
1533   = initTcPrintErrors hsc_env iNTERACTIVE $
1534     setInteractiveContext hsc_env ictxt $ do {
1535
1536     (rn_expr, _fvs) <- rnLExpr rdr_expr ;
1537     failIfErrsM ;
1538
1539         -- Now typecheck the expression;
1540         -- it might have a rank-2 type (e.g. :t runST)
1541     uniq <- newUnique ;
1542     let { fresh_it  = itName uniq (getLoc rdr_expr) } ;
1543     ((_tc_expr, res_ty), lie) <- captureConstraints $ 
1544                                  tcInferRho rn_expr ;
1545     ((qtvs, dicts, _, _), lie_top) <- captureConstraints $
1546                                       {-# SCC "simplifyInfer" #-}
1547                                       simplifyInfer True {- Free vars are closed -}
1548                                                     False {- No MR for now -}
1549                                                     [(fresh_it, res_ty)]
1550                                                     lie ;
1551     _ <- simplifyInteractive lie_top ;       -- Ignore the dicionary bindings
1552
1553     let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
1554     zonkTcType all_expr_ty
1555     }
1556
1557 --------------------------
1558 tcRnImportDecls :: HscEnv
1559                 -> [LImportDecl RdrName]
1560                 -> IO (Messages, Maybe GlobalRdrEnv)
1561 tcRnImportDecls hsc_env import_decls
1562  =  initTcPrintErrors hsc_env iNTERACTIVE $
1563     do { gbl_env <- tcRnImports hsc_env iNTERACTIVE import_decls
1564        ; return (tcg_rdr_env gbl_env) }
1565 \end{code}
1566
1567 tcRnType just finds the kind of a type
1568
1569 \begin{code}
1570 tcRnType :: HscEnv
1571          -> InteractiveContext
1572          -> Bool        -- Normalise the returned type
1573          -> LHsType RdrName
1574          -> IO (Messages, Maybe (Type, Kind))
1575 tcRnType hsc_env ictxt normalise rdr_type
1576   = initTcPrintErrors hsc_env iNTERACTIVE $
1577     setInteractiveContext hsc_env ictxt $ do {
1578
1579     (rn_type, _fvs) <- rnLHsType GHCiCtx rdr_type ;
1580     failIfErrsM ;
1581
1582         -- Now kind-check the type
1583         -- It can have any rank or kind
1584     ty <- tcHsSigType GhciCtxt rn_type ;
1585
1586     ty' <- if normalise
1587            then do { fam_envs <- tcGetFamInstEnvs
1588                    ; return (snd (normaliseType fam_envs ty)) }
1589                    -- normaliseType returns a coercion
1590                    -- which we discard
1591            else return ty ;
1592
1593     return (ty', typeKind ty)
1594     }
1595
1596 \end{code}
1597
1598 tcRnDeclsi exists to allow class, data, and other declarations in GHCi.
1599
1600 \begin{code}
1601 tcRnDeclsi :: HscEnv
1602            -> InteractiveContext
1603            -> [LHsDecl RdrName]
1604            -> IO (Messages, Maybe TcGblEnv)
1605
1606 tcRnDeclsi hsc_env ictxt local_decls =
1607     initTcPrintErrors hsc_env iNTERACTIVE $
1608     setInteractiveContext hsc_env ictxt $ do
1609
1610     ((tcg_env, tclcl_env), lie) <-
1611         captureConstraints $ tc_rn_src_decls emptyModDetails local_decls
1612     setEnvs (tcg_env, tclcl_env) $ do
1613
1614     new_ev_binds <- simplifyTop lie
1615     failIfErrsM
1616     let TcGblEnv { tcg_type_env  = type_env,
1617                    tcg_binds     = binds,
1618                    tcg_sigs      = sig_ns,
1619                    tcg_ev_binds  = cur_ev_binds,
1620                    tcg_imp_specs = imp_specs,
1621                    tcg_rules     = rules,
1622                    tcg_vects     = vects,
1623                    tcg_fords     = fords } = tcg_env
1624         all_ev_binds = cur_ev_binds `unionBags` new_ev_binds
1625
1626     (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
1627         <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords
1628
1629     let --global_ids = map globaliseAndTidyId bind_ids
1630         final_type_env = extendTypeEnvWithIds type_env bind_ids --global_ids
1631         tcg_env' = tcg_env { tcg_binds     = binds',
1632                              tcg_ev_binds  = ev_binds',
1633                              tcg_imp_specs = imp_specs',
1634                              tcg_rules     = rules',
1635                              tcg_vects     = vects',
1636                              tcg_fords     = fords' }
1637
1638     tcg_env'' <- setGlobalTypeEnv tcg_env' final_type_env
1639
1640     traceTc "returning from tcRnDeclsi: " $ ppr $ nameEnvElts $ tcg_type_env tcg_env'' -- RAE
1641
1642     return tcg_env''
1643
1644
1645 #endif /* GHCi */
1646 \end{code}
1647
1648
1649 %************************************************************************
1650 %*                                                                      *
1651         More GHCi stuff, to do with browsing and getting info
1652 %*                                                                      *
1653 %************************************************************************
1654
1655 \begin{code}
1656 #ifdef GHCI
1657 -- | ASSUMES that the module is either in the 'HomePackageTable' or is
1658 -- a package module with an interface on disk.  If neither of these is
1659 -- true, then the result will be an error indicating the interface
1660 -- could not be found.
1661 getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface)
1662 getModuleInterface hsc_env mod
1663   = initTc hsc_env HsSrcFile False iNTERACTIVE $
1664     loadModuleInterface (ptext (sLit "getModuleInterface")) mod
1665
1666 tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name])
1667 tcRnLookupRdrName hsc_env rdr_name
1668   = initTcPrintErrors hsc_env iNTERACTIVE $
1669     setInteractiveContext hsc_env (hsc_IC hsc_env) $
1670     lookup_rdr_name rdr_name
1671
1672 lookup_rdr_name :: RdrName -> TcM [Name]
1673 lookup_rdr_name rdr_name = do
1674         -- If the identifier is a constructor (begins with an
1675         -- upper-case letter), then we need to consider both
1676         -- constructor and type class identifiers.
1677     let rdr_names = dataTcOccs rdr_name
1678
1679         -- results :: [Either Messages Name]
1680     results <- mapM (tryTcErrs . lookupOccRn) rdr_names
1681
1682     traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)])
1683         -- The successful lookups will be (Just name)
1684     let (warns_s, good_names) = unzip [ (msgs, name)
1685                                       | (msgs, Just name) <- results]
1686         errs_s = [msgs | (msgs, Nothing) <- results]
1687
1688         -- Fail if nothing good happened, else add warnings
1689     if null good_names
1690       then  addMessages (head errs_s) >> failM
1691                 -- No lookup succeeded, so
1692                 -- pick the first error message and report it
1693                 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
1694                 --       while the other is "X is not in scope",
1695                 --       we definitely want the former; but we might pick the latter
1696       else      mapM_ addMessages warns_s
1697                 -- Add deprecation warnings
1698     return good_names
1699
1700 #endif
1701
1702 tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
1703 tcRnLookupName hsc_env name
1704   = initTcPrintErrors hsc_env iNTERACTIVE $
1705     setInteractiveContext hsc_env (hsc_IC hsc_env) $
1706     tcRnLookupName' name
1707
1708 -- To look up a name we have to look in the local environment (tcl_lcl)
1709 -- as well as the global environment, which is what tcLookup does.
1710 -- But we also want a TyThing, so we have to convert:
1711
1712 tcRnLookupName' :: Name -> TcRn TyThing
1713 tcRnLookupName' name = do
1714    tcthing <- tcLookup name
1715    case tcthing of
1716      AGlobal thing    -> return thing
1717      ATcId{tct_id=id} -> return (AnId id)
1718      _ -> panic "tcRnLookupName'"
1719
1720 tcRnGetInfo :: HscEnv
1721             -> Name
1722             -> IO (Messages, Maybe (TyThing, Fixity, [ClsInst]))
1723
1724 -- Used to implement :info in GHCi
1725 --
1726 -- Look up a RdrName and return all the TyThings it might be
1727 -- A capitalised RdrName is given to us in the DataName namespace,
1728 -- but we want to treat it as *both* a data constructor
1729 --  *and* as a type or class constructor;
1730 -- hence the call to dataTcOccs, and we return up to two results
1731 tcRnGetInfo hsc_env name
1732   = let ictxt = hsc_IC hsc_env in
1733     initTcPrintErrors hsc_env iNTERACTIVE $
1734     setInteractiveContext hsc_env ictxt  $ do
1735
1736         -- Load the interface for all unqualified types and classes
1737         -- That way we will find all the instance declarations
1738         -- (Packages have not orphan modules, and we assume that
1739         --  in the home package all relevant modules are loaded.)
1740     loadUnqualIfaces hsc_env ictxt
1741
1742     thing  <- tcRnLookupName' name
1743     fixity <- lookupFixityRn name
1744     ispecs <- lookupInsts thing
1745     return (thing, fixity, ispecs)
1746
1747 lookupInsts :: TyThing -> TcM [ClsInst]
1748 lookupInsts (ATyCon tc)
1749   | Just cls <- tyConClass_maybe tc
1750   = do  { inst_envs <- tcGetInstEnvs
1751         ; return (classInstances inst_envs cls) }
1752
1753   | otherwise
1754   = do  { (pkg_ie, home_ie) <- tcGetInstEnvs
1755                 -- Load all instances for all classes that are
1756                 -- in the type environment (which are all the ones
1757                 -- we've seen in any interface file so far)
1758         ; return [ ispec        -- Search all
1759                  | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
1760                  , let dfun = instanceDFunId ispec
1761                  , relevant dfun ] }
1762   where
1763     relevant df = tc_name `elemNameSet` orphNamesOfDFunHead (idType df)
1764     tc_name     = tyConName tc
1765
1766 lookupInsts _ = return []
1767
1768 loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM ()
1769 -- Load the interface for everything that is in scope unqualified
1770 -- This is so that we can accurately report the instances for
1771 -- something
1772 loadUnqualIfaces hsc_env ictxt
1773   = initIfaceTcRn $ do
1774     mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
1775   where
1776     this_pkg = thisPackage (hsc_dflags hsc_env)
1777
1778     unqual_mods = filter ((/= this_pkg) . modulePackageId)
1779                   [ nameModule name
1780                   | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt),
1781                     let name = gre_name gre,
1782                     not (isInternalName name),
1783                     isTcOcc (nameOccName name),  -- Types and classes only
1784                     unQualOK gre ]               -- In scope unqualified
1785     doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified")
1786 \end{code}
1787
1788 %************************************************************************
1789 %*                                                                      *
1790                 Degugging output
1791 %*                                                                      *
1792 %************************************************************************
1793
1794 \begin{code}
1795 rnDump :: SDoc -> TcRn ()
1796 -- Dump, with a banner, if -ddump-rn
1797 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1798
1799 tcDump :: TcGblEnv -> TcRn ()
1800 tcDump env
1801  = do { dflags <- getDynFlags ;
1802
1803         -- Dump short output if -ddump-types or -ddump-tc
1804         when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1805              (dumpTcRn short_dump) ;
1806
1807         -- Dump bindings if -ddump-tc
1808         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1809    }
1810   where
1811     short_dump = pprTcGblEnv env
1812     full_dump  = pprLHsBinds (tcg_binds env)
1813         -- NB: foreign x-d's have undefined's in their types;
1814         --     hence can't show the tc_fords
1815
1816 tcCoreDump :: ModGuts -> TcM ()
1817 tcCoreDump mod_guts
1818  = do { dflags <- getDynFlags ;
1819         when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1820              (dumpTcRn (pprModGuts mod_guts)) ;
1821
1822         -- Dump bindings if -ddump-tc
1823         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1824   where
1825     full_dump = pprCoreBindings (mg_binds mod_guts)
1826
1827 -- It's unpleasant having both pprModGuts and pprModDetails here
1828 pprTcGblEnv :: TcGblEnv -> SDoc
1829 pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,
1830                         tcg_insts     = insts,
1831                         tcg_fam_insts = fam_insts,
1832                         tcg_rules     = rules,
1833                         tcg_vects     = vects,
1834                         tcg_imports   = imports })
1835   = vcat [ ppr_types insts type_env
1836          , ppr_tycons fam_insts type_env
1837          , ppr_insts insts
1838          , ppr_fam_insts fam_insts
1839          , vcat (map ppr rules)
1840          , vcat (map ppr vects)
1841          , ptext (sLit "Dependent modules:") <+>
1842                 ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
1843          , ptext (sLit "Dependent packages:") <+>
1844                 ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)]
1845   where         -- The two uses of sortBy are just to reduce unnecessary
1846                 -- wobbling in testsuite output
1847     cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2)
1848         = (mod_name1 `stableModuleNameCmp` mod_name2)
1849                   `thenCmp`
1850           (is_boot1 `compare` is_boot2)
1851
1852 pprModGuts :: ModGuts -> SDoc
1853 pprModGuts (ModGuts { mg_tcs = tcs
1854                     , mg_rules = rules })
1855   = vcat [ ppr_types [] (mkTypeEnv (map ATyCon tcs)),
1856            ppr_rules rules ]
1857
1858 ppr_types :: [ClsInst] -> TypeEnv -> SDoc
1859 ppr_types insts type_env
1860   = text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids)
1861   where
1862     dfun_ids = map instanceDFunId insts
1863     ids = [id | id <- typeEnvIds type_env, want_sig id]
1864     want_sig id | opt_PprStyle_Debug = True
1865                 | otherwise          = isLocalId id &&
1866                                        isExternalName (idName id) &&
1867                                        not (id `elem` dfun_ids)
1868         -- isLocalId ignores data constructors, records selectors etc.
1869         -- The isExternalName ignores local dictionary and method bindings
1870         -- that the type checker has invented.  Top-level user-defined things
1871         -- have External names.
1872
1873 ppr_tycons :: [FamInst br] -> TypeEnv -> SDoc
1874 ppr_tycons fam_insts type_env
1875   = vcat [ text "TYPE CONSTRUCTORS"
1876          ,   nest 2 (ppr_tydecls tycons)
1877          , text "COERCION AXIOMS"
1878          ,   nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ]
1879   where
1880     fi_tycons = famInstsRepTyCons fam_insts
1881     tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
1882     want_tycon tycon | opt_PprStyle_Debug = True
1883                      | otherwise          = not (isImplicitTyCon tycon) &&
1884                                             isExternalName (tyConName tycon) &&
1885                                             not (tycon `elem` fi_tycons)
1886
1887 ppr_insts :: [ClsInst] -> SDoc
1888 ppr_insts []     = empty
1889 ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
1890
1891 ppr_fam_insts :: [FamInst br] -> SDoc
1892 ppr_fam_insts []        = empty
1893 ppr_fam_insts fam_insts =
1894   text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts)
1895
1896 ppr_sigs :: [Var] -> SDoc
1897 ppr_sigs ids
1898         -- Print type signatures; sort by OccName
1899   = vcat (map ppr_sig (sortBy (comparing getOccName) ids))
1900   where
1901     ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id)))
1902
1903 ppr_tydecls :: [TyCon] -> SDoc
1904 ppr_tydecls tycons
1905         -- Print type constructor info; sort by OccName
1906   = vcat (map ppr_tycon (sortBy (comparing getOccName) tycons))
1907   where
1908     ppr_tycon tycon = vcat [ ppr (tyConName tycon) <+> dcolon <+> ppr (tyConKind tycon)
1909                               -- Temporarily print the kind signature too
1910                            , ppr (tyThingToIfaceDecl (ATyCon tycon)) ]
1911
1912 ppr_rules :: [CoreRule] -> SDoc
1913 ppr_rules [] = empty
1914 ppr_rules rs = vcat [ptext (sLit "{-# RULES"),
1915                       nest 2 (pprRules rs),
1916                       ptext (sLit "#-}")]
1917 \end{code}