PostTcType replaced with TypeAnnot
[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         boot_details
549   | isHsBoot hs_src     -- Current module is already a hs-boot file!
550   = return tcg_env
551
552   | otherwise
553   = do  { mb_dfun_prs <- checkHiBootIface' local_insts local_type_env
554                                            local_exports boot_details
555         ; let dfun_prs   = catMaybes mb_dfun_prs
556               boot_dfuns = map fst dfun_prs
557               dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
558                                      | (boot_dfun, dfun) <- dfun_prs ]
559               type_env'  = extendTypeEnvWithIds local_type_env boot_dfuns
560               tcg_env'   = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
561
562         ; setGlobalTypeEnv tcg_env' type_env' }
563              -- Update the global type env *including* the knot-tied one
564              -- so that if the source module reads in an interface unfolding
565              -- mentioning one of the dfuns from the boot module, then it
566              -- can "see" that boot dfun.   See Trac #4003
567
568 checkHiBootIface' :: [ClsInst] -> TypeEnv -> [AvailInfo]
569                   -> ModDetails -> TcM [Maybe (Id, Id)]
570 -- Variant which doesn't require a full TcGblEnv; you could get the
571 -- local components from another ModDetails.
572
573 checkHiBootIface'
574         local_insts local_type_env local_exports
575         (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
576                       md_types = boot_type_env, md_exports = boot_exports })
577   = do  { traceTc "checkHiBootIface" $ vcat
578              [ ppr boot_type_env, ppr boot_insts, ppr boot_exports]
579
580                 -- Check the exports of the boot module, one by one
581         ; mapM_ check_export boot_exports
582
583                 -- Check for no family instances
584         ; unless (null boot_fam_insts) $
585             panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
586                    "instances in boot files yet...")
587             -- FIXME: Why?  The actual comparison is not hard, but what would
588             --        be the equivalent to the dfun bindings returned for class
589             --        instances?  We can't easily equate tycons...
590
591                 -- Check instance declarations
592         ; mb_dfun_prs <- mapM check_inst boot_insts
593
594         ; failIfErrsM
595
596         ; return mb_dfun_prs }
597
598   where
599     check_export boot_avail     -- boot_avail is exported by the boot iface
600       | name `elem` dfun_names = return ()
601       | isWiredInName name     = return ()      -- No checking for wired-in names.  In particular,
602                                                 -- 'error' is handled by a rather gross hack
603                                                 -- (see comments in GHC.Err.hs-boot)
604
605         -- Check that the actual module exports the same thing
606       | not (null missing_names)
607       = addErrAt (nameSrcSpan (head missing_names))
608                  (missingBootThing (head missing_names) "exported by")
609
610         -- If the boot module does not *define* the thing, we are done
611         -- (it simply re-exports it, and names match, so nothing further to do)
612       | isNothing mb_boot_thing = return ()
613
614         -- Check that the actual module also defines the thing, and
615         -- then compare the definitions
616       | Just real_thing <- lookupTypeEnv local_type_env name,
617         Just boot_thing <- mb_boot_thing
618       = when (not (checkBootDecl boot_thing real_thing))
619             $ addErrAt (nameSrcSpan (getName boot_thing))
620                        (bootMisMatch real_thing boot_thing)
621
622       | otherwise
623       = addErrTc (missingBootThing name "defined in")
624       where
625         name          = availName boot_avail
626         mb_boot_thing = lookupTypeEnv boot_type_env name
627         missing_names = case lookupNameEnv local_export_env name of
628                           Nothing    -> [name]
629                           Just avail -> availNames boot_avail `minusList` availNames avail
630
631     dfun_names = map getName boot_insts
632
633     local_export_env :: NameEnv AvailInfo
634     local_export_env = availsToNameEnv local_exports
635
636     check_inst :: ClsInst -> TcM (Maybe (Id, Id))
637         -- Returns a pair of the boot dfun in terms of the equivalent real dfun
638     check_inst boot_inst
639         = case [dfun | inst <- local_insts,
640                        let dfun = instanceDFunId inst,
641                        idType dfun `eqType` boot_inst_ty ] of
642             [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts)
643                                                   , text "boot_inst"   <+> ppr boot_inst
644                                                   , text "boot_inst_ty" <+> ppr boot_inst_ty
645                                                   ])
646                      ; addErrTc (instMisMatch boot_inst); return Nothing }
647             (dfun:_) -> return (Just (local_boot_dfun, dfun))
648         where
649           boot_dfun = instanceDFunId boot_inst
650           boot_inst_ty = idType boot_dfun
651           local_boot_dfun = Id.mkExportedLocalId VanillaId (idName boot_dfun) boot_inst_ty
652
653
654 -- This has to compare the TyThing from the .hi-boot file to the TyThing
655 -- in the current source file.  We must be careful to allow alpha-renaming
656 -- where appropriate, and also the boot declaration is allowed to omit
657 -- constructors and class methods.
658 --
659 -- See rnfail055 for a good test of this stuff.
660
661 checkBootDecl :: TyThing -> TyThing -> Bool
662
663 checkBootDecl (AnId id1) (AnId id2)
664   = ASSERT(id1 == id2)
665     (idType id1 `eqType` idType id2)
666
667 checkBootDecl (ATyCon tc1) (ATyCon tc2)
668   = checkBootTyCon tc1 tc2
669
670 checkBootDecl (AConLike (RealDataCon dc1)) (AConLike (RealDataCon _))
671   = pprPanic "checkBootDecl" (ppr dc1)
672
673 checkBootDecl _ _ = False -- probably shouldn't happen
674
675 ----------------
676 checkBootTyCon :: TyCon -> TyCon -> Bool
677 checkBootTyCon tc1 tc2
678   | not (eqKind (tyConKind tc1) (tyConKind tc2))
679   = False       -- First off, check the kind
680
681   | Just c1 <- tyConClass_maybe tc1
682   , Just c2 <- tyConClass_maybe tc2
683   , let (clas_tvs1, clas_fds1, sc_theta1, _, ats1, op_stuff1)
684           = classExtraBigSig c1
685         (clas_tvs2, clas_fds2, sc_theta2, _, ats2, op_stuff2)
686           = classExtraBigSig c2
687   , Just env <- eqTyVarBndrs emptyRnEnv2 clas_tvs1 clas_tvs2
688   = let
689        eqSig (id1, def_meth1) (id2, def_meth2)
690          = idName id1 == idName id2 &&
691            eqTypeX env op_ty1 op_ty2 &&
692            def_meth1 == def_meth2
693          where
694           (_, rho_ty1) = splitForAllTys (idType id1)
695           op_ty1 = funResultTy rho_ty1
696           (_, rho_ty2) = splitForAllTys (idType id2)
697           op_ty2 = funResultTy rho_ty2
698
699        eqAT (ATI tc1 def_ats1) (ATI tc2 def_ats2)
700          = checkBootTyCon tc1 tc2 &&
701            eqATDef def_ats1 def_ats2
702
703        -- Ignore the location of the defaults
704        eqATDef Nothing    Nothing    = True
705        eqATDef (Just ty1) (Just ty2) = eqTypeX env ty1 ty2
706        eqATDef _ _ = False           
707
708        eqFD (as1,bs1) (as2,bs2) =
709          eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
710          eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
711     in
712        roles1 == roles2 &&
713              -- Checks kind of class
714        eqListBy eqFD clas_fds1 clas_fds2 &&
715        (null sc_theta1 && null op_stuff1 && null ats1
716         ||   -- Above tests for an "abstract" class
717         eqListBy (eqPredX env) sc_theta1 sc_theta2 &&
718         eqListBy eqSig op_stuff1 op_stuff2 &&
719         eqListBy eqAT ats1 ats2)
720
721   | Just syn_rhs1 <- synTyConRhs_maybe tc1
722   , Just syn_rhs2 <- synTyConRhs_maybe tc2
723   , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
724   = ASSERT(tc1 == tc2)
725     let eqSynRhs OpenSynFamilyTyCon OpenSynFamilyTyCon = True
726         eqSynRhs AbstractClosedSynFamilyTyCon (ClosedSynFamilyTyCon {}) = True
727         eqSynRhs (ClosedSynFamilyTyCon {}) AbstractClosedSynFamilyTyCon = True
728         eqSynRhs (ClosedSynFamilyTyCon ax1) (ClosedSynFamilyTyCon ax2)
729             = eqClosedFamilyAx ax1 ax2
730         eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
731             = eqTypeX env t1 t2
732         eqSynRhs (BuiltInSynFamTyCon _) (BuiltInSynFamTyCon _) = tc1 == tc2
733         eqSynRhs _ _ = False
734     in
735     roles1 == roles2 &&
736     eqSynRhs syn_rhs1 syn_rhs2
737
738   | isAlgTyCon tc1 && isAlgTyCon tc2
739   , Just env <- eqTyVarBndrs emptyRnEnv2 (tyConTyVars tc1) (tyConTyVars tc2)
740   = ASSERT(tc1 == tc2)
741     roles1 == roles2 &&
742     eqListBy (eqPredX env) (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
743     eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
744
745   | isForeignTyCon tc1 && isForeignTyCon tc2
746   = eqKind (tyConKind tc1) (tyConKind tc2) &&
747     tyConExtName tc1 == tyConExtName tc2
748
749   | otherwise = False
750   where
751     roles1 = tyConRoles tc1
752     roles2 = tyConRoles tc2
753
754     eqAlgRhs (AbstractTyCon dis1) rhs2
755       | dis1      = isDistinctAlgRhs rhs2   --Check compatibility
756       | otherwise = True
757     eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True
758     eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} =
759         eqListBy eqCon (data_cons tc1) (data_cons tc2)
760     eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} =
761         eqCon (data_con tc1) (data_con tc2)
762     eqAlgRhs _ _ = False
763
764     eqCon c1 c2
765       =  dataConName c1 == dataConName c2
766       && dataConIsInfix c1 == dataConIsInfix c2
767       && eqListBy eqHsBang (dataConStrictMarks c1) (dataConStrictMarks c2)
768       && dataConFieldLabels c1 == dataConFieldLabels c2
769       && eqType (dataConUserType c1) (dataConUserType c2)
770
771     eqClosedFamilyAx (CoAxiom { co_ax_branches = branches1 })
772                      (CoAxiom { co_ax_branches = branches2 })
773       =  brListLength branches1 == brListLength branches2
774       && (and $ brListZipWith eqClosedFamilyBranch branches1 branches2)
775
776     eqClosedFamilyBranch (CoAxBranch { cab_tvs = tvs1, cab_lhs = lhs1, cab_rhs = rhs1 })
777                          (CoAxBranch { cab_tvs = tvs2, cab_lhs = lhs2, cab_rhs = rhs2 })
778       | Just env <- eqTyVarBndrs emptyRnEnv2 tvs1 tvs2
779       = eqListBy (eqTypeX env) lhs1 lhs2 &&
780         eqTypeX env rhs1 rhs2
781
782       | otherwise = False
783
784 emptyRnEnv2 :: RnEnv2
785 emptyRnEnv2 = mkRnEnv2 emptyInScopeSet
786
787 ----------------
788 missingBootThing :: Name -> String -> SDoc
789 missingBootThing name what
790   = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not")
791               <+> text what <+> ptext (sLit "the module")
792
793 bootMisMatch :: TyThing -> TyThing -> SDoc
794 bootMisMatch real_thing boot_thing
795   = vcat [ppr real_thing <+>
796           ptext (sLit "has conflicting definitions in the module"),
797           ptext (sLit "and its hs-boot file"),
798           ptext (sLit "Main module:") <+> PprTyThing.pprTyThing real_thing,
799           ptext (sLit "Boot file:  ") <+> PprTyThing.pprTyThing boot_thing]
800
801 instMisMatch :: ClsInst -> SDoc
802 instMisMatch inst
803   = hang (ppr inst)
804        2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself"))
805 \end{code}
806
807
808 %************************************************************************
809 %*                                                                      *
810         Type-checking the top level of a module
811 %*                                                                      *
812 %************************************************************************
813
814 tcRnGroup takes a bunch of top-level source-code declarations, and
815  * renames them
816  * gets supporting declarations from interface files
817  * typechecks them
818  * zonks them
819  * and augments the TcGblEnv with the results
820
821 In Template Haskell it may be called repeatedly for each group of
822 declarations.  It expects there to be an incoming TcGblEnv in the
823 monad; it augments it and returns the new TcGblEnv.
824
825 \begin{code}
826 ------------------------------------------------
827 rnTopSrcDecls :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
828 -- Fails if there are any errors
829 rnTopSrcDecls extra_deps group
830  = do { -- Rename the source decls
831         traceTc "rn12" empty ;
832         (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls extra_deps group ;
833         traceTc "rn13" empty ;
834
835         -- save the renamed syntax, if we want it
836         let { tcg_env'
837                 | Just grp <- tcg_rn_decls tcg_env
838                   = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
839                 | otherwise
840                    = tcg_env };
841
842                 -- Dump trace of renaming part
843         rnDump (ppr rn_decls) ;
844
845         return (tcg_env', rn_decls)
846    }
847 \end{code}
848
849
850 %************************************************************************
851 %*                                                                      *
852                 tcTopSrcDecls
853 %*                                                                      *
854 %************************************************************************
855
856
857 \begin{code}
858 tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
859 tcTopSrcDecls boot_details
860         (HsGroup { hs_tyclds = tycl_decls,
861                    hs_instds = inst_decls,
862                    hs_derivds = deriv_decls,
863                    hs_fords  = foreign_decls,
864                    hs_defds  = default_decls,
865                    hs_annds  = annotation_decls,
866                    hs_ruleds = rule_decls,
867                    hs_vects  = vect_decls,
868                    hs_valds  = val_binds })
869  = do {         -- Type-check the type and class decls, and all imported decls
870                 -- The latter come in via tycl_decls
871         traceTc "Tc2 (src)" empty ;
872
873                 -- Source-language instances, including derivings,
874                 -- and import the supporting declarations
875         traceTc "Tc3" empty ;
876         (tcg_env, inst_infos, deriv_binds)
877             <- tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls ;
878         setGblEnv tcg_env       $ do {
879
880
881                 -- Generate Applicative/Monad proposal (AMP) warnings
882         traceTc "Tc3b" empty ;
883
884                 -- Foreign import declarations next.
885         traceTc "Tc4" empty ;
886         (fi_ids, fi_decls, fi_gres) <- tcForeignImports foreign_decls ;
887         tcExtendGlobalValEnv fi_ids     $ do {
888
889                 -- Default declarations
890         traceTc "Tc4a" empty ;
891         default_tys <- tcDefaults default_decls ;
892         updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
893
894                 -- Now GHC-generated derived bindings, generics, and selectors
895                 -- Do not generate warnings from compiler-generated code;
896                 -- hence the use of discardWarnings
897         tc_envs <- discardWarnings (tcTopBinds deriv_binds) ;
898         setEnvs tc_envs $ do {
899
900                 -- Value declarations next
901         traceTc "Tc5" empty ;
902         tc_envs@(tcg_env, tcl_env) <- tcTopBinds val_binds;
903         setEnvs tc_envs $ do {  -- Environment doesn't change now
904
905                 -- Second pass over class and instance declarations,
906                 -- now using the kind-checked decls
907         traceTc "Tc6" empty ;
908         inst_binds <- tcInstDecls2 (tyClGroupConcat tycl_decls) inst_infos ;
909
910                 -- Foreign exports
911         traceTc "Tc7" empty ;
912         (foe_binds, foe_decls, foe_gres) <- tcForeignExports foreign_decls ;
913
914                 -- Annotations
915         annotations <- tcAnnotations annotation_decls ;
916
917                 -- Rules
918         rules <- tcRules rule_decls ;
919
920                 -- Vectorisation declarations
921         vects <- tcVectDecls vect_decls ;
922
923                 -- Wrap up
924         traceTc "Tc7a" empty ;
925         let { all_binds = inst_binds     `unionBags`
926                           foe_binds
927
928             ; fo_gres = fi_gres `unionBags` foe_gres
929             ; fo_fvs = foldrBag (\gre fvs -> fvs `addOneFV` gre_name gre) 
930                                 emptyFVs fo_gres
931             ; fo_rdr_names :: [RdrName]
932             ; fo_rdr_names = foldrBag gre_to_rdr_name [] fo_gres
933
934             ; sig_names = mkNameSet (collectHsValBinders val_binds)
935                           `minusNameSet` getTypeSigNames val_binds
936
937                 -- Extend the GblEnv with the (as yet un-zonked)
938                 -- bindings, rules, foreign decls
939             ; tcg_env' = tcg_env { tcg_binds   = tcg_binds tcg_env `unionBags` all_binds
940                                  , tcg_sigs    = tcg_sigs tcg_env `unionNameSets` sig_names
941                                  , tcg_rules   = tcg_rules tcg_env ++ rules
942                                  , tcg_vects   = tcg_vects tcg_env ++ vects
943                                  , tcg_anns    = tcg_anns tcg_env ++ annotations
944                                  , tcg_ann_env = extendAnnEnvList (tcg_ann_env tcg_env) annotations
945                                  , tcg_fords   = tcg_fords tcg_env ++ foe_decls ++ fi_decls
946                                  , tcg_dus     = tcg_dus tcg_env `plusDU` usesOnly fo_fvs } } ;
947                                  -- tcg_dus: see Note [Newtype constructor usage in foreign declarations]
948
949         addUsedRdrNames fo_rdr_names ;
950         return (tcg_env', tcl_env)
951     }}}}}}
952   where
953     gre_to_rdr_name :: GlobalRdrElt -> [RdrName] -> [RdrName]
954         -- For *imported* newtype data constructors, we want to
955         -- make sure that at least one of the imports for them is used
956         -- See Note [Newtype constructor usage in foreign declarations]
957     gre_to_rdr_name gre rdrs
958       = case gre_prov gre of
959            LocalDef          -> rdrs
960            Imported []       -> panic "gre_to_rdr_name: Imported []"
961            Imported (is : _) -> mkRdrQual modName occName : rdrs
962               where
963                 modName = is_as (is_decl is)
964                 occName = nameOccName (gre_name gre)
965
966 ---------------------------
967 tcTyClsInstDecls :: ModDetails 
968                  -> [TyClGroup Name] 
969                  -> [LInstDecl Name]
970                  -> [LDerivDecl Name]
971                  -> TcM (TcGblEnv,            -- The full inst env
972                          [InstInfo Name],     -- Source-code instance decls to process;
973                                               -- contains all dfuns for this module
974                           HsValBinds Name)    -- Supporting bindings for derived instances
975
976 tcTyClsInstDecls boot_details tycl_decls inst_decls deriv_decls
977  = tcExtendKindEnv2 [ (con, APromotionErr FamDataConPE) 
978                     | lid <- inst_decls, con <- get_cons lid ] $
979       -- Note [AFamDataCon: not promoting data family constructors]
980    do { tcg_env <- tcTyAndClassDecls boot_details tycl_decls ;
981       ; setGblEnv tcg_env $
982         tcInstDecls1 (tyClGroupConcat tycl_decls) inst_decls deriv_decls }
983   where
984     -- get_cons extracts the *constructor* bindings of the declaration
985     get_cons :: LInstDecl Name -> [Name]
986     get_cons (L _ (TyFamInstD {}))                     = []
987     get_cons (L _ (DataFamInstD { dfid_inst = fid }))  = get_fi_cons fid
988     get_cons (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = fids } }))
989       = concatMap (get_fi_cons . unLoc) fids
990
991     get_fi_cons :: DataFamInstDecl Name -> [Name]
992     get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } }) 
993       = map (unLoc . con_name . unLoc) cons
994 \end{code}
995
996 Note [AFamDataCon: not promoting data family constructors]
997 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
998 Consider
999   data family T a
1000   data instance T Int = MkT
1001   data Proxy (a :: k)
1002   data S = MkS (Proxy 'MkT)
1003
1004 Is it ok to use the promoted data family instance constructor 'MkT' in
1005 the data declaration for S?  No, we don't allow this. It *might* make
1006 sense, but at least it would mean that we'd have to interleave
1007 typechecking instances and data types, whereas at present we do data
1008 types *then* instances.
1009
1010 So to check for this we put in the TcLclEnv a binding for all the family
1011 constructors, bound to AFamDataCon, so that if we trip over 'MkT' when
1012 type checking 'S' we'll produce a decent error message.
1013
1014
1015 %************************************************************************
1016 %*                                                                      *
1017         Checking for 'main'
1018 %*                                                                      *
1019 %************************************************************************
1020
1021 \begin{code}
1022 checkMain :: TcM TcGblEnv
1023 -- If we are in module Main, check that 'main' is defined.
1024 checkMain
1025   = do { tcg_env   <- getGblEnv ;
1026          dflags    <- getDynFlags ;
1027          check_main dflags tcg_env
1028     }
1029
1030 check_main :: DynFlags -> TcGblEnv -> TcM TcGblEnv
1031 check_main dflags tcg_env
1032  | mod /= main_mod
1033  = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>
1034    return tcg_env
1035
1036  | otherwise
1037  = do   { mb_main <- lookupGlobalOccRn_maybe main_fn
1038                 -- Check that 'main' is in scope
1039                 -- It might be imported from another module!
1040         ; case mb_main of {
1041              Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn)
1042                            ; complain_no_main
1043                            ; return tcg_env } ;
1044              Just main_name -> do
1045
1046         { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)
1047         ; let loc = srcLocSpan (getSrcLoc main_name)
1048         ; ioTyCon <- tcLookupTyCon ioTyConName
1049         ; res_ty <- newFlexiTyVarTy liftedTypeKind
1050         ; main_expr
1051                 <- addErrCtxt mainCtxt    $
1052                    tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty])
1053
1054                 -- See Note [Root-main Id]
1055                 -- Construct the binding
1056                 --      :Main.main :: IO res_ty = runMainIO res_ty main
1057         ; run_main_id <- tcLookupId runMainIOName
1058         ; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN
1059                                    (mkVarOccFS (fsLit "main"))
1060                                    (getSrcSpan main_name)
1061               ; root_main_id = Id.mkExportedLocalId VanillaId root_main_name
1062                                                     (mkTyConApp ioTyCon [res_ty])
1063               ; co  = mkWpTyApps [res_ty]
1064               ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
1065               ; main_bind = mkVarBind root_main_id rhs }
1066
1067         ; return (tcg_env { tcg_main  = Just main_name,
1068                             tcg_binds = tcg_binds tcg_env
1069                                         `snocBag` main_bind,
1070                             tcg_dus   = tcg_dus tcg_env
1071                                         `plusDU` usesOnly (unitFV main_name)
1072                         -- Record the use of 'main', so that we don't
1073                         -- complain about it being defined but not used
1074                  })
1075     }}}
1076   where
1077     mod          = tcg_mod tcg_env
1078     main_mod     = mainModIs dflags
1079     main_fn      = getMainFun dflags
1080
1081     complain_no_main | ghcLink dflags == LinkInMemory = return ()
1082                      | otherwise = failWithTc noMainMsg
1083         -- In interactive mode, don't worry about the absence of 'main'
1084         -- In other modes, fail altogether, so that we don't go on
1085         -- and complain a second time when processing the export list.
1086
1087     mainCtxt  = ptext (sLit "When checking the type of the") <+> pp_main_fn
1088     noMainMsg = ptext (sLit "The") <+> pp_main_fn
1089                 <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod)
1090     pp_main_fn = ppMainFn main_fn
1091
1092 -- | Get the unqualified name of the function to use as the \"main\" for the main module.
1093 -- Either returns the default name or the one configured on the command line with -main-is
1094 getMainFun :: DynFlags -> RdrName
1095 getMainFun dflags = case mainFunIs dflags of
1096                       Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))
1097                       Nothing -> main_RDR_Unqual
1098
1099 checkMainExported :: TcGblEnv -> TcM ()
1100 checkMainExported tcg_env
1101   = case tcg_main tcg_env of
1102       Nothing -> return () -- not the main module
1103       Just main_name -> 
1104          do { dflags <- getDynFlags
1105             ; let main_mod = mainModIs dflags
1106             ; checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $
1107                 ptext (sLit "The") <+> ppMainFn (nameRdrName main_name) <+>
1108                 ptext (sLit "is not exported by module") <+> quotes (ppr main_mod) }
1109
1110 ppMainFn :: RdrName -> SDoc
1111 ppMainFn main_fn
1112   | rdrNameOcc main_fn == mainOcc
1113   = ptext (sLit "IO action") <+> quotes (ppr main_fn)
1114   | otherwise
1115   = ptext (sLit "main IO action") <+> quotes (ppr main_fn)
1116
1117 mainOcc :: OccName
1118 mainOcc = mkVarOccFS (fsLit "main")
1119 \end{code}
1120
1121
1122 Note [Root-main Id]
1123 ~~~~~~~~~~~~~~~~~~~
1124 The function that the RTS invokes is always :Main.main, which we call
1125 root_main_id.  (Because GHC allows the user to have a module not
1126 called Main as the main module, we can't rely on the main function
1127 being called "Main.main".  That's why root_main_id has a fixed module
1128 ":Main".)
1129
1130 This is unusual: it's a LocalId whose Name has a Module from another
1131 module.  Tiresomely, we must filter it out again in MkIface, les we
1132 get two defns for 'main' in the interface file!
1133
1134
1135 %*********************************************************
1136 %*                                                       *
1137                 GHCi stuff
1138 %*                                                       *
1139 %*********************************************************
1140
1141 \begin{code}
1142 runTcInteractive :: HscEnv -> TcRn a -> IO (Messages, Maybe a)
1143 -- Initialise the tcg_inst_env with instances from all home modules.
1144 -- This mimics the more selective call to hptInstances in tcRnImports
1145 runTcInteractive hsc_env thing_inside
1146   = initTcInteractive hsc_env $
1147     do { traceTc "setInteractiveContext" $
1148             vcat [ text "ic_tythings:" <+> vcat (map ppr (ic_tythings icxt))
1149                  , text "ic_insts:" <+> vcat (map (pprBndr LetBind . instanceDFunId) ic_insts)
1150                  , text "ic_rn_gbl_env (LocalDef)" <+>
1151                       vcat (map ppr [ local_gres | gres <- occEnvElts (ic_rn_gbl_env icxt)
1152                                                  , let local_gres = filter isLocalGRE gres
1153                                                  , not (null local_gres) ]) ]
1154        ; gbl_env <- getGblEnv
1155        ; let gbl_env' = gbl_env {
1156                            tcg_rdr_env      = ic_rn_gbl_env icxt
1157                          , tcg_type_env     = type_env
1158                          , tcg_insts        = ic_insts
1159                          , tcg_fam_insts    = ic_finsts
1160                          , tcg_inst_env     = extendInstEnvList
1161                                                (extendInstEnvList (tcg_inst_env gbl_env) ic_insts)
1162                                                home_insts
1163                          , tcg_fam_inst_env = extendFamInstEnvList
1164                                                (extendFamInstEnvList (tcg_fam_inst_env gbl_env)
1165                                                                      ic_finsts)
1166                                                home_fam_insts
1167                          , tcg_field_env    = RecFields (mkNameEnv con_fields)
1168                                                         (mkNameSet (concatMap snd con_fields))
1169                               -- setting tcg_field_env is necessary
1170                               -- to make RecordWildCards work (test: ghci049)
1171                          , tcg_fix_env      = ic_fix_env icxt
1172                          , tcg_default      = ic_default icxt }
1173
1174        ; setGblEnv gbl_env' $
1175          tcExtendGhciIdEnv ty_things $   -- See Note [Initialising the type environment for GHCi]
1176          thing_inside }                  -- in TcEnv
1177   where
1178     (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True)
1179
1180     icxt                  = hsc_IC hsc_env
1181     (ic_insts, ic_finsts) = ic_instances icxt
1182     ty_things             = ic_tythings icxt
1183
1184     type_env1 = mkTypeEnvWithImplicits ty_things
1185     type_env  = extendTypeEnvWithIds type_env1 (map instanceDFunId ic_insts)
1186                 -- Putting the dfuns in the type_env
1187                 -- is just to keep Core Lint happy
1188
1189     con_fields = [ (dataConName c, dataConFieldLabels c)
1190                  | ATyCon t <- ty_things
1191                  , c <- tyConDataCons t ]
1192
1193
1194 #ifdef GHCI
1195 -- | The returned [Id] is the list of new Ids bound by this statement. It can
1196 -- be used to extend the InteractiveContext via extendInteractiveContext.
1197 --
1198 -- The returned TypecheckedHsExpr is of type IO [ () ], a list of the bound
1199 -- values, coerced to ().
1200 tcRnStmt :: HscEnv -> GhciLStmt RdrName
1201          -> IO (Messages, Maybe ([Id], LHsExpr Id, FixityEnv))
1202 tcRnStmt hsc_env rdr_stmt
1203   = runTcInteractive hsc_env $ do {
1204
1205     -- The real work is done here
1206     ((bound_ids, tc_expr), fix_env) <- tcUserStmt rdr_stmt ;
1207     zonked_expr <- zonkTopLExpr tc_expr ;
1208     zonked_ids  <- zonkTopBndrs bound_ids ;
1209
1210         -- None of the Ids should be of unboxed type, because we
1211         -- cast them all to HValues in the end!
1212     mapM_ bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
1213
1214     traceTc "tcs 1" empty ;
1215     let { global_ids = map globaliseAndTidyId zonked_ids } ;
1216         -- Note [Interactively-bound Ids in GHCi] in HscTypes
1217
1218 {- ---------------------------------------------
1219    At one stage I removed any shadowed bindings from the type_env;
1220    they are inaccessible but might, I suppose, cause a space leak if we leave them there.
1221    However, with Template Haskell they aren't necessarily inaccessible.  Consider this
1222    GHCi session
1223          Prelude> let f n = n * 2 :: Int
1224          Prelude> fName <- runQ [| f |]
1225          Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
1226          14
1227          Prelude> let f n = n * 3 :: Int
1228          Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
1229    In the last line we use 'fName', which resolves to the *first* 'f'
1230    in scope. If we delete it from the type env, GHCi crashes because
1231    it doesn't expect that.
1232
1233    Hence this code is commented out
1234
1235 -------------------------------------------------- -}
1236
1237     dumpOptTcRn Opt_D_dump_tc
1238         (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
1239                text "Typechecked expr" <+> ppr zonked_expr]) ;
1240
1241     return (global_ids, zonked_expr, fix_env)
1242     }
1243   where
1244     bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"),
1245                                   nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
1246 \end{code}
1247
1248
1249 --------------------------------------------------------------------------
1250                 Typechecking Stmts in GHCi
1251
1252 Here is the grand plan, implemented in tcUserStmt
1253
1254         What you type                   The IO [HValue] that hscStmt returns
1255         -------------                   ------------------------------------
1256         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
1257                                         bindings: [x,y,...]
1258
1259         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
1260                                         bindings: [x,y,...]
1261
1262         expr (of IO type)       ==>     expr >>= \ it -> return [coerce HVal it]
1263           [NB: result not printed]      bindings: [it]
1264
1265         expr (of non-IO type,   ==>     let it = expr in print it >> return [coerce HVal it]
1266           result showable)              bindings: [it]
1267
1268         expr (of non-IO type,
1269           result not showable)  ==>     error
1270
1271 \begin{code}
1272
1273 -- | A plan is an attempt to lift some code into the IO monad.
1274 type PlanResult = ([Id], LHsExpr Id)
1275 type Plan = TcM PlanResult
1276
1277 -- | Try the plans in order. If one fails (by raising an exn), try the next.
1278 -- If one succeeds, take it.
1279 runPlans :: [Plan] -> TcM PlanResult
1280 runPlans []     = panic "runPlans"
1281 runPlans [p]    = p
1282 runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
1283
1284 -- | Typecheck (and 'lift') a stmt entered by the user in GHCi into the
1285 -- GHCi 'environemnt'.
1286 --
1287 -- By 'lift' and 'environment we mean that the code is changed to
1288 -- execute properly in an IO monad. See Note [Interactively-bound Ids
1289 -- in GHCi] in HscTypes for more details. We do this lifting by trying
1290 -- different ways ('plans') of lifting the code into the IO monad and
1291 -- type checking each plan until one succeeds.
1292 tcUserStmt :: GhciLStmt RdrName -> TcM (PlanResult, FixityEnv)
1293
1294 -- An expression typed at the prompt is treated very specially
1295 tcUserStmt (L loc (BodyStmt expr _ _ _))
1296   = do  { (rn_expr, fvs) <- checkNoErrs (rnLExpr expr)
1297                -- Don't try to typecheck if the renamer fails!
1298         ; ghciStep <- getGhciStepIO
1299         ; uniq <- newUnique
1300         ; interPrintName <- getInteractivePrintName
1301         ; let fresh_it  = itName uniq loc
1302               matches   = [mkMatch [] rn_expr emptyLocalBinds]
1303               -- [it = expr]
1304               the_bind  = L loc $ (mkTopFunBind FromSource (L loc fresh_it) matches) { bind_fvs = fvs }
1305                           -- Care here!  In GHCi the expression might have
1306                           -- free variables, and they in turn may have free type variables
1307                           -- (if we are at a breakpoint, say).  We must put those free vars
1308
1309               -- [let it = expr]
1310               let_stmt  = L loc $ LetStmt $ HsValBinds $
1311                           ValBindsOut [(NonRecursive,unitBag the_bind)] []
1312
1313               -- [it <- e]
1314               bind_stmt = L loc $ BindStmt (L loc (VarPat fresh_it))
1315                                            (nlHsApp ghciStep rn_expr)
1316                                            (HsVar bindIOName) noSyntaxExpr
1317
1318               -- [; print it]
1319               print_it  = L loc $ BodyStmt (nlHsApp (nlHsVar interPrintName) (nlHsVar fresh_it))
1320                                            (HsVar thenIOName) noSyntaxExpr placeHolderType
1321
1322         -- The plans are:
1323         --   A. [it <- e; print it]     but not if it::()
1324         --   B. [it <- e]
1325         --   C. [let it = e; print it]
1326         --
1327         -- Ensure that type errors don't get deferred when type checking the
1328         -- naked expression. Deferring type errors here is unhelpful because the
1329         -- expression gets evaluated right away anyway. It also would potentially
1330         -- emit two redundant type-error warnings, one from each plan.
1331         ; plan <- unsetGOptM Opt_DeferTypeErrors $ runPlans [
1332                     -- Plan A
1333                     do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
1334                        ; it_ty <- zonkTcType (idType it_id)
1335                        ; when (isUnitTy $ it_ty) failM
1336                        ; return stuff },
1337
1338                         -- Plan B; a naked bind statment
1339                     tcGhciStmts [bind_stmt],
1340
1341                         -- Plan C; check that the let-binding is typeable all by itself.
1342                         -- If not, fail; if so, try to print it.
1343                         -- The two-step process avoids getting two errors: one from
1344                         -- the expression itself, and one from the 'print it' part
1345                         -- This two-step story is very clunky, alas
1346                     do { _ <- checkNoErrs (tcGhciStmts [let_stmt])
1347                                 --- checkNoErrs defeats the error recovery of let-bindings
1348                        ; tcGhciStmts [let_stmt, print_it] } ]
1349
1350         ; fix_env <- getFixityEnv
1351         ; return (plan, fix_env) }
1352
1353 tcUserStmt rdr_stmt@(L loc _)
1354   = do { (([rn_stmt], fix_env), fvs) <- checkNoErrs $
1355            rnStmts GhciStmtCtxt rnLExpr [rdr_stmt] $ \_ -> do
1356              fix_env <- getFixityEnv
1357              return (fix_env, emptyFVs)
1358             -- Don't try to typecheck if the renamer fails!
1359        ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs])
1360        ; rnDump (ppr rn_stmt) ;
1361
1362        ; ghciStep <- getGhciStepIO
1363        ; let gi_stmt
1364                | (L loc (BindStmt pat expr op1 op2)) <- rn_stmt
1365                            = L loc $ BindStmt pat (nlHsApp ghciStep expr) op1 op2
1366                | otherwise = rn_stmt
1367
1368        ; opt_pr_flag <- goptM Opt_PrintBindResult
1369        ; let print_result_plan
1370                | opt_pr_flag                         -- The flag says "print result"   
1371                , [v] <- collectLStmtBinders gi_stmt  -- One binder
1372                            =  [mk_print_result_plan gi_stmt v]
1373                | otherwise = []
1374
1375         -- The plans are:
1376         --      [stmt; print v]         if one binder and not v::()
1377         --      [stmt]                  otherwise
1378        ; plan <- runPlans (print_result_plan ++ [tcGhciStmts [gi_stmt]])
1379        ; return (plan, fix_env) }
1380   where
1381     mk_print_result_plan stmt v
1382       = do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
1383            ; v_ty <- zonkTcType (idType v_id)
1384            ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM
1385            ; return stuff }
1386       where
1387         print_v  = L loc $ BodyStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
1388                                     (HsVar thenIOName) noSyntaxExpr
1389                                     placeHolderType
1390
1391 -- | Typecheck the statements given and then return the results of the
1392 -- statement in the form 'IO [()]'.
1393 tcGhciStmts :: [GhciLStmt Name] -> TcM PlanResult
1394 tcGhciStmts stmts
1395  = do { ioTyCon <- tcLookupTyCon ioTyConName ;
1396         ret_id  <- tcLookupId returnIOName ;            -- return @ IO
1397         let {
1398             ret_ty      = mkListTy unitTy ;
1399             io_ret_ty   = mkTyConApp ioTyCon [ret_ty] ;
1400             tc_io_stmts = tcStmtsAndThen GhciStmtCtxt tcDoStmt stmts io_ret_ty ;
1401             names = collectLStmtsBinders stmts ;
1402          } ;
1403
1404         -- OK, we're ready to typecheck the stmts
1405         traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
1406         ((tc_stmts, ids), lie) <- captureConstraints $
1407                                   tc_io_stmts $ \ _ ->
1408                                   mapM tcLookupId names  ;
1409                         -- Look up the names right in the middle,
1410                         -- where they will all be in scope
1411
1412         -- Simplify the context
1413         traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
1414         const_binds <- checkNoErrs (simplifyInteractive lie) ;
1415                 -- checkNoErrs ensures that the plan fails if context redn fails
1416
1417         traceTc "TcRnDriver.tcGhciStmts: done" empty ;
1418         let {   -- mk_return builds the expression
1419                 --      returnIO @ [()] [coerce () x, ..,  coerce () z]
1420                 --
1421                 -- Despite the inconvenience of building the type applications etc,
1422                 -- this *has* to be done in type-annotated post-typecheck form
1423                 -- because we are going to return a list of *polymorphic* values
1424                 -- coerced to type (). If we built a *source* stmt
1425                 --      return [coerce x, ..., coerce z]
1426                 -- then the type checker would instantiate x..z, and we wouldn't
1427                 -- get their *polymorphic* values.  (And we'd get ambiguity errs
1428                 -- if they were overloaded, since they aren't applied to anything.)
1429             ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty])
1430                        (noLoc $ ExplicitList unitTy Nothing (map mk_item ids)) ;
1431             mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
1432                                  (nlHsVar id) ;
1433             stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
1434         } ;
1435         return (ids, mkHsDictLet (EvBinds const_binds) $
1436                      noLoc (HsDo GhciStmtCtxt stmts io_ret_ty))
1437     }
1438
1439 -- | Generate a typed ghciStepIO expression (ghciStep :: Ty a -> IO a)
1440 getGhciStepIO :: TcM (LHsExpr Name)
1441 getGhciStepIO = do
1442     ghciTy <- getGHCiMonad
1443     fresh_a <- newUnique
1444     let a_tv   = mkTcTyVarName fresh_a (fsLit "a")
1445         ghciM  = nlHsAppTy (nlHsTyVar ghciTy) (nlHsTyVar a_tv)
1446         ioM    = nlHsAppTy (nlHsTyVar ioTyConName) (nlHsTyVar a_tv)
1447
1448         stepTy :: LHsType Name    -- Renamed, so needs all binders in place
1449         stepTy = noLoc $ HsForAllTy Implicit
1450                             (HsQTvs { hsq_tvs = [noLoc (UserTyVar a_tv)]
1451                                     , hsq_kvs = [] })
1452                             (noLoc [])
1453                             (nlHsFunTy ghciM ioM)
1454         step   = noLoc $ ExprWithTySig (nlHsVar ghciStepIoMName) stepTy
1455     return step
1456
1457 isGHCiMonad :: HscEnv -> String -> IO (Messages, Maybe Name)
1458 isGHCiMonad hsc_env ty
1459   = runTcInteractive hsc_env $ do
1460         rdrEnv <- getGlobalRdrEnv
1461         let occIO = lookupOccEnv rdrEnv (mkOccName tcName ty)
1462         case occIO of
1463             Just [n] -> do
1464                 let name = gre_name n
1465                 ghciClass <- tcLookupClass ghciIoClassName 
1466                 userTyCon <- tcLookupTyCon name
1467                 let userTy = mkTyConApp userTyCon []
1468                 _ <- tcLookupInstance ghciClass [userTy]
1469                 return name
1470
1471             Just _  -> failWithTc $ text "Ambigous type!"
1472             Nothing -> failWithTc $ text ("Can't find type:" ++ ty)
1473
1474 \end{code}
1475
1476 tcRnExpr just finds the type of an expression
1477
1478 \begin{code}
1479 tcRnExpr :: HscEnv
1480          -> LHsExpr RdrName
1481          -> IO (Messages, Maybe Type)
1482 -- Type checks the expression and returns its most general type
1483 tcRnExpr hsc_env rdr_expr
1484   = runTcInteractive hsc_env $ do {
1485
1486     (rn_expr, _fvs) <- rnLExpr rdr_expr ;
1487     failIfErrsM ;
1488
1489         -- Now typecheck the expression;
1490         -- it might have a rank-2 type (e.g. :t runST)
1491     uniq <- newUnique ;
1492     let { fresh_it  = itName uniq (getLoc rdr_expr) } ;
1493     ((_tc_expr, res_ty), lie) <- captureConstraints $ 
1494                                  tcInferRho rn_expr ;
1495     ((qtvs, dicts, _, _), lie_top) <- captureConstraints $
1496                                       {-# SCC "simplifyInfer" #-}
1497                                       simplifyInfer True {- Free vars are closed -}
1498                                                     False {- No MR for now -}
1499                                                     [(fresh_it, res_ty)]
1500                                                     lie ;
1501     _ <- simplifyInteractive lie_top ;       -- Ignore the dicionary bindings
1502
1503     let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
1504     zonkTcType all_expr_ty
1505     }
1506
1507 --------------------------
1508 tcRnImportDecls :: HscEnv
1509                 -> [LImportDecl RdrName]
1510                 -> IO (Messages, Maybe GlobalRdrEnv)
1511 -- Find the new chunk of GlobalRdrEnv created by this list of import
1512 -- decls.  In contract tcRnImports *extends* the TcGblEnv.
1513 tcRnImportDecls hsc_env import_decls
1514  =  runTcInteractive hsc_env $
1515     do { gbl_env <- updGblEnv zap_rdr_env $
1516                     tcRnImports hsc_env import_decls
1517        ; return (tcg_rdr_env gbl_env) }
1518   where
1519     zap_rdr_env gbl_env = gbl_env { tcg_rdr_env = emptyGlobalRdrEnv }
1520 \end{code}
1521
1522 tcRnType just finds the kind of a type
1523
1524 \begin{code}
1525 tcRnType :: HscEnv
1526          -> Bool        -- Normalise the returned type
1527          -> LHsType RdrName
1528          -> IO (Messages, Maybe (Type, Kind))
1529 tcRnType hsc_env normalise rdr_type
1530   = runTcInteractive hsc_env $
1531     setXOptM Opt_PolyKinds $   -- See Note [Kind-generalise in tcRnType]
1532     do { (rn_type, _fvs) <- rnLHsType GHCiCtx rdr_type
1533        ; failIfErrsM
1534
1535         -- Now kind-check the type
1536         -- It can have any rank or kind
1537        ; ty <- tcHsSigType GhciCtxt rn_type ;
1538
1539        ; ty' <- if normalise
1540                 then do { fam_envs <- tcGetFamInstEnvs
1541                         ; return (snd (normaliseType fam_envs Nominal ty)) }
1542                         -- normaliseType returns a coercion
1543                         -- which we discard, so the Role is irrelevant
1544                 else return ty ;
1545
1546        ; return (ty', typeKind ty) }
1547 \end{code}
1548
1549 Note [Kind-generalise in tcRnType]
1550 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1551 We switch on PolyKinds when kind-checking a user type, so that we will
1552 kind-generalise the type.  This gives the right default behaviour at
1553 the GHCi prompt, where if you say ":k T", and T has a polymorphic
1554 kind, you'd like to see that polymorphism. Of course.  If T isn't
1555 kind-polymorphic you won't get anything unexpected, but the apparent
1556 *loss* of polymorphism, for types that you know are polymorphic, is
1557 quite surprising.  See Trac #7688 for a discussion.
1558
1559
1560 %************************************************************************
1561 %*                                                                      *
1562                  tcRnDeclsi
1563 %*                                                                      *
1564 %************************************************************************
1565
1566 tcRnDeclsi exists to allow class, data, and other declarations in GHCi.
1567
1568 \begin{code}
1569 tcRnDeclsi :: HscEnv
1570            -> [LHsDecl RdrName]
1571            -> IO (Messages, Maybe TcGblEnv)
1572
1573 tcRnDeclsi hsc_env local_decls =
1574   runTcInteractive hsc_env $ do
1575
1576     ((tcg_env, tclcl_env), lie) <-
1577         captureConstraints $ tc_rn_src_decls emptyModDetails local_decls
1578     setEnvs (tcg_env, tclcl_env) $ do
1579
1580     new_ev_binds <- simplifyTop lie
1581     failIfErrsM
1582     let TcGblEnv { tcg_type_env  = type_env,
1583                    tcg_binds     = binds,
1584                    tcg_sigs      = sig_ns,
1585                    tcg_ev_binds  = cur_ev_binds,
1586                    tcg_imp_specs = imp_specs,
1587                    tcg_rules     = rules,
1588                    tcg_vects     = vects,
1589                    tcg_fords     = fords } = tcg_env
1590         all_ev_binds = cur_ev_binds `unionBags` new_ev_binds
1591
1592     (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects')
1593         <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords
1594
1595     let --global_ids = map globaliseAndTidyId bind_ids
1596         final_type_env = extendTypeEnvWithIds type_env bind_ids --global_ids
1597         tcg_env' = tcg_env { tcg_binds     = binds',
1598                              tcg_ev_binds  = ev_binds',
1599                              tcg_imp_specs = imp_specs',
1600                              tcg_rules     = rules',
1601                              tcg_vects     = vects',
1602                              tcg_fords     = fords' }
1603
1604     setGlobalTypeEnv tcg_env' final_type_env
1605     
1606 #endif /* GHCi */
1607 \end{code}
1608
1609
1610 %************************************************************************
1611 %*                                                                      *
1612         More GHCi stuff, to do with browsing and getting info
1613 %*                                                                      *
1614 %************************************************************************
1615
1616 \begin{code}
1617 #ifdef GHCI
1618 -- | ASSUMES that the module is either in the 'HomePackageTable' or is
1619 -- a package module with an interface on disk.  If neither of these is
1620 -- true, then the result will be an error indicating the interface
1621 -- could not be found.
1622 getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface)
1623 getModuleInterface hsc_env mod
1624   = runTcInteractive hsc_env $
1625     loadModuleInterface (ptext (sLit "getModuleInterface")) mod
1626
1627 tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name])
1628 tcRnLookupRdrName hsc_env rdr_name
1629   = runTcInteractive hsc_env $
1630     lookup_rdr_name rdr_name
1631
1632 lookup_rdr_name :: RdrName -> TcM [Name]
1633 lookup_rdr_name rdr_name = do
1634         -- If the identifier is a constructor (begins with an
1635         -- upper-case letter), then we need to consider both
1636         -- constructor and type class identifiers.
1637     let rdr_names = dataTcOccs rdr_name
1638
1639         -- results :: [Either Messages Name]
1640     results <- mapM (tryTcErrs . lookupOccRn) rdr_names
1641
1642     traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)])
1643         -- The successful lookups will be (Just name)
1644     let (warns_s, good_names) = unzip [ (msgs, name)
1645                                       | (msgs, Just name) <- results]
1646         errs_s = [msgs | (msgs, Nothing) <- results]
1647
1648         -- Fail if nothing good happened, else add warnings
1649     if null good_names
1650       then  addMessages (head errs_s) >> failM
1651                 -- No lookup succeeded, so
1652                 -- pick the first error message and report it
1653                 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
1654                 --       while the other is "X is not in scope",
1655                 --       we definitely want the former; but we might pick the latter
1656       else      mapM_ addMessages warns_s
1657                 -- Add deprecation warnings
1658     return good_names
1659
1660 #endif
1661
1662 tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
1663 tcRnLookupName hsc_env name
1664   = runTcInteractive hsc_env $
1665     tcRnLookupName' name
1666
1667 -- To look up a name we have to look in the local environment (tcl_lcl)
1668 -- as well as the global environment, which is what tcLookup does.
1669 -- But we also want a TyThing, so we have to convert:
1670
1671 tcRnLookupName' :: Name -> TcRn TyThing
1672 tcRnLookupName' name = do
1673    tcthing <- tcLookup name
1674    case tcthing of
1675      AGlobal thing    -> return thing
1676      ATcId{tct_id=id} -> return (AnId id)
1677      _ -> panic "tcRnLookupName'"
1678
1679 tcRnGetInfo :: HscEnv
1680             -> Name
1681             -> IO (Messages, Maybe (TyThing, Fixity, [ClsInst], [FamInst]))
1682
1683 -- Used to implement :info in GHCi
1684 --
1685 -- Look up a RdrName and return all the TyThings it might be
1686 -- A capitalised RdrName is given to us in the DataName namespace,
1687 -- but we want to treat it as *both* a data constructor
1688 --  *and* as a type or class constructor;
1689 -- hence the call to dataTcOccs, and we return up to two results
1690 tcRnGetInfo hsc_env name
1691   = runTcInteractive hsc_env $
1692     do { loadUnqualIfaces hsc_env (hsc_IC hsc_env)
1693            -- Load the interface for all unqualified types and classes
1694            -- That way we will find all the instance declarations
1695            -- (Packages have not orphan modules, and we assume that
1696            --  in the home package all relevant modules are loaded.)
1697
1698        ; thing  <- tcRnLookupName' name
1699        ; fixity <- lookupFixityRn name
1700        ; (cls_insts, fam_insts) <- lookupInsts thing
1701        ; return (thing, fixity, cls_insts, fam_insts) }
1702
1703 lookupInsts :: TyThing -> TcM ([ClsInst],[FamInst])
1704 lookupInsts (ATyCon tc)
1705   = do  { (pkg_ie, home_ie) <- tcGetInstEnvs
1706         ; (pkg_fie, home_fie) <- tcGetFamInstEnvs
1707                 -- Load all instances for all classes that are
1708                 -- in the type environment (which are all the ones
1709                 -- we've seen in any interface file so far)
1710
1711           -- Return only the instances relevant to the given thing, i.e.
1712           -- the instances whose head contains the thing's name.
1713         ; let cls_insts =
1714                  [ ispec        -- Search all
1715                  | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
1716                  , tc_name `elemNameSet` orphNamesOfClsInst ispec ]
1717         ; let fam_insts =
1718                  [ fispec
1719                  | fispec <- famInstEnvElts home_fie ++ famInstEnvElts pkg_fie
1720                  , tc_name `elemNameSet` orphNamesOfFamInst fispec ]
1721         ; return (cls_insts, fam_insts) }
1722   where
1723     tc_name     = tyConName tc
1724
1725 lookupInsts _ = return ([],[])
1726
1727 loadUnqualIfaces :: HscEnv -> InteractiveContext -> TcM ()
1728 -- Load the interface for everything that is in scope unqualified
1729 -- This is so that we can accurately report the instances for
1730 -- something
1731 loadUnqualIfaces hsc_env ictxt
1732   = initIfaceTcRn $ do
1733     mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
1734   where
1735     this_pkg = thisPackage (hsc_dflags hsc_env)
1736
1737     unqual_mods = [ mod
1738                   | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt)
1739                   , let name = gre_name gre
1740                   , not (isInternalName name)
1741                   , let mod = nameModule name
1742                   , not (modulePackageKey mod == this_pkg || isInteractiveModule mod)
1743                       -- Don't attempt to load an interface for stuff
1744                       -- from the command line, or from the home package
1745                   , isTcOcc (nameOccName name)   -- Types and classes only
1746                   , unQualOK gre ]               -- In scope unqualified
1747     doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified")
1748 \end{code}
1749
1750 %************************************************************************
1751 %*                                                                      *
1752                 Degugging output
1753 %*                                                                      *
1754 %************************************************************************
1755
1756 \begin{code}
1757 rnDump :: SDoc -> TcRn ()
1758 -- Dump, with a banner, if -ddump-rn
1759 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1760
1761 tcDump :: TcGblEnv -> TcRn ()
1762 tcDump env
1763  = do { dflags <- getDynFlags ;
1764
1765         -- Dump short output if -ddump-types or -ddump-tc
1766         when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1767              (dumpTcRn short_dump) ;
1768
1769         -- Dump bindings if -ddump-tc
1770         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1771    }
1772   where
1773     short_dump = pprTcGblEnv env
1774     full_dump  = pprLHsBinds (tcg_binds env)
1775         -- NB: foreign x-d's have undefined's in their types;
1776         --     hence can't show the tc_fords
1777
1778 -- It's unpleasant having both pprModGuts and pprModDetails here
1779 pprTcGblEnv :: TcGblEnv -> SDoc
1780 pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env,
1781                         tcg_insts     = insts,
1782                         tcg_fam_insts = fam_insts,
1783                         tcg_rules     = rules,
1784                         tcg_vects     = vects,
1785                         tcg_imports   = imports })
1786   = vcat [ ppr_types insts type_env
1787          , ppr_tycons fam_insts type_env
1788          , ppr_insts insts
1789          , ppr_fam_insts fam_insts
1790          , vcat (map ppr rules)
1791          , vcat (map ppr vects)
1792          , ptext (sLit "Dependent modules:") <+>
1793                 ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
1794          , ptext (sLit "Dependent packages:") <+>
1795                 ppr (sortBy stablePackageKeyCmp $ imp_dep_pkgs imports)]
1796   where         -- The two uses of sortBy are just to reduce unnecessary
1797                 -- wobbling in testsuite output
1798     cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2)
1799         = (mod_name1 `stableModuleNameCmp` mod_name2)
1800                   `thenCmp`
1801           (is_boot1 `compare` is_boot2)
1802
1803 ppr_types :: [ClsInst] -> TypeEnv -> SDoc
1804 ppr_types insts type_env
1805   = text "TYPE SIGNATURES" $$ nest 2 (ppr_sigs ids)
1806   where
1807     dfun_ids = map instanceDFunId insts
1808     ids = [id | id <- typeEnvIds type_env, want_sig id]
1809     want_sig id | opt_PprStyle_Debug = True
1810                 | otherwise          = isLocalId id &&
1811                                        isExternalName (idName id) &&
1812                                        not (id `elem` dfun_ids)
1813         -- isLocalId ignores data constructors, records selectors etc.
1814         -- The isExternalName ignores local dictionary and method bindings
1815         -- that the type checker has invented.  Top-level user-defined things
1816         -- have External names.
1817
1818 ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
1819 ppr_tycons fam_insts type_env
1820   = vcat [ text "TYPE CONSTRUCTORS"
1821          ,   nest 2 (ppr_tydecls tycons)
1822          , text "COERCION AXIOMS"
1823          ,   nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ]
1824   where
1825     fi_tycons = famInstsRepTyCons fam_insts
1826     tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
1827     want_tycon tycon | opt_PprStyle_Debug = True
1828                      | otherwise          = not (isImplicitTyCon tycon) &&
1829                                             isExternalName (tyConName tycon) &&
1830                                             not (tycon `elem` fi_tycons)
1831
1832 ppr_insts :: [ClsInst] -> SDoc
1833 ppr_insts []     = empty
1834 ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
1835
1836 ppr_fam_insts :: [FamInst] -> SDoc
1837 ppr_fam_insts []        = empty
1838 ppr_fam_insts fam_insts =
1839   text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts)
1840
1841 ppr_sigs :: [Var] -> SDoc
1842 ppr_sigs ids
1843         -- Print type signatures; sort by OccName
1844   = vcat (map ppr_sig (sortBy (comparing getOccName) ids))
1845   where
1846     ppr_sig id = hang (ppr id <+> dcolon) 2 (ppr (tidyTopType (idType id)))
1847
1848 ppr_tydecls :: [TyCon] -> SDoc
1849 ppr_tydecls tycons
1850         -- Print type constructor info; sort by OccName
1851   = vcat (map ppr_tycon (sortBy (comparing getOccName) tycons))
1852   where
1853     ppr_tycon tycon = vcat [ ppr (tyThingToIfaceDecl (ATyCon tycon)) ]
1854 \end{code}