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