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