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 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 TcDefaults
46 import TcEnv
47 import TcRules
48 import TcForeign
49 import TcInstDcls
50 import TcIface
51 import TcMType
52 import MkIface
53 import IfaceSyn
54 import TcSimplify
55 import TcTyClsDecls
56 import LoadIface
57 import RnNames
58 import RnEnv
59 import RnSource
60 import PprCore
61 import CoreSyn
62 import ErrUtils
63 import Id
64 import VarEnv
65 import Module
66 import UniqFM
67 import Name
68 import NameEnv
69 import NameSet
70 import Avail
71 import TyCon
72 import SrcLoc
73 import HscTypes
74 import ListSetOps
75 import Outputable
76 import DataCon
77 import Type
78 import Class
79 import CoAxiom  ( CoAxBranch(..) )
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 (CoAxBranch { cab_tvs = tvs1, cab_lhs =  ty_pats1, cab_rhs = ty1 })
752                (CoAxBranch { cab_tvs = tvs2, cab_lhs =  ty_pats2, cab_rhs = ty2 })
753          | Just env <- eqTyVarBndrs emptyRnEnv2 tvs1 tvs2
754          = eqListBy (eqTypeX env) ty_pats1 ty_pats2 &&
755            eqTypeX env ty1 ty2
756          | otherwise = False
757
758        eqFD (as1,bs1) (as2,bs2) =
759          eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
760          eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
761     in
762              -- Checks kind of class
763        eqListBy eqFD clas_fds1 clas_fds2 &&
764        (null sc_theta1 && null op_stuff1 && null ats1
765         ||   -- Above tests for an "abstract" class
766         eqListBy (eqPredX env) sc_theta1 sc_theta2 &&
767         eqListBy eqSig op_stuff1 op_stuff2 &&
768         eqListBy eqAT ats1 ats2)
769
770   | Just syn_rhs1 <- synTyConRhs_maybe tc1
771   , Just syn_rhs2 <- synTyConRhs_maybe tc2
772   , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
773   = ASSERT(tc1 == tc2)
774     let eqSynRhs (SynFamilyTyCon o1 i1) (SynFamilyTyCon o2 i2)
775             = o1==o2 && i1==i2
776         eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
777             = eqTypeX env t1 t2
778         eqSynRhs _ _ = False
779     in
780     eqSynRhs syn_rhs1 syn_rhs2
781
782   | isAlgTyCon tc1 && isAlgTyCon tc2
783   , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
784   = ASSERT(tc1 == tc2)
785     eqListBy (eqPredX env) (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
786     eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
787
788   | isForeignTyCon tc1 && isForeignTyCon tc2
789   = eqKind (tyConKind tc1) (tyConKind tc2) &&
790     tyConExtName tc1 == tyConExtName tc2
791
792   | otherwise = False
793   where
794     eqAlgRhs (AbstractTyCon dis1) rhs2
795       | dis1      = isDistinctAlgRhs rhs2   --Check compatibility
796       | otherwise = True
797     eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True
798     eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} =
799         eqListBy eqCon (data_cons tc1) (data_cons tc2)
800     eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} =
801         eqCon (data_con tc1) (data_con tc2)
802     eqAlgRhs _ _ = False
803
804     eqCon c1 c2
805       =  dataConName c1 == dataConName c2
806       && dataConIsInfix c1 == dataConIsInfix c2
807       && eqListBy eqHsBang (dataConStrictMarks c1) (dataConStrictMarks c2)
808       && dataConFieldLabels c1 == dataConFieldLabels c2
809       && eqType (dataConUserType c1) (dataConUserType c2)
810
811 emptyRnEnv2 :: RnEnv2
812 emptyRnEnv2 = mkRnEnv2 emptyInScopeSet
813
814 ----------------
815 missingBootThing :: Name -> String -> SDoc
816 missingBootThing name what
817   = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not")
818               <+> text what <+> ptext (sLit "the module")
819
820 bootMisMatch :: TyThing -> IfaceDecl -> IfaceDecl -> SDoc
821 bootMisMatch thing boot_decl real_decl
822   = vcat [ppr thing <+> ptext (sLit "has conflicting definitions in the module and its hs-boot file"),
823           ptext (sLit "Main module:") <+> ppr real_decl,
824           ptext (sLit "Boot file:  ") <+> ppr boot_decl]
825
826 instMisMatch :: ClsInst -> SDoc
827 instMisMatch inst
828   = hang (ppr inst)
829        2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself"))
830 \end{code}
831
832
833 %************************************************************************
834 %*                                                                      *
835         Type-checking the top level of a module
836 %*                                                                      *
837 %************************************************************************
838
839 tcRnGroup takes a bunch of top-level source-code declarations, and
840  * renames them
841  * gets supporting declarations from interface files
842  * typechecks them
843  * zonks them
844  * and augments the TcGblEnv with the results
845
846 In Template Haskell it may be called repeatedly for each group of
847 declarations.  It expects there to be an incoming TcGblEnv in the
848 monad; it augments it and returns the new TcGblEnv.
849
850 \begin{code}
851 ------------------------------------------------
852 rnTopSrcDecls :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
853 -- Fails if there are any errors
854 rnTopSrcDecls extra_deps group
855  = do { -- Rename the source decls
856         traceTc "rn12" empty ;
857         (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls extra_deps group ;
858         traceTc "rn13" empty ;
859
860         -- save the renamed syntax, if we want it
861         let { tcg_env'
862                 | Just grp <- tcg_rn_decls tcg_env
863                   = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
864                 | otherwise
865                    = tcg_env };
866
867                 -- Dump trace of renaming part
868         rnDump (ppr rn_decls) ;
869
870         return (tcg_env', rn_decls)
871    }
872
873 ------------------------------------------------
874 tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
875 tcTopSrcDecls boot_details
876         (HsGroup { hs_tyclds = tycl_decls,
877                    hs_instds = inst_decls,
878                    hs_derivds = deriv_decls,
879                    hs_fords  = foreign_decls,
880                    hs_defds  = default_decls,
881                    hs_annds  = annotation_decls,
882                    hs_ruleds = rule_decls,
883                    hs_vects  = vect_decls,
884                    hs_valds  = val_binds })
885  = do {         -- Type-check the type and class decls, and all imported decls
886                 -- The latter come in via tycl_decls
887         traceTc "Tc2 (src)" empty ;
888
889                 -- Source-language instances, including derivings,
890                 -- and import the supporting declarations
891         traceTc "Tc3" empty ;
892         (tcg_env, inst_infos, deriv_binds)
893             <- tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls ;
894         setGblEnv tcg_env       $ do {
895
896                 -- Foreign import declarations next.
897         traceTc "Tc4" empty ;
898         (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ;
899         tcExtendGlobalValEnv fi_ids     $ do {
900
901                 -- Default declarations
902         traceTc "Tc4a" empty ;
903         default_tys <- tcDefaults default_decls ;
904         updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
905
906                 -- Now GHC-generated derived bindings, generics, and selectors
907                 -- Do not generate warnings from compiler-generated code;
908                 -- hence the use of discardWarnings
909         tc_envs <- discardWarnings (tcTopBinds deriv_binds) ;
910         setEnvs tc_envs $ do {
911
912                 -- Value declarations next
913         traceTc "Tc5" empty ;
914         tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds;
915         setEnvs tc_envs $ do {  -- Environment doesn't change now
916
917                 -- Second pass over class and instance declarations,
918                 -- now using the kind-checked decls
919         traceTc "Tc6" empty ;
920         inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
921
922                 -- Foreign exports
923         traceTc "Tc7" empty ;
924         (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ;
925
926                 -- Annotations
927         annotations <- tcAnnotations annotation_decls ;
928
929                 -- Rules
930         rules <- tcRules rule_decls ;
931
932                 -- Vectorisation declarations
933         vects <- tcVectDecls vect_decls ;
934
935                 -- Wrap up
936         traceTc "Tc7a" empty ;
937         let { all_binds = inst_binds     `unionBags`
938                           foe_binds
939
940             ; fo_gres = fi_gres `unionBags` foe_gres
941             ; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre) 
942                                 emptyFVs fo_gres
943             ; fo_rdr_names :: [RdrName]
944             ; fo_rdr_names = foldrBag gre_to_rdr_name [] fo_gres
945
946             ; sig_names = mkNameSet (collectHsValBinders val_binds)
947                           `minusNameSet` getTypeSigNames val_binds
948
949                 -- Extend the GblEnv with the (as yet un-zonked)
950                 -- bindings, rules, foreign decls
951             ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds
952                                  , tcg_sigs  = tcg_sigs tcg_env `unionNameSets` sig_names
953                                  , tcg_rules = tcg_rules tcg_env ++ rules
954                                  , tcg_vects = tcg_vects tcg_env ++ vects
955                                  , tcg_anns  = tcg_anns tcg_env ++ annotations
956                                  , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls
957                                  , tcg_dus   = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ;
958                                  -- tcg_dus: see Note [Newtype constructor usage in foreign declarations]
959
960         addUsedRdrNames fo_rdr_names ;
961         traceTc "Tc8: type_env: " (ppr $ nameEnvElts $ tcg_type_env tcg_env') ; -- RAE
962         return (tcg_env', tcl_env)
963     }}}}}}
964   where
965     gre_to_rdr_name :: GlobalRdrElt -> [RdrName] -> [RdrName]
966         -- For *imported* newtype data constructors, we want to
967         -- make sure that at least one of the imports for them is used
968         -- See Note [Newtype constructor usage in foreign declarations]
969     gre_to_rdr_name gre rdrs
970       = case gre_prov gre of
971            LocalDef          -> rdrs
972            Imported []       -> panic "gre_to_rdr_name: Imported []"
973            Imported (is : _) -> mkRdrQual modName occName : rdrs
974               where
975                 modName = is_as (is_decl is)
976                 occName = nameOccName (gre_name gre)
977
978 ---------------------------
979 tcTyClsInstDecls :: ModDetails 
980                  -> [TyClGroup Name] 
981                  -> [LInstDecl Name]
982                  -> [LDerivDecl Name]
983                  -> TcM (TcGblEnv,            -- The full inst env
984                          [InstInfo Name],     -- Source-code instance decls to process;
985                                               -- contains all dfuns for this module
986                           HsValBinds Name)    -- Supporting bindings for derived instances
987
988 tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls
989  = tcExtendTcTyThingEnv [(con, APromotionErr FamDataConPE) 
990                         | lid <- inst_decls, con <- get_cons lid ] $
991       -- Note [AFamDataCon: not promoting data family constructors]
992    do { tcg_env <- tcTyAndClassDecls boot_details tycl_decls ;
993       ; setGblEnv tcg_env $
994         tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls }
995   where
996     -- get_cons extracts the *constructor* bindings of the declaration
997     get_cons :: LInstDecl Name -> [Name]
998     get_cons (L _ (TyFamInstD {}))                     = []
999     get_cons (L _ (DataFamInstD { dfid_inst = fid }))  = get_fi_cons fid
1000     get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
1001       = concatMap (get_fi_cons . unLoc) fids
1002
1003     get_fi_cons :: DataFamInstDecl Name -> [Name]
1004     get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } }) 
1005       = map (unLoc . con_name . unLoc) cons
1006 \end{code}
1007
1008 Note [AFamDataCon: not promoting data family constructors]
1009 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1010 Consider
1011   data family T a
1012   data instance T Int = MkT
1013   data Proxy (a :: k)
1014   data S = MkS (Proxy 'MkT)
1015
1016 Is it ok to use the promoted data family instance constructor 'MkT' in
1017 the data declaration for S?  No, we don't allow this. It *might* make
1018 sense, but at least it would mean that we'd have to interleave
1019 typechecking instances and data types, whereas at present we do data
1020 types *then* instances.
1021
1022 So to check for this we put in the TcLclEnv a binding for all the family
1023 constructors, bound to AFamDataCon, so that if we trip over 'MkT' when
1024 type checking 'S' we'll produce a decent error message.
1025
1026
1027 %************************************************************************
1028 %*                                                                      *
1029         Checking for 'main'
1030 %*                                                                      *
1031 %************************************************************************
1032
1033 \begin{code}
1034 checkMain :: TcM TcGblEnv
1035 -- If we are in module Main, check that 'main' is defined.
1036 checkMain
1037   = do { tcg_env   <- getGblEnv ;
1038          dflags    <- getDynFlags ;
1039          check_main dflags tcg_env
1040     }
1041
1042 check_main :: DynFlags -> TcGblEnv -> TcM TcGblEnv
1043 check_main dflags tcg_env
1044  | mod /= main_mod
1045  = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>
1046    return tcg_env
1047
1048  | otherwise
1049  = do   { mb_main <- lookupGlobalOccRn_maybe main_fn
1050                 -- Check that 'main' is in scope
1051                 -- It might be imported from another module!
1052         ; case mb_main of {
1053              Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn)
1054                            ; complain_no_main
1055                            ; return tcg_env } ;
1056              Just main_name -> do
1057
1058         { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)
1059         ; let loc = srcLocSpan (getSrcLoc main_name)
1060         ; ioTyCon <- tcLookupTyCon ioTyConName
1061         ; res_ty <- newFlexiTyVarTy liftedTypeKind
1062         ; main_expr
1063                 <- addErrCtxt mainCtxt    $
1064                    tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty])
1065
1066                 -- See Note [Root-main Id]
1067                 -- Construct the binding
1068                 --      :Main.main :: IO res_ty = runMainIO res_ty main
1069         ; run_main_id <- tcLookupId runMainIOName
1070         ; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN
1071                                    (mkVarOccFS (fsLit "main"))
1072                                    (getSrcSpan main_name)
1073               ; root_main_id = Id.mkExportedLocalId root_main_name
1074                                                     (mkTyConApp ioTyCon [res_ty])
1075               ; co  = mkWpTyApps [res_ty]
1076               ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
1077               ; main_bind = mkVarBind root_main_id rhs }
1078
1079         ; return (tcg_env { tcg_main  = Just main_name,
1080                             tcg_binds = tcg_binds tcg_env
1081                                         `snocBag` main_bind,
1082                             tcg_dus   = tcg_dus tcg_env
1083                                         `plusDU` usesOnly (unitFV main_name)
1084                         -- Record the use of 'main', so that we don't
1085                         -- complain about it being defined but not used
1086                  })
1087     }}}
1088   where
1089     mod          = tcg_mod tcg_env
1090     main_mod     = mainModIs dflags
1091     main_fn      = getMainFun dflags
1092
1093     complain_no_main | ghcLink dflags == LinkInMemory = return ()
1094                      | otherwise = failWithTc noMainMsg
1095         -- In interactive mode, don't worry about the absence of 'main'
1096         -- In other modes, fail altogether, so that we don't go on
1097         -- and complain a second time when processing the export list.
1098
1099     mainCtxt  = ptext (sLit "When checking the type of the") <+> pp_main_fn
1100     noMainMsg = ptext (sLit "The") <+> pp_main_fn
1101                 <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod)
1102     pp_main_fn = ppMainFn main_fn
1103
1104 ppMainFn :: RdrName -> SDoc
1105 ppMainFn main_fn
1106   | main_fn == main_RDR_Unqual
1107   = ptext (sLit "function") <+> quotes (ppr main_fn)
1108   | otherwise
1109   = ptext (sLit "main function") <+> quotes (ppr main_fn)
1110
1111 -- | Get the unqualified name of the function to use as the \"main\" for the main module.
1112 -- Either returns the default name or the one configured on the command line with -main-is
1113 getMainFun :: DynFlags -> RdrName
1114 getMainFun dflags = case (mainFunIs dflags) of
1115     Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))
1116     Nothing -> main_RDR_Unqual
1117
1118 checkMainExported :: TcGblEnv -> TcM ()
1119 checkMainExported tcg_env = do
1120   dflags    <- getDynFlags
1121   case tcg_main tcg_env of
1122     Nothing -> return () -- not the main module
1123     Just main_name -> do
1124       let main_mod = mainModIs dflags
1125       checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $
1126               ptext (sLit "The") <+> ppMainFn (nameRdrName main_name) <+>
1127               ptext (sLit "is not exported by module") <+> quotes (ppr main_mod)
1128 \end{code}
1129
1130 Note [Root-main Id]
1131 ~~~~~~~~~~~~~~~~~~~
1132 The function that the RTS invokes is always :Main.main, which we call
1133 root_main_id.  (Because GHC allows the user to have a module not
1134 called Main as the main module, we can't rely on the main function
1135 being called "Main.main".  That's why root_main_id has a fixed module
1136 ":Main".)
1137
1138 This is unusual: it's a LocalId whose Name has a Module from another
1139 module.  Tiresomely, we must filter it out again in MkIface, les we
1140 get two defns for 'main' in the interface file!
1141
1142
1143 %*********************************************************
1144 %*                                                       *
1145                 GHCi stuff
1146 %*                                                       *
1147 %*********************************************************
1148
1149 \begin{code}
1150 setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
1151 setInteractiveContext hsc_env icxt thing_inside
1152   = let -- Initialise the tcg_inst_env with instances from all home modules.
1153         -- This mimics the more selective call to hptInstances in tcRnImports
1154         (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True)
1155         (ic_insts, ic_finsts) = ic_instances icxt
1156
1157         -- Note [GHCi temporary Ids]
1158         -- Ideally we would just make a type_env from ic_tythings
1159         -- and ic_sys_vars, adding in implicit things.  However, Ids
1160         -- bound interactively might have some free type variables
1161         -- (RuntimeUnk things), and if we don't register these free
1162         -- TyVars as global TyVars then the typechecker will try to
1163         -- quantify over them and fall over in zonkQuantifiedTyVar.
1164         --
1165         -- So we must add any free TyVars to the typechecker's global
1166         -- TyVar set.  This is what happens when the local environment
1167         -- is extended, so we use tcExtendGhciEnv below which extends
1168         -- the local environment with the Ids.
1169         --
1170         -- However, any Ids bound this way will shadow other Ids in
1171         -- the GlobalRdrEnv, so we have to be careful to only add Ids
1172         -- which are visible in the GlobalRdrEnv.
1173         --
1174         -- Perhaps it would be better to just extend the global TyVar
1175         -- list from the free tyvars in the Ids here?  Anyway, at least
1176         -- this hack is localised.
1177         --
1178         -- Note [delete shadowed tcg_rdr_env entries]
1179         -- We also *delete* entries from tcg_rdr_env that we have
1180         -- shadowed in the local env (see above).  This isn't strictly
1181         -- necessary, but in an out-of-scope error when GHC suggests
1182         -- names it can be confusing to see multiple identical
1183         -- entries. (#5564)
1184         --
1185         (tmp_ids, types_n_classes) = partitionWith sel_id (ic_tythings icxt)
1186           where sel_id (AnId id) = Left id
1187                 sel_id other     = Right other
1188
1189         type_env = mkTypeEnvWithImplicits
1190                        (map AnId (ic_sys_vars icxt) ++ types_n_classes)
1191
1192         visible_tmp_ids = filter visible tmp_ids
1193           where visible id = not (null (lookupGRE_Name (ic_rn_gbl_env icxt)
1194                                                        (idName id)))
1195
1196         con_fields = [ (dataConName c, dataConFieldLabels c)
1197                      | ATyCon t <- types_n_classes
1198                      , c <- tyConDataCons t ]
1199     in
1200     updGblEnv (\env -> env {
1201           tcg_rdr_env      = delListFromOccEnv (ic_rn_gbl_env icxt)
1202                                                (map getOccName visible_tmp_ids)
1203                                  -- Note [delete shadowed tcg_rdr_env entries]
1204         , tcg_type_env     = type_env
1205         , tcg_insts        = ic_insts
1206         , tcg_inst_env     = extendInstEnvList
1207                               (extendInstEnvList (tcg_inst_env env) ic_insts)
1208                               home_insts
1209         , tcg_fam_insts    = ic_finsts
1210         , tcg_fam_inst_env = extendFamInstEnvList
1211                               (extendFamInstEnvList (tcg_fam_inst_env env)
1212                                                     ic_finsts)
1213                               home_fam_insts
1214         , tcg_field_env    = RecFields (mkNameEnv con_fields)
1215                                        (mkNameSet (concatMap snd con_fields))
1216              -- setting tcg_field_env is necessary to make RecordWildCards work
1217              -- (test: ghci049)
1218         , tcg_fix_env      = ic_fix_env icxt
1219         , tcg_default      = ic_default icxt
1220         }) $
1221
1222         tcExtendGhciEnv visible_tmp_ids $ -- Note [GHCi temporary Ids]
1223           thing_inside
1224
1225 #ifdef GHCI
1226 -- | The returned [Id] is the list of new Ids bound by this statement. It can
1227 -- be used to extend the InteractiveContext via extendInteractiveContext.
1228 --
1229 -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound
1230 -- values, coerced to ().
1231 tcRnStmt :: HscEnv -> InteractiveContext -> GhciLStmt RdrName
1232          -> IO (Messages, Maybe ([Id], LHsExpr Id, FixityEnv))
1233 tcRnStmt hsc_env ictxt rdr_stmt
1234   = initTcPrintErrors hsc_env iNTERACTIVE $
1235     setInteractiveContext hsc_env ictxt $ do {
1236
1237     -- The real work is done here
1238     ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ;
1239     zonked_expr <- zonkTopLExpr tc_expr ;
1240     zonked_ids  <- zonkTopBndrs bound_ids ;
1241
1242         -- None of the Ids should be of unboxed type, because we
1243         -- cast them all to HValues in the end!
1244     mapM_ bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
1245
1246     traceTc "tcs 1" empty ;
1247     let { global_ids = map globaliseAndTidyId zonked_ids } ;
1248         -- Note [Interactively-bound Ids in GHCi]
1249
1250 {- ---------------------------------------------
1251    At one stage I removed any shadowed bindings from the type_env;
1252    they are inaccessible but might, I suppose, cause a space leak if we leave them there.
1253    However, with Template Haskell they aren't necessarily inaccessible.  Consider this
1254    GHCi session
1255          Prelude> let f n = n * 2 :: Int
1256          Prelude> fName <- runQ [| f |]
1257          Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
1258          14
1259          Prelude> let f n = n * 3 :: Int
1260          Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
1261    In the last line we use 'fName', which resolves to the *first* 'f'
1262    in scope. If we delete it from the type env, GHCi crashes because
1263    it doesn't expect that.
1264
1265    Hence this code is commented out
1266
1267 -------------------------------------------------- -}
1268
1269     dumpOptTcRn Opt_D_dump_tc
1270         (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
1271                text "Typechecked expr" <+> ppr zonked_expr]) ;
1272
1273     return (global_ids, zonked_expr, fix_env)
1274     }
1275   where
1276     bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"),
1277                                   nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
1278 \end{code}
1279
1280 Note [Interactively-bound Ids in GHCi]
1281 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1282 The Ids bound by previous Stmts in GHCi are currently
1283         a) GlobalIds
1284         b) with an Internal Name (not External)
1285         c) and a tidied type
1286
1287  (a) They must be GlobalIds (not LocalIds) otherwise when we come to
1288      compile an expression using these ids later, the byte code
1289      generator will consider the occurrences to be free rather than
1290      global.
1291
1292  (b) They retain their Internal names becuase we don't have a suitable
1293      Module to name them with. We could revisit this choice.
1294
1295  (c) Their types are tidied. This is important, because :info may ask
1296      to look at them, and :info expects the things it looks up to have
1297      tidy types
1298
1299 --------------------------------------------------------------------------
1300                 Typechecking Stmts in GHCi
1301
1302 Here is the grand plan, implemented in tcUserStmt
1303
1304         What you type                   The IO [HValue] that hscStmt returns
1305         -------------                   ------------------------------------
1306         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
1307                                         bindings: [x,y,...]
1308
1309         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
1310                                         bindings: [x,y,...]
1311
1312         expr (of IO type)       ==>     expr >>= \ it -> return [coerce HVal it]
1313           [NB: result not printed]      bindings: [it]
1314
1315         expr (of non-IO type,   ==>     let it = expr in print it >> return [coerce HVal it]
1316           result showable)              bindings: [it]
1317
1318         expr (of non-IO type,
1319           result not showable)  ==>     error
1320
1321 \begin{code}
1322
1323 -- | A plan is an attempt to lift some code into the IO monad.
1324 type PlanResult = ([Id], LHsExpr Id)
1325 type Plan = TcM PlanResult
1326
1327 -- | Try the plans in order. If one fails (by raising an exn), try the next.
1328 -- If one succeeds, take it.
1329 runPlans :: [Plan] -> TcM PlanResult
1330 runPlans []     = panic "runPlans"
1331 runPlans [p]    = p
1332 runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
1333
1334 -- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the
1335 -- GHCi 'environemnt'.
1336 --
1337 -- By 'lift' and 'environment we mean that the code is changed to execute
1338 -- properly in an IO monad. See Note [Interactively-bound Ids in GHCi] above
1339 -- for more details. We do this lifting by trying different ways ('plans') of
1340 -- lifting the code into the IO monad and type checking each plan until one
1341 -- succeeds.
1342 tcUserStmt :: GhciLStmt RdrName -> TcM (PlanResult, FixityEnv)
1343
1344 -- An expression typed at the prompt is treated very specially
1345 tcUserStmt (L loc (BodyStmt expr _ _ _))
1346   = do  { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr)
1347                -- Don't try to typecheck if the renamer fails!
1348         ; ghciStep <- getGhciStepIO
1349         ; uniq <- newUnique
1350         ; interPrintName <- getInteractivePrintName
1351         ; let fresh_it  = itName uniq loc
1352               matches   = [mkMatch [] rn_expr emptyLocalBinds]
1353               -- [it = expr]
1354               the_bind  = L loc $ (mkTopFunBind (L loc fresh_it) matches) { bind_fvs = fvs }
1355                           -- Care here!  In GHCi the expression might have
1356                           -- free variables, and they in turn may have free type variables
1357                           -- (if we are at a breakpoint, say).  We must put those free vars
1358
1359               -- [let it = expr]
1360               let_stmt  = L loc $ LetStmt $ HsValBinds $
1361                           ValBindsOut [(NonRecursive,unitBag the_bind)] []
1362
1363               -- [it <- e]
1364               bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it))
1365                                            (nlHsApp ghciStep rn_expr)
1366                                            (HsVar bindIOName) noSyntaxExpr
1367
1368               -- [; print it]
1369               print_it  = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it))
1370                                            (HsVar thenIOName) noSyntaxExpr placeHolderType
1371
1372         -- The plans are:
1373         --   A. [it <- e; print it]     but not if it::()
1374         --   B. [it <- e]
1375         --   C. [let it = e; print it]
1376         --
1377         -- Ensure that type errors don't get deferred when type checking the
1378         -- naked expression. Deferring type errors here is unhelpful because the
1379         -- expression gets evaluated right away anyway. It also would potentially
1380         -- emit two redundant type-error warnings, one from each plan.
1381         ; plan <- unsetGOptM Opt_DeferTypeErrors $ runPlans [
1382                     -- Plan A
1383                     do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
1384                        ; it_ty <- zonkTcType (idType it_id)
1385                        ; when (isUnitTy $ it_ty) failM
1386                        ; return stuff },
1387
1388                         -- Plan B; a naked bind statment
1389                     tcGhciStmts [bind_stmt],
1390
1391                         -- Plan C; check that the let-binding is typeable all by itself.
1392                         -- If not, fail; if so, try to print it.
1393                         -- The two-step process avoids getting two errors: one from
1394                         -- the expression itself, and one from the 'print it' part
1395                         -- This two-step story is very clunky, alas
1396                     do { _ <- checkNoErrs (tcGhciStmts [let_stmt])
1397                                 --- checkNoErrs defeats the error recovery of let-bindings
1398                        ; tcGhciStmts [let_stmt, print_it] } ]
1399
1400         ; fix_env <- getFixityEnv
1401         ; return (plan, fix_env) }
1402
1403 tcUserStmt rdr_stmt@(L loc _)
1404   = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $
1405            rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do
1406              fix_env <- getFixityEnv
1407              return (fix_env, emptyFVs)
1408             -- Don't try to typecheck if the renamer fails!
1409        ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])
1410        ; rnDump (ppr rn_stmt) ;
1411
1412        ; ghciStep <- getGhciStepIO
1413        ; let gi_stmt
1414                | (L loc (BindStmt pat expr op1 op2)) <- rn_stmt
1415                            = L loc $ BindStmt pat (nlHsApp ghciStep expr) op1 op2
1416                | otherwise = rn_stmt
1417
1418        ; opt_pr_flag <- goptM Opt_PrintBindResult
1419        ; let print_result_plan
1420                | opt_pr_flag                         -- The flag says "print result"   
1421                , [v] <- collectLStmtBinders gi_stmt  -- One binder
1422                            =  [mk_print_result_plan gi_stmt v]
1423                | otherwise = []
1424
1425         -- The plans are:
1426         --      [stmt; print v]         if one binder and not v::()
1427         --      [stmt]                  otherwise
1428        ; plan <- runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]])
1429        ; return (plan, fix_env) }
1430   where
1431     mk_print_result_plan stmt v
1432       = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
1433            ; v_ty <- zonkTcType (idType v_id)
1434            ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM
1435            ; return stuff }
1436       where
1437         print_v  = L loc $ BodyStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
1438                                     (HsVar thenIOName) noSyntaxExpr placeHolderType
1439
1440 -- | Typecheck the statements given and then return the results of the
1441 -- statement in the form 'IO [()]'.
1442 tcGhciStmts :: [GhciLStmt Name] -> TcM PlanResult
1443 tcGhciStmts stmts
1444  = do { ioTyCon <- tcLookupTyCon ioTyConName ;
1445         ret_id  <- tcLookupId returnIOName ;            -- return @ IO
1446         let {
1447             ret_ty      = mkListTy unitTy ;
1448             io_ret_ty   = mkTyConApp ioTyCon [ret_ty] ;
1449             tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts io_ret_ty ;
1450             names = collectLStmtsBinders stmts ;
1451          } ;
1452
1453         -- OK, we're ready to typecheck the stmts
1454         traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
1455         ((tc_stmts, ids), lie) <- captureConstraints $
1456                                   tc_io_stmts $ \ _ ->
1457                                   mapM tcLookupId names  ;
1458                         -- Look up the names right in the middle,
1459                         -- where they will all be in scope
1460
1461         -- Simplify the context
1462         traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
1463         const_binds <- checkNoErrs (simplifyInteractive lie) ;
1464                 -- checkNoErrs ensures that the plan fails if context redn fails
1465
1466         traceTc "TcRnDriver.tcGhciStmts: done" empty ;
1467         let {   -- mk_return builds the expression
1468                 --      returnIO @ [()] [coerce () x, ..,  coerce () z]
1469                 --
1470                 -- Despite the inconvenience of building the type applications etc,
1471                 -- this *has* to be done in type-annotated post-typecheck form
1472                 -- because we are going to return a list of *polymorphic* values
1473                 -- coerced to type (). If we built a *source* stmt
1474                 --      return [coerce x, ..., coerce z]
1475                 -- then the type checker would instantiate x..z, and we wouldn't
1476                 -- get their *polymorphic* values.  (And we'd get ambiguity errs
1477                 -- if they were overloaded, since they aren't applied to anything.)
1478             ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty])
1479                        (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
1480             mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
1481                                  (nlHsVar id) ;
1482             stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
1483         } ;
1484         return (ids, mkHsDictLet (EvBinds const_binds) $
1485                      noLoc (HsDo GhciStmtCtxt stmts io_ret_ty))
1486     }
1487
1488 -- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)
1489 getGhciStepIO :: TcM (LHsExpr Name)
1490 getGhciStepIO = do
1491     ghciTy <- getGHCiMonad
1492     fresh_a <- newUnique
1493     let a_tv   = mkTcTyVarName fresh_a (fsLit "a")
1494         ghciM  = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)
1495         ioM    = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
1496
1497         stepTy :: LHsType Name    -- Renamed, so needs all binders in place
1498         stepTy = noLoc $ HsForAllTy Implicit
1499                             (HsQTvs { hsq_tvs = [noLoc (UserTyVar a_tv)]
1500                                     , hsq_kvs = [] })
1501                             (noLoc [])
1502                             (nlHsFunTy ghciM ioM)
1503         step   = noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy
1504     return step
1505
1506 isGHCiMonad :: HscEnv -> InteractiveContext -> String -> IO (Messages, Maybe Name)
1507 isGHCiMonad hsc_env ictxt ty
1508   = initTcPrintErrors hsc_env iNTERACTIVE $
1509     setInteractiveContext hsc_env ictxt $ do
1510         rdrEnv <- getGlobalRdrEnv
1511         let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty)
1512         case occIO of
1513             Just [n] -> do
1514                 let name = gre_name n
1515                 ghciClass <- tcLookupClass ghciIoClassName 
1516                 userTyCon <- tcLookupTyCon name
1517                 let userTy = TyConApp userTyCon []
1518                 _ <- tcLookupInstance ghciClass [userTy]
1519                 return name
1520
1521             Just _  -> failWithTc $ text "Ambigous type!"
1522             Nothing -> failWithTc $ text ("Can't find type:" ++ ty)
1523
1524 \end{code}
1525
1526 tcRnExpr just finds the type of an expression
1527
1528 \begin{code}
1529 tcRnExpr :: HscEnv
1530          -> InteractiveContext
1531          -> LHsExpr RdrName
1532          -> IO (Messages, Maybe Type)
1533 -- Type checks the expression and returns its most general type
1534 tcRnExpr hsc_env ictxt rdr_expr
1535   = initTcPrintErrors hsc_env iNTERACTIVE $
1536     setInteractiveContext hsc_env ictxt $ do {
1537
1538     (rn_expr, _fvs) <- rnLExpr rdr_expr ;
1539     failIfErrsM ;
1540
1541         -- Now typecheck the expression;
1542         -- it might have a rank-2 type (e.g. :t runST)
1543     uniq <- newUnique ;
1544     let { fresh_it  = itName uniq (getLoc rdr_expr) } ;
1545     ((_tc_expr, res_ty), lie) <- captureConstraints $ 
1546                                  tcInferRho rn_expr ;
1547     ((qtvs, dicts, _, _), lie_top) <- captureConstraints $
1548                                       {-# SCC "simplifyInfer" #-}
1549                                       simplifyInfer True {- Free vars are closed -}
1550                                                     False {- No MR for now -}
1551                                                     [(fresh_it, res_ty)]
1552                                                     lie ;
1553     _ <- simplifyInteractive lie_top ;       -- Ignore the dicionary bindings
1554
1555     let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
1556     zonkTcType all_expr_ty
1557     }
1558
1559 --------------------------
1560 tcRnImportDecls :: HscEnv
1561                 -> [LImportDecl RdrName]
1562                 -> IO (Messages, Maybe GlobalRdrEnv)
1563 tcRnImportDecls hsc_env import_decls
1564  =  initTcPrintErrors hsc_env iNTERACTIVE $
1565     do { gbl_env <- tcRnImports hsc_env iNTERACTIVE import_decls
1566        ; return (tcg_rdr_env gbl_env) }
1567 \end{code}
1568
1569 tcRnType just finds the kind of a type
1570
1571 \begin{code}
1572 tcRnType :: HscEnv
1573          -> InteractiveContext
1574          -> Bool        -- Normalise the returned type
1575          -> LHsType RdrName
1576          -> IO (Messages, Maybe (Type, Kind))
1577 tcRnType hsc_env ictxt normalise rdr_type
1578   = initTcPrintErrors hsc_env iNTERACTIVE $
1579     setInteractiveContext hsc_env ictxt $ do {
1580
1581     (rn_type, _fvs) <- rnLHsType GHCiCtx rdr_type ;
1582     failIfErrsM ;
1583
1584         -- Now kind-check the type
1585         -- It can have any rank or kind
1586     ty <- tcHsSigType GhciCtxt rn_type ;
1587
1588     ty' <- if normalise
1589            then do { fam_envs <- tcGetFamInstEnvs
1590                    ; return (snd (normaliseType fam_envs ty)) }
1591                    -- normaliseType returns a coercion
1592                    -- which we discard
1593            else return ty ;
1594
1595     return (ty', typeKind ty)
1596     }
1597
1598 \end{code}
1599
1600 tcRnDeclsi exists to allow class, data, and other declarations in GHCi.
1601
1602 \begin{code}
1603 tcRnDeclsi :: HscEnv
1604            -> InteractiveContext
1605            -> [LHsDecl RdrName]
1606            -> IO (Messages, Maybe TcGblEnv)
1607
1608 tcRnDeclsi hsc_env ictxt local_decls =
1609     initTcPrintErrors hsc_env iNTERACTIVE $
1610     setInteractiveContext hsc_env ictxt $ do
1611
1612     ((tcg_env, tclcl_env), lie) <-
1613         captureConstraints $ tc_rn_src_decls emptyModDetails local_decls
1614     setEnvs (tcg_env, tclcl_env) $ do
1615
1616     new_ev_binds <- simplifyTop lie
1617     failIfErrsM
1618     let TcGblEnv { tcg_type_env  = type_env,
1619                    tcg_binds     = binds,
1620                    tcg_sigs      = sig_ns,
1621                    tcg_ev_binds  = cur_ev_binds,
1622                    tcg_imp_specs = imp_specs,
1623                    tcg_rules     = rules,
1624                    tcg_vects     = vects,
1625                    tcg_fords     = fords } = tcg_env
1626         all_ev_binds = cur_ev_binds `unionBags` new_ev_binds
1627
1628     (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
1629         <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords
1630
1631     let --global_ids = map globaliseAndTidyId bind_ids
1632         final_type_env = extendTypeEnvWithIds type_env bind_ids --global_ids
1633         tcg_env' = tcg_env { tcg_binds     = binds',
1634                              tcg_ev_binds  = ev_binds',
1635                              tcg_imp_specs = imp_specs',
1636                              tcg_rules     = rules',
1637                              tcg_vects     = vects',
1638                              tcg_fords     = fords' }
1639
1640     tcg_env'' <- setGlobalTypeEnv tcg_env' final_type_env
1641
1642     traceTc "returning from tcRnDeclsi: " $ ppr $ nameEnvElts $ tcg_type_env tcg_env'' -- RAE
1643
1644     return tcg_env''
1645
1646
1647 #endif /* GHCi */
1648 \end{code}
1649
1650
1651 %************************************************************************
1652 %*                                                                      *
1653         More GHCi stuff, to do with browsing and getting info
1654 %*                                                                      *
1655 %************************************************************************
1656
1657 \begin{code}
1658 #ifdef GHCI
1659 -- | ASSUMES that the module is either in the 'HomePackageTable' or is
1660 -- a package module with an interface on disk.  If neither of these is
1661 -- true, then the result will be an error indicating the interface
1662 -- could not be found.
1663 getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface)
1664 getModuleInterface hsc_env mod
1665   = initTc hsc_env HsSrcFile False iNTERACTIVE $
1666     loadModuleInterface (ptext (sLit "getModuleInterface")) mod
1667
1668 tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name])
1669 tcRnLookupRdrName hsc_env rdr_name
1670   = initTcPrintErrors hsc_env iNTERACTIVE $
1671     setInteractiveContext hsc_env (hsc_IC hsc_env) $
1672     lookup_rdr_name rdr_name
1673
1674 lookup_rdr_name :: RdrName -> TcM [Name]
1675 lookup_rdr_name rdr_name = do
1676         -- If the identifier is a constructor (begins with an
1677         -- upper-case letter), then we need to consider both
1678         -- constructor and type class identifiers.
1679     let rdr_names = dataTcOccs rdr_name
1680
1681         -- results :: [Either Messages Name]
1682     results <- mapM (tryTcErrs . lookupOccRn) rdr_names
1683
1684     traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)])
1685         -- The successful lookups will be (Just name)
1686     let (warns_s, good_names) = unzip [ (msgs, name)
1687                                       | (msgs, Just name) <- results]
1688         errs_s = [msgs | (msgs, Nothing) <- results]
1689
1690         -- Fail if nothing good happened, else add warnings
1691     if null good_names
1692       then  addMessages (head errs_s) >> failM
1693                 -- No lookup succeeded, so
1694                 -- pick the first error message and report it
1695                 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
1696                 --       while the other is "X is not in scope",
1697                 --       we definitely want the former; but we might pick the latter
1698       else      mapM_ addMessages warns_s
1699                 -- Add deprecation warnings
1700     return good_names
1701
1702 #endif
1703
1704 tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
1705 tcRnLookupName hsc_env name
1706   = initTcPrintErrors hsc_env iNTERACTIVE $
1707     setInteractiveContext hsc_env (hsc_IC hsc_env) $
1708     tcRnLookupName' name
1709
1710 -- To look up a name we have to look in the local environment (tcl_lcl)
1711 -- as well as the global environment, which is what tcLookup does.
1712 -- But we also want a TyThing, so we have to convert:
1713
1714 tcRnLookupName' :: Name -> TcRn TyThing
1715 tcRnLookupName' name = do
1716    tcthing <- tcLookup name
1717    case tcthing of
1718      AGlobal thing    -> return thing
1719      ATcId{tct_id=id} -> return (AnId id)
1720      _ -> panic "tcRnLookupName'"
1721
1722 tcRnGetInfo :: HscEnv
1723             -> Name
1724             -> IO (Messages, Maybe (TyThing, Fixity, [ClsInst]))
1725
1726 -- Used to implement :info in GHCi
1727 --
1728 -- Look up a RdrName and return all the TyThings it might be
1729 -- A capitalised RdrName is given to us in the DataName namespace,
1730 -- but we want to treat it as *both* a data constructor
1731 --  *and* as a type or class constructor;
1732 -- hence the call to dataTcOccs, and we return up to two results
1733 tcRnGetInfo hsc_env name
1734   = let ictxt = hsc_IC hsc_env in
1735     initTcPrintErrors hsc_env iNTERACTIVE $
1736     setInteractiveContext hsc_env ictxt  $ do
1737
1738         -- Load the interface for all unqualified types and classes
1739         -- That way we will find all the instance declarations
1740         -- (Packages have not orphan modules, and we assume that
1741         --  in the home package all relevant modules are loaded.)
1742     loadUnqualIfaces hsc_env ictxt
1743
1744     thing  <- tcRnLookupName' name
1745     fixity <- lookupFixityRn name
1746     ispecs <- lookupInsts thing
1747     return (thing, fixity, ispecs)
1748
1749 lookupInsts :: TyThing -> TcM [ClsInst]
1750 lookupInsts (ATyCon tc)
1751   | Just cls <- tyConClass_maybe tc
1752   = do  { inst_envs <- tcGetInstEnvs
1753         ; return (classInstances inst_envs cls) }
1754
1755   | otherwise
1756   = do  { (pkg_ie, home_ie) <- tcGetInstEnvs
1757                 -- Load all instances for all classes that are
1758                 -- in the type environment (which are all the ones
1759                 -- we've seen in any interface file so far)
1760         ; return [ ispec        -- Search all
1761                  | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
1762                  , let dfun = instanceDFunId ispec
1763                  , relevant dfun ] }
1764   where
1765     relevant df = tc_name `elemNameSet` orphNamesOfDFunHead (idType df)
1766     tc_name     = tyConName tc
1767
1768 lookupInsts _ = return []
1769
1770 loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM ()
1771 -- Load the interface for everything that is in scope unqualified
1772 -- This is so that we can accurately report the instances for
1773 -- something
1774 loadUnqualIfaces hsc_env ictxt
1775   = initIfaceTcRn $ do
1776     mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
1777   where
1778     this_pkg = thisPackage (hsc_dflags hsc_env)
1779
1780     unqual_mods = filter ((/= this_pkg) . modulePackageId)
1781                   [ nameModule name
1782                   | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt),
1783                     let name = gre_name gre,
1784                     not (isInternalName name),
1785                     isTcOcc (nameOccName name),  -- Types and classes only
1786                     unQualOK gre ]               -- In scope unqualified
1787     doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified")
1788 \end{code}
1789
1790 %************************************************************************
1791 %*                                                                      *
1792                 Degugging output
1793 %*                                                                      *
1794 %************************************************************************
1795
1796 \begin{code}
1797 rnDump :: SDoc -> TcRn ()
1798 -- Dump, with a banner, if -ddump-rn
1799 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1800
1801 tcDump :: TcGblEnv -> TcRn ()
1802 tcDump env
1803  = do { dflags <- getDynFlags ;
1804
1805         -- Dump short output if -ddump-types or -ddump-tc
1806         when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1807              (dumpTcRn short_dump) ;
1808
1809         -- Dump bindings if -ddump-tc
1810         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1811    }
1812   where
1813     short_dump = pprTcGblEnv env
1814     full_dump  = pprLHsBinds (tcg_binds env)
1815         -- NB: foreign x-d's have undefined's in their types;
1816         --     hence can't show the tc_fords
1817
1818 tcCoreDump :: ModGuts -> TcM ()
1819 tcCoreDump mod_guts
1820  = do { dflags <- getDynFlags ;
1821         when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1822              (dumpTcRn (pprModGuts mod_guts)) ;
1823
1824         -- Dump bindings if -ddump-tc
1825         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1826   where
1827     full_dump = pprCoreBindings (mg_binds mod_guts)
1828
1829 -- It's unpleasant having both pprModGuts and pprModDetails here
1830 pprTcGblEnv :: TcGblEnv -> SDoc
1831 pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,
1832                         tcg_insts     = insts,
1833                         tcg_fam_insts = fam_insts,
1834                         tcg_rules     = rules,
1835                         tcg_vects     = vects,
1836                         tcg_imports   = imports })
1837   = vcat [ ppr_types insts type_env
1838          , ppr_tycons fam_insts type_env
1839          , ppr_insts insts
1840          , ppr_fam_insts fam_insts
1841          , vcat (map ppr rules)
1842          , vcat (map ppr vects)
1843          , ptext (sLit "Dependent modules:") <+>
1844                 ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
1845          , ptext (sLit "Dependent packages:") <+>
1846                 ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)]
1847   where         -- The two uses of sortBy are just to reduce unnecessary
1848                 -- wobbling in testsuite output
1849     cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2)
1850         = (mod_name1 `stableModuleNameCmp` mod_name2)
1851                   `thenCmp`
1852           (is_boot1 `compare` is_boot2)
1853
1854 pprModGuts :: ModGuts -> SDoc
1855 pprModGuts (ModGuts { mg_tcs = tcs
1856                     , mg_rules = rules })
1857   = vcat [ ppr_types [] (mkTypeEnv (map ATyCon tcs)),
1858            ppr_rules rules ]
1859
1860 ppr_types :: [ClsInst] -> TypeEnv -> SDoc
1861 ppr_types insts type_env
1862   = text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids)
1863   where
1864     dfun_ids = map instanceDFunId insts
1865     ids = [id | id <- typeEnvIds type_env, want_sig id]
1866     want_sig id | opt_PprStyle_Debug = True
1867                 | otherwise          = isLocalId id &&
1868                                        isExternalName (idName id) &&
1869                                        not (id `elem` dfun_ids)
1870         -- isLocalId ignores data constructors, records selectors etc.
1871         -- The isExternalName ignores local dictionary and method bindings
1872         -- that the type checker has invented.  Top-level user-defined things
1873         -- have External names.
1874
1875 ppr_tycons :: [FamInst br] -> TypeEnv -> SDoc
1876 ppr_tycons fam_insts type_env
1877   = vcat [ text "TYPE CONSTRUCTORS"
1878          ,   nest 2 (ppr_tydecls tycons)
1879          , text "COERCION AXIOMS"
1880          ,   nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ]
1881   where
1882     fi_tycons = famInstsRepTyCons fam_insts
1883     tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
1884     want_tycon tycon | opt_PprStyle_Debug = True
1885                      | otherwise          = not (isImplicitTyCon tycon) &&
1886                                             isExternalName (tyConName tycon) &&
1887                                             not (tycon `elem` fi_tycons)
1888
1889 ppr_insts :: [ClsInst] -> SDoc
1890 ppr_insts []     = empty
1891 ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
1892
1893 ppr_fam_insts :: [FamInst br] -> SDoc
1894 ppr_fam_insts []        = empty
1895 ppr_fam_insts fam_insts =
1896   text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts)
1897
1898 ppr_sigs :: [Var] -> SDoc
1899 ppr_sigs ids
1900         -- Print type signatures; sort by OccName
1901   = vcat (map ppr_sig (sortBy (comparing getOccName) ids))
1902   where
1903     ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id)))
1904
1905 ppr_tydecls :: [TyCon] -> SDoc
1906 ppr_tydecls tycons
1907         -- Print type constructor info; sort by OccName
1908   = vcat (map ppr_tycon (sortBy (comparing getOccName) tycons))
1909   where
1910     ppr_tycon tycon = vcat [ ppr (tyConName tycon) <+> dcolon <+> ppr (tyConKind tycon)
1911                               -- Temporarily print the kind signature too
1912                            , ppr (tyThingToIfaceDecl (ATyCon tycon)) ]
1913
1914 ppr_rules :: [CoreRule] -> SDoc
1915 ppr_rules [] = empty
1916 ppr_rules rs = vcat [ptext (sLit "{-# RULES"),
1917                       nest 2 (pprRules rs),
1918                       ptext (sLit "#-}")]
1919 \end{code}