Move exprIsConApp_maybe to CoreSubst so we can use it in VSO. Fix VSO bug with unlift...
[ghc.git] / compiler / typecheck / TcRnDriver.lhs
1 %
2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %
5 \section[TcMovectle]{Typechecking a whole module}
6
7 \begin{code}
8 module TcRnDriver (
9 #ifdef GHCI
10         tcRnStmt, tcRnExpr, tcRnType,
11         tcRnLookupRdrName,
12         getModuleInterface,
13 #endif
14         tcRnImports,
15         tcRnLookupName,
16         tcRnGetInfo,
17         tcRnModule, 
18         tcTopSrcDecls,
19         tcRnExtCore
20     ) where
21
22 #ifdef GHCI
23 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
24 #endif
25
26 import DynFlags
27 import StaticFlags
28 import HsSyn
29 import PrelNames
30 import RdrName
31 import TcHsSyn
32 import TcExpr
33 import TcRnMonad
34 import Coercion
35 import FamInst
36 import InstEnv
37 import FamInstEnv
38 import TcAnnotations
39 import TcBinds
40 import HeaderInfo       ( mkPrelImports )
41 import TcType   ( tidyTopType )
42 import TcDefaults
43 import TcEnv
44 import TcRules
45 import TcForeign
46 import TcInstDcls
47 import TcIface
48 import TcMType
49 import MkIface
50 import IfaceSyn
51 import TcSimplify
52 import TcTyClsDecls
53 import LoadIface
54 import RnNames
55 import RnEnv
56 import RnSource
57 import PprCore
58 import CoreSyn
59 import ErrUtils
60 import Id
61 import VarEnv
62 import Var
63 import Module
64 import UniqFM
65 import Name
66 import NameEnv
67 import NameSet
68 import TyCon
69 import SrcLoc
70 import HscTypes
71 import ListSetOps
72 import Outputable
73 import DataCon
74 import Type
75 import Class
76 import TcType   ( orphNamesOfDFunHead )
77 import Inst     ( tcGetInstEnvs )
78 import Data.List ( sortBy )
79
80 #ifdef GHCI
81 import TcType   ( isUnitTy, isTauTy )
82 import CoreUtils( mkPiTypes )
83 import TcHsType
84 import TcMatches
85 import RnTypes
86 import RnExpr
87 import MkId
88 import BasicTypes
89 import TidyPgm    ( globaliseAndTidyId )
90 import TysWiredIn ( unitTy, mkListTy )
91 #endif
92
93 import FastString
94 import Maybes
95 import Util
96 import Bag
97
98 import Control.Monad
99
100 #include "HsVersions.h"
101 \end{code}
102
103 %************************************************************************
104 %*                                                                      *
105         Typecheck and rename a module
106 %*                                                                      *
107 %************************************************************************
108
109
110 \begin{code}
111 tcRnModule :: HscEnv 
112            -> HscSource
113            -> Bool              -- True <=> save renamed syntax
114            -> Located (HsModule RdrName)
115            -> IO (Messages, Maybe TcGblEnv)
116
117 tcRnModule hsc_env hsc_src save_rn_syntax
118          (L loc (HsModule maybe_mod export_ies 
119                           import_decls local_decls mod_deprec
120                           maybe_doc_hdr))
121  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
122
123    let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
124          (this_mod, prel_imp_loc) 
125             = case maybe_mod of
126                 Nothing -- 'module M where' is omitted  
127                     ->  (mAIN, srcLocSpan (srcSpanStart loc))   
128                                    
129                 Just (L mod_loc mod)  -- The normal case
130                     -> (mkModule this_pkg mod, mod_loc) } ;
131                 
132    initTc hsc_env hsc_src save_rn_syntax this_mod $ 
133    setSrcSpan loc $
134    do {         -- Deal with imports; first add implicit prelude
135         implicit_prelude <- xoptM Opt_ImplicitPrelude;
136         let { prel_imports = mkPrelImports (moduleName this_mod) prel_imp_loc
137                                          implicit_prelude import_decls } ;
138
139         ifWOptM Opt_WarnImplicitPrelude $
140              when (notNull prel_imports) $ addWarn (implicitPreludeWarn) ;
141
142         tcg_env <- tcRnImports hsc_env this_mod (prel_imports ++ import_decls) ;
143         setGblEnv tcg_env               $ do {
144
145                 -- Load the hi-boot interface for this module, if any
146                 -- We do this now so that the boot_names can be passed
147                 -- to tcTyAndClassDecls, because the boot_names are 
148                 -- automatically considered to be loop breakers
149                 --
150                 -- Do this *after* tcRnImports, so that we know whether
151                 -- a module that we import imports us; and hence whether to
152                 -- look for a hi-boot file
153         boot_iface <- tcHiBootIface hsc_src this_mod ;
154
155                 -- Rename and type check the declarations
156         traceRn (text "rn1a") ;
157         tcg_env <- if isHsBoot hsc_src then
158                         tcRnHsBootDecls local_decls
159                    else 
160                         tcRnSrcDecls boot_iface local_decls ;
161         setGblEnv tcg_env               $ do {
162
163                 -- Report the use of any deprecated things
164                 -- We do this *before* processsing the export list so
165                 -- that we don't bleat about re-exporting a deprecated
166                 -- thing (especially via 'module Foo' export item)
167                 -- That is, only uses in the *body* of the module are complained about
168         traceRn (text "rn3") ;
169         failIfErrsM ;   -- finishWarnings crashes sometimes 
170                         -- as a result of typechecker repairs (e.g. unboundNames)
171         tcg_env <- finishWarnings (hsc_dflags hsc_env) mod_deprec tcg_env ;
172
173                 -- Process the export list
174         traceRn (text "rn4a: before exports");
175         tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ;
176         traceRn (text "rn4b: after exportss") ;
177
178                 -- Check that main is exported (must be after rnExports)
179         checkMainExported tcg_env ;
180
181         -- Compare the hi-boot iface (if any) with the real thing
182         -- Must be done after processing the exports
183         tcg_env <- checkHiBootIface tcg_env boot_iface ;
184
185         -- The new type env is already available to stuff slurped from 
186         -- interface files, via TcEnv.updateGlobalTypeEnv
187         -- It's important that this includes the stuff in checkHiBootIface, 
188         -- because the latter might add new bindings for boot_dfuns, 
189         -- which may be mentioned in imported unfoldings
190
191                 -- Don't need to rename the Haddock documentation,
192                 -- it's not parsed by GHC anymore.
193         tcg_env <- return (tcg_env { tcg_doc_hdr = maybe_doc_hdr }) ;
194
195                 -- Report unused names
196         reportUnusedNames export_ies tcg_env ;
197
198                 -- Dump output and return
199         tcDump tcg_env ;
200         return tcg_env
201     }}}}
202
203
204 implicitPreludeWarn :: SDoc
205 implicitPreludeWarn
206   = ptext (sLit "Module `Prelude' implicitly imported")
207 \end{code}
208
209
210 %************************************************************************
211 %*                                                                      *
212                 Import declarations
213 %*                                                                      *
214 %************************************************************************
215
216 \begin{code}
217 tcRnImports :: HscEnv -> Module 
218             -> [LImportDecl RdrName] -> TcM TcGblEnv
219 tcRnImports hsc_env this_mod import_decls
220   = do  { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ;
221
222         ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
223                 -- Make sure we record the dependencies from the DynFlags in the EPS or we
224                 -- end up hitting the sanity check in LoadIface.loadInterface that
225                 -- checks for unknown home-package modules being loaded. We put
226                 -- these dependencies on the left so their (non-source) imports
227                 -- take precedence over the (possibly-source) imports on the right.
228                 -- We don't add them to any other field (e.g. the imp_dep_mods of
229                 -- imports) because we don't want to load their instances etc.
230               ; dep_mods = listToUFM [(mod_nm, (mod_nm, False)) | mod_nm <- dynFlagDependencies (hsc_dflags hsc_env)]
231                                 `plusUFM` imp_dep_mods imports
232
233                 -- We want instance declarations from all home-package
234                 -- modules below this one, including boot modules, except
235                 -- ourselves.  The 'except ourselves' is so that we don't
236                 -- get the instances from this module's hs-boot file
237               ; want_instances :: ModuleName -> Bool
238               ; want_instances mod = mod `elemUFM` dep_mods
239                                    && mod /= moduleName this_mod
240               ; (home_insts, home_fam_insts) = hptInstances hsc_env 
241                                                             want_instances
242               } ;
243
244                 -- Record boot-file info in the EPS, so that it's 
245                 -- visible to loadHiBootInterface in tcRnSrcDecls,
246                 -- and any other incrementally-performed imports
247         ; updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
248
249                 -- Update the gbl env
250         ; updGblEnv ( \ gbl -> 
251             gbl { 
252               tcg_rdr_env      = plusOccEnv (tcg_rdr_env gbl) rdr_env,
253               tcg_imports      = tcg_imports gbl `plusImportAvails` imports,
254               tcg_rn_imports   = rn_imports,
255               tcg_inst_env     = extendInstEnvList (tcg_inst_env gbl) home_insts,
256               tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) 
257                                                       home_fam_insts,
258               tcg_hpc          = hpc_info
259             }) $ do {
260
261         ; traceRn (text "rn1" <+> ppr (imp_dep_mods imports))
262                 -- Fail if there are any errors so far
263                 -- The error printing (if needed) takes advantage 
264                 -- of the tcg_env we have now set
265 --      ; traceIf (text "rdr_env: " <+> ppr rdr_env)
266         ; failIfErrsM
267
268                 -- Load any orphan-module and family instance-module
269                 -- interfaces, so that their rules and instance decls will be
270                 -- found.
271         ; loadModuleInterfaces (ptext (sLit "Loading orphan modules")) 
272                                (imp_orphs imports)
273
274                 -- Check type-family consistency
275         ; traceRn (text "rn1: checking family instance consistency")
276         ; let { dir_imp_mods = moduleEnvKeys
277                              . imp_mods 
278                              $ imports }
279         ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ;
280
281         ; getGblEnv } }
282 \end{code}
283
284
285 %************************************************************************
286 %*                                                                      *
287         Type-checking external-core modules
288 %*                                                                      *
289 %************************************************************************
290
291 \begin{code}
292 tcRnExtCore :: HscEnv 
293             -> HsExtCore RdrName
294             -> IO (Messages, Maybe ModGuts)
295         -- Nothing => some error occurred 
296
297 tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
298         -- The decls are IfaceDecls; all names are original names
299  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
300
301    initTc hsc_env ExtCoreFile False this_mod $ do {
302
303    let { ldecls  = map noLoc decls } ;
304
305        -- Bring the type and class decls into scope
306        -- ToDo: check that this doesn't need to extract the val binds.
307        --       It seems that only the type and class decls need to be in scope below because
308        --          (a) tcTyAndClassDecls doesn't need the val binds, and 
309        --          (b) tcExtCoreBindings doesn't need anything
310        --              (in fact, it might not even need to be in the scope of
311        --               this tcg_env at all)
312    (tc_envs, _bndrs) <- getLocalNonValBinders emptyFsEnv {- no fixity decls -} 
313                                               (mkFakeGroup ldecls) ;
314    setEnvs tc_envs $ do {
315
316    (rn_decls, _fvs) <- checkNoErrs $ rnTyClDecls [ldecls] ;
317
318         -- Dump trace of renaming part
319    rnDump (ppr rn_decls) ;
320
321         -- Typecheck them all together so that
322         -- any mutually recursive types are done right
323         -- Just discard the auxiliary bindings; they are generated 
324         -- only for Haskell source code, and should already be in Core
325    (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ;
326
327    setGblEnv tcg_env $ do {
328         -- Make the new type env available to stuff slurped from interface files
329    
330         -- Now the core bindings
331    core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
332
333         -- Wrap up
334    let {
335         bndrs      = bindersOfBinds core_binds ;
336         my_exports = map (Avail . idName) bndrs ;
337                 -- ToDo: export the data types also?
338
339         final_type_env = 
340              extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
341
342         mod_guts = ModGuts {    mg_module    = this_mod,
343                                 mg_boot      = False,
344                                 mg_used_names = emptyNameSet, -- ToDo: compute usage
345                                 mg_used_th   = False,
346                                 mg_dir_imps  = emptyModuleEnv, -- ??
347                                 mg_deps      = noDependencies,  -- ??
348                                 mg_exports   = my_exports,
349                                 mg_types     = final_type_env,
350                                 mg_insts     = tcg_insts tcg_env,
351                                 mg_fam_insts = tcg_fam_insts tcg_env,
352                                 mg_inst_env  = tcg_inst_env tcg_env,
353                                 mg_fam_inst_env = tcg_fam_inst_env tcg_env,
354                                 mg_rules     = [],
355                                 mg_vect_decls = [],
356                                 mg_anns      = [],
357                                 mg_binds     = core_binds,
358
359                                 -- Stubs
360                                 mg_rdr_env   = emptyGlobalRdrEnv,
361                                 mg_fix_env   = emptyFixityEnv,
362                                 mg_warns     = NoWarnings,
363                                 mg_foreign   = NoStubs,
364                                 mg_hpc_info  = emptyHpcInfo False,
365                                 mg_modBreaks = emptyModBreaks,
366                                 mg_vect_info = noVectInfo,
367                                 mg_trust_pkg = False
368                     } } ;
369
370    tcCoreDump mod_guts ;
371
372    return mod_guts
373    }}}}
374
375 mkFakeGroup :: [LTyClDecl a] -> HsGroup a
376 mkFakeGroup decls -- Rather clumsy; lots of unused fields
377   = emptyRdrGroup { hs_tyclds = [decls] }
378 \end{code}
379
380
381 %************************************************************************
382 %*                                                                      *
383         Type-checking the top level of a module
384 %*                                                                      *
385 %************************************************************************
386
387 \begin{code}
388 tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv
389         -- Returns the variables free in the decls
390         -- Reason: solely to report unused imports and bindings
391 tcRnSrcDecls boot_iface decls
392  = do {         -- Do all the declarations
393         (tc_envs, lie) <- captureConstraints $ tc_rn_src_decls boot_iface decls ;
394       ; traceTc "Tc8" empty ;
395       ; setEnvs tc_envs $ 
396    do { 
397
398              --         Finish simplifying class constraints
399              -- 
400              -- simplifyTop deals with constant or ambiguous InstIds.  
401              -- How could there be ambiguous ones?  They can only arise if a
402              -- top-level decl falls under the monomorphism restriction
403              -- and no subsequent decl instantiates its type.
404              --
405              -- We do this after checkMain, so that we use the type info 
406              -- thaat checkMain adds
407              -- 
408              -- We do it with both global and local env in scope:
409              --  * the global env exposes the instances to simplifyTop
410              --  * the local env exposes the local Ids to simplifyTop, 
411              --    so that we get better error messages (monomorphism restriction)
412         new_ev_binds <- simplifyTop lie ;
413         traceTc "Tc9" empty ;
414
415         failIfErrsM ;   -- Don't zonk if there have been errors
416                         -- It's a waste of time; and we may get debug warnings
417                         -- about strangely-typed TyCons!
418
419         -- Zonk the final code.  This must be done last.
420         -- Even simplifyTop may do some unification.
421         -- This pass also warns about missing type signatures
422         let { (tcg_env, _) = tc_envs
423             ; TcGblEnv { tcg_type_env  = type_env,
424                          tcg_binds     = binds,
425                          tcg_sigs      = sig_ns,
426                          tcg_ev_binds  = cur_ev_binds,
427                          tcg_imp_specs = imp_specs,
428                          tcg_rules     = rules,
429                          tcg_vects     = vects,
430                          tcg_fords     = fords } = tcg_env
431             ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ;
432
433         (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') 
434             <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords ;
435         
436         let { final_type_env = extendTypeEnvWithIds type_env bind_ids
437             ; tcg_env' = tcg_env { tcg_binds    = binds',
438                                    tcg_ev_binds = ev_binds',
439                                    tcg_imp_specs = imp_specs',
440                                    tcg_rules    = rules', 
441                                    tcg_vects    = vects', 
442                                    tcg_fords    = fords' } } ;
443
444         setGlobalTypeEnv tcg_env' final_type_env                                   
445    } }
446
447 tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
448 -- Loops around dealing with each top level inter-splice group 
449 -- in turn, until it's dealt with the entire module
450 tc_rn_src_decls boot_details ds
451  = do { (first_group, group_tail) <- findSplice ds  ;
452                 -- If ds is [] we get ([], Nothing)
453
454         -- Deal with decls up to, but not including, the first splice
455         (tcg_env, rn_decls) <- rnTopSrcDecls first_group ;
456                 -- rnTopSrcDecls fails if there are any errors
457
458         (tcg_env, tcl_env) <- setGblEnv tcg_env $ 
459                               tcTopSrcDecls boot_details rn_decls ;
460
461         -- If there is no splice, we're nearly done
462         setEnvs (tcg_env, tcl_env) $ 
463         case group_tail of {
464            Nothing -> do { tcg_env <- checkMain ;       -- Check for `main'
465                            return (tcg_env, tcl_env) 
466                       } ;
467
468 #ifndef GHCI
469         -- There shouldn't be a splice
470            Just (SpliceDecl {}, _) -> do {
471         failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
472 #else
473         -- If there's a splice, we must carry on
474            Just (SpliceDecl splice_expr _, rest_ds) -> do {
475
476         -- Rename the splice expression, and get its supporting decls
477         (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ;
478                 -- checkNoErrs: don't typecheck if renaming failed
479         rnDump (ppr rn_splice_expr) ;
480
481         -- Execute the splice
482         spliced_decls <- tcSpliceDecls rn_splice_expr ;
483
484         -- Glue them on the front of the remaining decls and loop
485         setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
486         tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
487 #endif /* GHCI */
488     } } }
489 \end{code}
490
491 %************************************************************************
492 %*                                                                      *
493         Compiling hs-boot source files, and
494         comparing the hi-boot interface with the real thing
495 %*                                                                      *
496 %************************************************************************
497
498 \begin{code}
499 tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
500 tcRnHsBootDecls decls
501    = do { (first_group, group_tail) <- findSplice decls
502
503                 -- Rename the declarations
504         ; (tcg_env, HsGroup { 
505                    hs_tyclds = tycl_decls, 
506                    hs_instds = inst_decls,
507                    hs_derivds = deriv_decls,
508                    hs_fords  = for_decls,
509                    hs_defds  = def_decls,  
510                    hs_ruleds = rule_decls, 
511                    hs_vects  = vect_decls, 
512                    hs_annds  = _,
513                    hs_valds  = val_binds }) <- rnTopSrcDecls first_group
514         ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do {
515
516
517                 -- Check for illegal declarations
518         ; case group_tail of
519              Just (SpliceDecl d _, _) -> badBootDecl "splice" d
520              Nothing                  -> return ()
521         ; mapM_ (badBootDecl "foreign") for_decls
522         ; mapM_ (badBootDecl "default") def_decls
523         ; mapM_ (badBootDecl "rule")    rule_decls
524         ; mapM_ (badBootDecl "vect")    vect_decls
525
526                 -- Typecheck type/class decls
527         ; traceTc "Tc2" empty
528         ; (tcg_env, aux_binds) 
529                <- tcTyAndClassDecls emptyModDetails tycl_decls
530         ; setGblEnv tcg_env    $ do {
531
532                 -- Typecheck instance decls
533                 -- Family instance declarations are rejected here
534         ; traceTc "Tc3" empty
535         ; (tcg_env, inst_infos, _deriv_binds) 
536             <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls
537
538         ; setGblEnv tcg_env     $ do {
539
540                 -- Typecheck value declarations
541         ; traceTc "Tc5" empty 
542         ; val_ids <- tcHsBootSigs val_binds
543
544                 -- Wrap up
545                 -- No simplification or zonking to do
546         ; traceTc "Tc7a" empty
547         ; gbl_env <- getGblEnv 
548         
549                 -- Make the final type-env
550                 -- Include the dfun_ids so that their type sigs
551                 -- are written into the interface file. 
552                 -- And similarly the aux_ids from aux_binds
553         ; let { type_env0 = tcg_type_env gbl_env
554               ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
555               ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids 
556               ; type_env3 = extendTypeEnvWithIds type_env2 aux_ids 
557               ; dfun_ids = map iDFunId inst_infos
558               ; aux_ids  = case aux_binds of
559                              ValBindsOut _ sigs -> [id | L _ (IdSig id) <- sigs]
560                              _                  -> panic "tcRnHsBoodDecls"
561               }
562
563         ; setGlobalTypeEnv gbl_env type_env3
564    }}}
565    ; traceTc "boot" (ppr lie); return gbl_env }
566
567 badBootDecl :: String -> Located decl -> TcM ()
568 badBootDecl what (L loc _) 
569   = addErrAt loc (char 'A' <+> text what 
570       <+> ptext (sLit "declaration is not (currently) allowed in a hs-boot file"))
571 \end{code}
572
573 Once we've typechecked the body of the module, we want to compare what
574 we've found (gathered in a TypeEnv) with the hi-boot details (if any).
575
576 \begin{code}
577 checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv
578 -- Compare the hi-boot file for this module (if there is one)
579 -- with the type environment we've just come up with
580 -- In the common case where there is no hi-boot file, the list
581 -- of boot_names is empty.
582 --
583 -- The bindings we return give bindings for the dfuns defined in the
584 -- hs-boot file, such as        $fbEqT = $fEqT
585
586 checkHiBootIface
587         tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds,
588                             tcg_insts = local_insts, 
589                             tcg_type_env = local_type_env, tcg_exports = local_exports })
590         (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
591                       md_types = boot_type_env, md_exports = boot_exports })
592   | isHsBoot hs_src     -- Current module is already a hs-boot file!
593   = return tcg_env      
594
595   | otherwise
596   = do  { traceTc "checkHiBootIface" $ vcat
597              [ ppr boot_type_env, ppr boot_insts, ppr boot_exports]
598
599                 -- Check the exports of the boot module, one by one
600         ; mapM_ check_export boot_exports
601
602                 -- Check for no family instances
603         ; unless (null boot_fam_insts) $
604             panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
605                    "instances in boot files yet...")
606             -- FIXME: Why?  The actual comparison is not hard, but what would
607             --        be the equivalent to the dfun bindings returned for class
608             --        instances?  We can't easily equate tycons...
609
610                 -- Check instance declarations
611         ; mb_dfun_prs <- mapM check_inst boot_insts
612         ; let dfun_prs   = catMaybes mb_dfun_prs
613               boot_dfuns = map fst dfun_prs
614               dfun_binds = listToBag [ mkVarBind boot_dfun (nlHsVar dfun)
615                                      | (boot_dfun, dfun) <- dfun_prs ]
616               type_env'  = extendTypeEnvWithIds local_type_env boot_dfuns
617               tcg_env'   = tcg_env { tcg_binds = binds `unionBags` dfun_binds }
618
619         ; failIfErrsM
620         ; setGlobalTypeEnv tcg_env' type_env' }
621              -- Update the global type env *including* the knot-tied one
622              -- so that if the source module reads in an interface unfolding
623              -- mentioning one of the dfuns from the boot module, then it
624              -- can "see" that boot dfun.   See Trac #4003
625   where
626     check_export boot_avail     -- boot_avail is exported by the boot iface
627       | name `elem` dfun_names = return ()      
628       | isWiredInName name     = return ()      -- No checking for wired-in names.  In particular,
629                                                 -- 'error' is handled by a rather gross hack
630                                                 -- (see comments in GHC.Err.hs-boot)
631
632         -- Check that the actual module exports the same thing
633       | not (null missing_names)
634       = addErrAt (nameSrcSpan (head missing_names)) 
635                  (missingBootThing (head missing_names) "exported by")
636
637         -- If the boot module does not *define* the thing, we are done
638         -- (it simply re-exports it, and names match, so nothing further to do)
639       | isNothing mb_boot_thing = return ()
640
641         -- Check that the actual module also defines the thing, and 
642         -- then compare the definitions
643       | Just real_thing <- lookupTypeEnv local_type_env name,
644         Just boot_thing <- mb_boot_thing
645       = when (not (checkBootDecl boot_thing real_thing))
646             $ addErrAt (nameSrcSpan (getName boot_thing))
647                        (let boot_decl = tyThingToIfaceDecl 
648                                                (fromJust mb_boot_thing)
649                             real_decl = tyThingToIfaceDecl real_thing
650                         in bootMisMatch real_thing boot_decl real_decl)
651
652       | otherwise
653       = addErrTc (missingBootThing name "defined in")
654       where
655         name          = availName boot_avail
656         mb_boot_thing = lookupTypeEnv boot_type_env name
657         missing_names = case lookupNameEnv local_export_env name of
658                           Nothing    -> [name]
659                           Just avail -> availNames boot_avail `minusList` availNames avail
660                  
661     dfun_names = map getName boot_insts
662
663     local_export_env :: NameEnv AvailInfo
664     local_export_env = availsToNameEnv local_exports
665
666     check_inst :: Instance -> TcM (Maybe (Id, Id))
667         -- Returns a pair of the boot dfun in terms of the equivalent real dfun
668     check_inst boot_inst
669         = case [dfun | inst <- local_insts, 
670                        let dfun = instanceDFunId inst,
671                        idType dfun `eqType` boot_inst_ty ] of
672             [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts)
673                                                   , text "boot_inst"   <+> ppr boot_inst
674                                                   , text "boot_inst_ty" <+> ppr boot_inst_ty
675                                                   ]) 
676                      ; addErrTc (instMisMatch boot_inst); return Nothing }
677             (dfun:_) -> return (Just (local_boot_dfun, dfun))
678         where
679           boot_dfun = instanceDFunId boot_inst
680           boot_inst_ty = idType boot_dfun
681           local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
682
683
684 -- This has to compare the TyThing from the .hi-boot file to the TyThing
685 -- in the current source file.  We must be careful to allow alpha-renaming
686 -- where appropriate, and also the boot declaration is allowed to omit
687 -- constructors and class methods.
688 --
689 -- See rnfail055 for a good test of this stuff.
690
691 checkBootDecl :: TyThing -> TyThing -> Bool
692
693 checkBootDecl (AnId id1) (AnId id2)
694   = ASSERT(id1 == id2) 
695     (idType id1 `eqType` idType id2)
696
697 checkBootDecl (ATyCon tc1) (ATyCon tc2)
698   = checkBootTyCon tc1 tc2
699
700 checkBootDecl (ADataCon dc1) (ADataCon _)
701   = pprPanic "checkBootDecl" (ppr dc1)
702
703 checkBootDecl _ _ = False -- probably shouldn't happen
704
705 ----------------
706 checkBootTyCon :: TyCon -> TyCon -> Bool
707 checkBootTyCon tc1 tc2
708   | not (eqKind (tyConKind tc1) (tyConKind tc2))
709   = False       -- First off, check the kind
710
711   | Just c1 <- tyConClass_maybe tc1
712   , Just c2 <- tyConClass_maybe tc2
713   = let 
714        (clas_tyvars1, clas_fds1, sc_theta1, _, ats1, op_stuff1) 
715           = classExtraBigSig c1
716        (clas_tyvars2, clas_fds2, sc_theta2, _, ats2, op_stuff2) 
717           = classExtraBigSig c2
718
719        env0 = mkRnEnv2 emptyInScopeSet
720        env = rnBndrs2 env0 clas_tyvars1 clas_tyvars2
721
722        eqSig (id1, def_meth1) (id2, def_meth2)
723          = idName id1 == idName id2 &&
724            eqTypeX env op_ty1 op_ty2 &&
725            def_meth1 == def_meth2
726          where
727           (_, rho_ty1) = splitForAllTys (idType id1)
728           op_ty1 = funResultTy rho_ty1
729           (_, rho_ty2) = splitForAllTys (idType id2)
730           op_ty2 = funResultTy rho_ty2
731
732        eqFD (as1,bs1) (as2,bs2) = 
733          eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) &&
734          eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2)
735
736        same_kind tv1 tv2 = eqKind (tyVarKind tv1) (tyVarKind tv2)
737     in
738        eqListBy same_kind clas_tyvars1 clas_tyvars2 &&
739              -- Checks kind of class
740        eqListBy eqFD clas_fds1 clas_fds2 &&
741        (null sc_theta1 && null op_stuff1 && null ats1
742         ||   -- Above tests for an "abstract" class
743         eqListBy (eqPredX env) sc_theta1 sc_theta2 &&
744         eqListBy eqSig op_stuff1 op_stuff2 &&
745         eqListBy checkBootTyCon ats1 ats2)
746
747   | isSynTyCon tc1 && isSynTyCon tc2
748   = ASSERT(tc1 == tc2)
749     let tvs1 = tyConTyVars tc1; tvs2 = tyConTyVars tc2
750         env = rnBndrs2 env0 tvs1 tvs2
751
752         eqSynRhs SynFamilyTyCon SynFamilyTyCon
753             = True
754         eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2)
755             = eqTypeX env t1 t2
756         eqSynRhs _ _ = False
757     in
758     equalLength tvs1 tvs2 &&
759     eqSynRhs (synTyConRhs tc1) (synTyConRhs tc2)
760
761   | isAlgTyCon tc1 && isAlgTyCon tc2
762   = ASSERT(tc1 == tc2)
763     eqKind (tyConKind tc1) (tyConKind tc2) &&
764     eqListBy eqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) &&
765     eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2)
766
767   | isForeignTyCon tc1 && isForeignTyCon tc2
768   = eqKind (tyConKind tc1) (tyConKind tc2) &&
769     tyConExtName tc1 == tyConExtName tc2
770
771   | otherwise = False
772   where 
773         env0 = mkRnEnv2 emptyInScopeSet
774
775         eqAlgRhs (AbstractTyCon dis1) rhs2 
776           | dis1      = isDistinctAlgRhs rhs2   --Check compatibility
777           | otherwise = True
778         eqAlgRhs DataFamilyTyCon{} DataFamilyTyCon{} = True
779         eqAlgRhs tc1@DataTyCon{} tc2@DataTyCon{} =
780             eqListBy eqCon (data_cons tc1) (data_cons tc2)
781         eqAlgRhs tc1@NewTyCon{} tc2@NewTyCon{} =
782             eqCon (data_con tc1) (data_con tc2)
783         eqAlgRhs _ _ = False
784
785         eqCon c1 c2
786           =  dataConName c1 == dataConName c2
787           && dataConIsInfix c1 == dataConIsInfix c2
788           && dataConStrictMarks c1 == dataConStrictMarks c2
789           && dataConFieldLabels c1 == dataConFieldLabels c2
790           && eqType (dataConUserType c1) (dataConUserType c2)
791
792 ----------------
793 missingBootThing :: Name -> String -> SDoc
794 missingBootThing name what
795   = ppr name <+> ptext (sLit "is exported by the hs-boot file, but not") 
796               <+> text what <+> ptext (sLit "the module")
797
798 bootMisMatch :: TyThing -> IfaceDecl -> IfaceDecl -> SDoc
799 bootMisMatch thing boot_decl real_decl
800   = vcat [ppr thing <+> ptext (sLit "has conflicting definitions in the module and its hs-boot file"),
801           ptext (sLit "Main module:") <+> ppr real_decl,
802           ptext (sLit "Boot file:  ") <+> ppr boot_decl]
803
804 instMisMatch :: Instance -> SDoc
805 instMisMatch inst
806   = hang (ppr inst)
807        2 (ptext (sLit "is defined in the hs-boot file, but not in the module itself"))
808 \end{code}
809
810
811 %************************************************************************
812 %*                                                                      *
813         Type-checking the top level of a module
814 %*                                                                      *
815 %************************************************************************
816
817 tcRnGroup takes a bunch of top-level source-code declarations, and
818  * renames them
819  * gets supporting declarations from interface files
820  * typechecks them
821  * zonks them
822  * and augments the TcGblEnv with the results
823
824 In Template Haskell it may be called repeatedly for each group of
825 declarations.  It expects there to be an incoming TcGblEnv in the
826 monad; it augments it and returns the new TcGblEnv.
827
828 \begin{code}
829 ------------------------------------------------
830 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
831 -- Fails if there are any errors
832 rnTopSrcDecls group
833  = do { -- Rename the source decls
834         traceTc "rn12" empty ;
835         (tcg_env, rn_decls) <- checkNoErrs $ rnSrcDecls group ;
836         traceTc "rn13" empty ;
837
838         -- save the renamed syntax, if we want it
839         let { tcg_env'
840                 | Just grp <- tcg_rn_decls tcg_env
841                   = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
842                 | otherwise
843                    = tcg_env };
844
845                 -- Dump trace of renaming part
846         rnDump (ppr rn_decls) ;
847
848         return (tcg_env', rn_decls)
849    }
850
851 ------------------------------------------------
852 tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
853 tcTopSrcDecls boot_details
854         (HsGroup { hs_tyclds = tycl_decls, 
855                    hs_instds = inst_decls,
856                    hs_derivds = deriv_decls,
857                    hs_fords  = foreign_decls,
858                    hs_defds  = default_decls,
859                    hs_annds  = annotation_decls,
860                    hs_ruleds = rule_decls,
861                    hs_vects  = vect_decls,
862                    hs_valds  = val_binds })
863  = do {         -- Type-check the type and class decls, and all imported decls
864                 -- The latter come in via tycl_decls
865         traceTc "Tc2" empty ;
866
867         (tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ;
868                 -- If there are any errors, tcTyAndClassDecls fails here
869         
870         setGblEnv tcg_env       $ do {
871
872                 -- Source-language instances, including derivings,
873                 -- and import the supporting declarations
874         traceTc "Tc3" empty ;
875         (tcg_env, inst_infos, deriv_binds) 
876             <- tcInstDecls1 (concat tycl_decls) inst_decls deriv_decls;
877         setGblEnv tcg_env       $ do {
878
879                 -- Foreign import declarations next. 
880         traceTc "Tc4" empty ;
881         (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
882         tcExtendGlobalValEnv fi_ids     $ do {
883
884                 -- Default declarations
885         traceTc "Tc4a" empty ;
886         default_tys <- tcDefaults default_decls ;
887         updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
888         
889                 -- Now GHC-generated derived bindings, generics, and selectors
890                 -- Do not generate warnings from compiler-generated code;
891                 -- hence the use of discardWarnings
892         (tc_aux_binds,   specs1, tcl_env) <- discardWarnings (tcTopBinds aux_binds) ;
893         (tc_deriv_binds, specs2, tcl_env) <- setLclTypeEnv tcl_env $ 
894                                              discardWarnings (tcTopBinds deriv_binds) ;
895
896                 -- Value declarations next
897         traceTc "Tc5" empty ;
898         (tc_val_binds, specs3, tcl_env) <- setLclTypeEnv tcl_env $
899                                            tcTopBinds val_binds;
900
901         setLclTypeEnv tcl_env $ do {    -- Environment doesn't change now
902
903                 -- Second pass over class and instance declarations, 
904                 -- now using the kind-checked decls
905         traceTc "Tc6" empty ;
906         inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ;
907
908                 -- Foreign exports
909         traceTc "Tc7" empty ;
910         (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
911
912                 -- Annotations
913         annotations <- tcAnnotations annotation_decls ;
914
915                 -- Rules
916         rules <- tcRules rule_decls ;
917
918                 -- Vectorisation declarations
919         vects <- tcVectDecls vect_decls ;
920
921                 -- Wrap up
922         traceTc "Tc7a" empty ;
923         tcg_env <- getGblEnv ;
924         let { all_binds = tc_val_binds   `unionBags`
925                           tc_deriv_binds `unionBags`
926                           tc_aux_binds   `unionBags`
927                           inst_binds     `unionBags`
928                           foe_binds
929
930             ; sig_names = mkNameSet (collectHsValBinders val_binds) 
931                           `minusNameSet` getTypeSigNames val_binds
932
933                 -- Extend the GblEnv with the (as yet un-zonked) 
934                 -- bindings, rules, foreign decls
935             ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds
936                                  , tcg_imp_specs = tcg_imp_specs tcg_env ++ specs1 ++ specs2 ++
937                                                    specs3
938                                  , tcg_sigs  = tcg_sigs tcg_env `unionNameSets` sig_names
939                                  , tcg_rules = tcg_rules tcg_env ++ rules
940                                  , tcg_vects = tcg_vects tcg_env ++ vects
941                                  , tcg_anns  = tcg_anns tcg_env ++ annotations
942                                  , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
943         return (tcg_env', tcl_env)
944     }}}}}}
945 \end{code}
946
947
948 %************************************************************************
949 %*                                                                      *
950         Checking for 'main'
951 %*                                                                      *
952 %************************************************************************
953
954 \begin{code}
955 checkMain :: TcM TcGblEnv
956 -- If we are in module Main, check that 'main' is defined.
957 checkMain 
958   = do { tcg_env   <- getGblEnv ;
959          dflags    <- getDOpts ;
960          check_main dflags tcg_env
961     }
962
963 check_main :: DynFlags -> TcGblEnv -> TcM TcGblEnv
964 check_main dflags tcg_env
965  | mod /= main_mod
966  = traceTc "checkMain not" (ppr main_mod <+> ppr mod) >>
967    return tcg_env
968
969  | otherwise
970  = do   { mb_main <- lookupGlobalOccRn_maybe main_fn
971                 -- Check that 'main' is in scope
972                 -- It might be imported from another module!
973         ; case mb_main of {
974              Nothing -> do { traceTc "checkMain fail" (ppr main_mod <+> ppr main_fn)
975                            ; complain_no_main   
976                            ; return tcg_env } ;
977              Just main_name -> do
978
979         { traceTc "checkMain found" (ppr main_mod <+> ppr main_fn)
980         ; let loc = srcLocSpan (getSrcLoc main_name)
981         ; ioTyCon <- tcLookupTyCon ioTyConName
982         ; res_ty <- newFlexiTyVarTy liftedTypeKind
983         ; main_expr
984                 <- addErrCtxt mainCtxt    $
985                    tcMonoExpr (L loc (HsVar main_name)) (mkTyConApp ioTyCon [res_ty])
986
987                 -- See Note [Root-main Id]
988                 -- Construct the binding
989                 --      :Main.main :: IO res_ty = runMainIO res_ty main 
990         ; run_main_id <- tcLookupId runMainIOName
991         ; let { root_main_name =  mkExternalName rootMainKey rOOT_MAIN 
992                                    (mkVarOccFS (fsLit "main")) 
993                                    (getSrcSpan main_name)
994               ; root_main_id = Id.mkExportedLocalId root_main_name 
995                                                     (mkTyConApp ioTyCon [res_ty])
996               ; co  = mkWpTyApps [res_ty]
997               ; rhs = nlHsApp (mkLHsWrap co (nlHsVar run_main_id)) main_expr
998               ; main_bind = mkVarBind root_main_id rhs }
999
1000         ; return (tcg_env { tcg_main  = Just main_name,
1001                             tcg_binds = tcg_binds tcg_env
1002                                         `snocBag` main_bind,
1003                             tcg_dus   = tcg_dus tcg_env
1004                                         `plusDU` usesOnly (unitFV main_name)
1005                         -- Record the use of 'main', so that we don't 
1006                         -- complain about it being defined but not used
1007                  })
1008     }}}
1009   where
1010     mod          = tcg_mod tcg_env
1011     main_mod     = mainModIs dflags
1012     main_fn      = getMainFun dflags
1013
1014     complain_no_main | ghcLink dflags == LinkInMemory = return ()
1015                      | otherwise = failWithTc noMainMsg
1016         -- In interactive mode, don't worry about the absence of 'main'
1017         -- In other modes, fail altogether, so that we don't go on
1018         -- and complain a second time when processing the export list.
1019
1020     mainCtxt  = ptext (sLit "When checking the type of the") <+> pp_main_fn
1021     noMainMsg = ptext (sLit "The") <+> pp_main_fn
1022                 <+> ptext (sLit "is not defined in module") <+> quotes (ppr main_mod)
1023     pp_main_fn = ppMainFn main_fn
1024
1025 ppMainFn :: RdrName -> SDoc
1026 ppMainFn main_fn
1027   | main_fn == main_RDR_Unqual
1028   = ptext (sLit "function") <+> quotes (ppr main_fn)
1029   | otherwise
1030   = ptext (sLit "main function") <+> quotes (ppr main_fn)
1031                
1032 -- | Get the unqualified name of the function to use as the \"main\" for the main module.
1033 -- Either returns the default name or the one configured on the command line with -main-is
1034 getMainFun :: DynFlags -> RdrName
1035 getMainFun dflags = case (mainFunIs dflags) of
1036     Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn))
1037     Nothing -> main_RDR_Unqual
1038
1039 checkMainExported :: TcGblEnv -> TcM ()
1040 checkMainExported tcg_env = do
1041   dflags    <- getDOpts
1042   case tcg_main tcg_env of
1043     Nothing -> return () -- not the main module
1044     Just main_name -> do
1045       let main_mod = mainModIs dflags
1046       checkTc (main_name `elem` concatMap availNames (tcg_exports tcg_env)) $
1047               ptext (sLit "The") <+> ppMainFn (nameRdrName main_name) <+>
1048               ptext (sLit "is not exported by module") <+> quotes (ppr main_mod)
1049 \end{code}
1050
1051 Note [Root-main Id]
1052 ~~~~~~~~~~~~~~~~~~~
1053 The function that the RTS invokes is always :Main.main, which we call
1054 root_main_id.  (Because GHC allows the user to have a module not
1055 called Main as the main module, we can't rely on the main function
1056 being called "Main.main".  That's why root_main_id has a fixed module
1057 ":Main".)  
1058
1059 This is unusual: it's a LocalId whose Name has a Module from another
1060 module.  Tiresomely, we must filter it out again in MkIface, les we
1061 get two defns for 'main' in the interface file!
1062
1063
1064 %*********************************************************
1065 %*                                                       *
1066                 GHCi stuff
1067 %*                                                       *
1068 %*********************************************************
1069
1070 \begin{code}
1071 setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
1072 setInteractiveContext hsc_env icxt thing_inside 
1073   = let -- Initialise the tcg_inst_env with instances from all home modules.  
1074         -- This mimics the more selective call to hptInstances in tcRnModule.
1075         (home_insts, home_fam_insts) = hptInstances hsc_env (\_ -> True)
1076     in
1077     updGblEnv (\env -> env { 
1078         tcg_rdr_env      = ic_rn_gbl_env icxt,
1079         tcg_inst_env     = extendInstEnvList    (tcg_inst_env env) home_insts,
1080         tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env env) 
1081                                                 home_fam_insts 
1082       }) $
1083
1084     tcExtendGhciEnv (ic_tmp_ids icxt) $
1085         -- tcExtendGhciEnv does lots: 
1086         --   - it extends the local type env (tcl_env) with the given Ids,
1087         --   - it extends the local rdr env (tcl_rdr) with the Names from 
1088         --     the given Ids
1089         --   - it adds the free tyvars of the Ids to the tcl_tyvars
1090         --     set.
1091         --
1092         -- later ids in ic_tmp_ids must shadow earlier ones with the same
1093         -- OccName, and tcExtendIdEnv implements this behaviour.
1094
1095     do  { traceTc "setIC" (ppr (ic_tmp_ids icxt))
1096         ; thing_inside }
1097 \end{code}
1098
1099
1100 \begin{code}
1101 #ifdef GHCI
1102 tcRnStmt :: HscEnv
1103          -> InteractiveContext
1104          -> LStmt RdrName
1105          -> IO (Messages, Maybe ([Id], LHsExpr Id))
1106                 -- The returned [Id] is the list of new Ids bound by
1107                 -- this statement.  It can be used to extend the
1108                 -- InteractiveContext via extendInteractiveContext.
1109                 --
1110                 -- The returned TypecheckedHsExpr is of type IO [ () ],
1111                 -- a list of the bound values, coerced to ().
1112
1113 tcRnStmt hsc_env ictxt rdr_stmt
1114   = initTcPrintErrors hsc_env iNTERACTIVE $ 
1115     setInteractiveContext hsc_env ictxt $ do {
1116
1117     -- Rename; use CmdLineMode because tcRnStmt is only used interactively
1118     (([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] $ \_ ->
1119                              return ((), emptyFVs) ;
1120     traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
1121     failIfErrsM ;
1122     rnDump (ppr rn_stmt) ;
1123     
1124     -- The real work is done here
1125     (bound_ids, tc_expr) <- mkPlan rn_stmt ;
1126     zonked_expr <- zonkTopLExpr tc_expr ;
1127     zonked_ids  <- zonkTopBndrs bound_ids ;
1128     
1129         -- None of the Ids should be of unboxed type, because we
1130         -- cast them all to HValues in the end!
1131     mapM_ bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
1132
1133     traceTc "tcs 1" empty ;
1134     let { global_ids = map globaliseAndTidyId zonked_ids } ;
1135         -- Note [Interactively-bound Ids in GHCi]
1136
1137 {- ---------------------------------------------
1138    At one stage I removed any shadowed bindings from the type_env;
1139    they are inaccessible but might, I suppose, cause a space leak if we leave them there.
1140    However, with Template Haskell they aren't necessarily inaccessible.  Consider this
1141    GHCi session
1142          Prelude> let f n = n * 2 :: Int
1143          Prelude> fName <- runQ [| f |]
1144          Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
1145          14
1146          Prelude> let f n = n * 3 :: Int
1147          Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
1148    In the last line we use 'fName', which resolves to the *first* 'f'
1149    in scope. If we delete it from the type env, GHCi crashes because
1150    it doesn't expect that.
1151  
1152    Hence this code is commented out
1153
1154 -------------------------------------------------- -}
1155
1156     dumpOptTcRn Opt_D_dump_tc 
1157         (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
1158                text "Typechecked expr" <+> ppr zonked_expr]) ;
1159
1160     return (global_ids, zonked_expr)
1161     }
1162   where
1163     bad_unboxed id = addErr (sep [ptext (sLit "GHCi can't bind a variable of unlifted type:"),
1164                                   nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
1165 \end{code}
1166
1167 Note [Interactively-bound Ids in GHCi]
1168 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
1169 The Ids bound by previous Stmts in Template Haskell are currently
1170         a) GlobalIds
1171         b) with an Internal Name (not External)
1172         c) and a tidied type
1173
1174  (a) They must be GlobalIds (not LocalIds) otherwise when we come to
1175      compile an expression using these ids later, the byte code
1176      generator will consider the occurrences to be free rather than
1177      global.
1178
1179  (b) They retain their Internal names becuase we don't have a suitable
1180      Module to name them with.  We could revisit this choice.
1181
1182  (c) Their types are tidied.  This is important, because :info may ask
1183      to look at them, and :info expects the things it looks up to have
1184      tidy types
1185         
1186
1187 --------------------------------------------------------------------------
1188                 Typechecking Stmts in GHCi
1189
1190 Here is the grand plan, implemented in tcUserStmt
1191
1192         What you type                   The IO [HValue] that hscStmt returns
1193         -------------                   ------------------------------------
1194         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
1195                                         bindings: [x,y,...]
1196
1197         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
1198                                         bindings: [x,y,...]
1199
1200         expr (of IO type)       ==>     expr >>= \ it -> return [coerce HVal it]
1201           [NB: result not printed]      bindings: [it]
1202           
1203         expr (of non-IO type,   ==>     let it = expr in print it >> return [coerce HVal it]
1204           result showable)              bindings: [it]
1205
1206         expr (of non-IO type, 
1207           result not showable)  ==>     error
1208
1209
1210 \begin{code}
1211 ---------------------------
1212 type PlanResult = ([Id], LHsExpr Id)
1213 type Plan = TcM PlanResult
1214
1215 runPlans :: [Plan] -> TcM PlanResult
1216 -- Try the plans in order.  If one fails (by raising an exn), try the next.
1217 -- If one succeeds, take it.
1218 runPlans []     = panic "runPlans"
1219 runPlans [p]    = p
1220 runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
1221
1222 --------------------
1223 mkPlan :: LStmt Name -> TcM PlanResult
1224 mkPlan (L loc (ExprStmt expr _ _ _))    -- An expression typed at the prompt 
1225   = do  { uniq <- newUnique             -- is treated very specially
1226         ; let fresh_it  = itName uniq
1227               the_bind  = L loc $ mkTopFunBind (L loc fresh_it) matches
1228               matches   = [mkMatch [] expr emptyLocalBinds]
1229               let_stmt  = L loc $ LetStmt $ HsValBinds $
1230                           ValBindsOut [(NonRecursive,unitBag the_bind)] []
1231               bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
1232                                            (HsVar bindIOName) noSyntaxExpr 
1233               print_it  = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
1234                                            (HsVar thenIOName) noSyntaxExpr placeHolderType
1235
1236         -- The plans are:
1237         --      [it <- e; print it]     but not if it::()
1238         --      [it <- e]               
1239         --      [let it = e; print it]  
1240         ; runPlans [    -- Plan A
1241                     do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
1242                        ; it_ty <- zonkTcType (idType it_id)
1243                        ; when (isUnitTy it_ty) failM
1244                        ; return stuff },
1245
1246                         -- Plan B; a naked bind statment
1247                     tcGhciStmts [bind_stmt],    
1248
1249                         -- Plan C; check that the let-binding is typeable all by itself.
1250                         -- If not, fail; if so, try to print it.
1251                         -- The two-step process avoids getting two errors: one from
1252                         -- the expression itself, and one from the 'print it' part
1253                         -- This two-step story is very clunky, alas
1254                     do { _ <- checkNoErrs (tcGhciStmts [let_stmt]) 
1255                                 --- checkNoErrs defeats the error recovery of let-bindings
1256                        ; tcGhciStmts [let_stmt, print_it] }
1257           ]}
1258
1259 mkPlan stmt@(L loc (BindStmt {}))
1260   | [v] <- collectLStmtBinders stmt             -- One binder, for a bind stmt 
1261   = do  { let print_v  = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
1262                                           (HsVar thenIOName) noSyntaxExpr placeHolderType
1263
1264         ; print_bind_result <- doptM Opt_PrintBindResult
1265         ; let print_plan = do
1266                   { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
1267                   ; v_ty <- zonkTcType (idType v_id)
1268                   ; when (isUnitTy v_ty || not (isTauTy v_ty)) failM
1269                   ; return stuff }
1270
1271         -- The plans are:
1272         --      [stmt; print v]         but not if v::()
1273         --      [stmt]
1274         ; runPlans ((if print_bind_result then [print_plan] else []) ++
1275                     [tcGhciStmts [stmt]])
1276         }
1277
1278 mkPlan stmt
1279   = tcGhciStmts [stmt]
1280
1281 ---------------------------
1282 tcGhciStmts :: [LStmt Name] -> TcM PlanResult
1283 tcGhciStmts stmts
1284  = do { ioTyCon <- tcLookupTyCon ioTyConName ;
1285         ret_id  <- tcLookupId returnIOName ;            -- return @ IO
1286         let {
1287             ret_ty    = mkListTy unitTy ;
1288             io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
1289             tc_io_stmts stmts = tcStmtsAndThen GhciStmt tcDoStmt stmts io_ret_ty ;
1290             names = collectLStmtsBinders stmts ;
1291          } ;
1292
1293         -- OK, we're ready to typecheck the stmts
1294         traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ;
1295         ((tc_stmts, ids), lie) <- captureConstraints $ 
1296                                   tc_io_stmts stmts  $ \ _ ->
1297                                   mapM tcLookupId names  ;
1298                         -- Look up the names right in the middle,
1299                         -- where they will all be in scope
1300
1301         -- Simplify the context
1302         traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ;
1303         const_binds <- checkNoErrs (simplifyInteractive lie) ;
1304                 -- checkNoErrs ensures that the plan fails if context redn fails
1305
1306         traceTc "TcRnDriver.tcGhciStmts: done" empty ;
1307         let {   -- mk_return builds the expression
1308                 --      returnIO @ [()] [coerce () x, ..,  coerce () z]
1309                 --
1310                 -- Despite the inconvenience of building the type applications etc,
1311                 -- this *has* to be done in type-annotated post-typecheck form
1312                 -- because we are going to return a list of *polymorphic* values
1313                 -- coerced to type (). If we built a *source* stmt
1314                 --      return [coerce x, ..., coerce z]
1315                 -- then the type checker would instantiate x..z, and we wouldn't
1316                 -- get their *polymorphic* values.  (And we'd get ambiguity errs
1317                 -- if they were overloaded, since they aren't applied to anything.)
1318             ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) 
1319                        (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
1320             mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
1321                                  (nlHsVar id) ;
1322             stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)]
1323         } ;
1324         return (ids, mkHsDictLet (EvBinds const_binds) $
1325                      noLoc (HsDo GhciStmt stmts io_ret_ty))
1326     }
1327 \end{code}
1328
1329
1330 tcRnExpr just finds the type of an expression
1331
1332 \begin{code}
1333 tcRnExpr :: HscEnv
1334          -> InteractiveContext
1335          -> LHsExpr RdrName
1336          -> IO (Messages, Maybe Type)
1337 tcRnExpr hsc_env ictxt rdr_expr
1338   = initTcPrintErrors hsc_env iNTERACTIVE $ 
1339     setInteractiveContext hsc_env ictxt $ do {
1340
1341     (rn_expr, _fvs) <- rnLExpr rdr_expr ;
1342     failIfErrsM ;
1343
1344         -- Now typecheck the expression; 
1345         -- it might have a rank-2 type (e.g. :t runST)
1346     uniq <- newUnique ;
1347     let { fresh_it  = itName uniq } ;
1348     ((_tc_expr, res_ty), lie)   <- captureConstraints (tcInferRho rn_expr) ;
1349     ((qtvs, dicts, _, _), lie_top) <- captureConstraints $ 
1350                                       simplifyInfer True {- Free vars are closed -}
1351                                                     False {- No MR for now -}
1352                                                     [(fresh_it, res_ty)]
1353                                                     lie  ;
1354     _ <- simplifyInteractive lie_top ;       -- Ignore the dicionary bindings
1355
1356     let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
1357     zonkTcType all_expr_ty
1358     }
1359 \end{code}
1360
1361 tcRnType just finds the kind of a type
1362
1363 \begin{code}
1364 tcRnType :: HscEnv
1365          -> InteractiveContext
1366          -> LHsType RdrName
1367          -> IO (Messages, Maybe Kind)
1368 tcRnType hsc_env ictxt rdr_type
1369   = initTcPrintErrors hsc_env iNTERACTIVE $ 
1370     setInteractiveContext hsc_env ictxt $ do {
1371
1372     rn_type <- rnLHsType doc rdr_type ;
1373     failIfErrsM ;
1374
1375         -- Now kind-check the type
1376     (_ty', kind) <- kcLHsType rn_type ;
1377     return kind
1378     }
1379   where
1380     doc = ptext (sLit "In GHCi input")
1381
1382 #endif /* GHCi */
1383 \end{code}
1384
1385
1386 %************************************************************************
1387 %*                                                                      *
1388         More GHCi stuff, to do with browsing and getting info
1389 %*                                                                      *
1390 %************************************************************************
1391
1392 \begin{code}
1393 #ifdef GHCI
1394 -- | ASSUMES that the module is either in the 'HomePackageTable' or is
1395 -- a package module with an interface on disk.  If neither of these is
1396 -- true, then the result will be an error indicating the interface
1397 -- could not be found.
1398 getModuleInterface :: HscEnv -> Module -> IO (Messages, Maybe ModIface)
1399 getModuleInterface hsc_env mod
1400   = initTc hsc_env HsSrcFile False iNTERACTIVE $
1401     loadModuleInterface (ptext (sLit "getModuleInterface")) mod
1402
1403 tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Messages, Maybe [Name])
1404 tcRnLookupRdrName hsc_env rdr_name 
1405   = initTcPrintErrors hsc_env iNTERACTIVE $ 
1406     setInteractiveContext hsc_env (hsc_IC hsc_env) $ 
1407     lookup_rdr_name rdr_name
1408
1409 lookup_rdr_name :: RdrName -> TcM [Name]
1410 lookup_rdr_name rdr_name = do {
1411         -- If the identifier is a constructor (begins with an
1412         -- upper-case letter), then we need to consider both
1413         -- constructor and type class identifiers.
1414     let { rdr_names = dataTcOccs rdr_name } ;
1415
1416         -- results :: [Either Messages Name]
1417     results <- mapM (tryTcErrs . lookupOccRn) rdr_names ;
1418
1419     traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
1420         -- The successful lookups will be (Just name)
1421     let { (warns_s, good_names) = unzip [ (msgs, name) 
1422                                         | (msgs, Just name) <- results] ;
1423           errs_s = [msgs | (msgs, Nothing) <- results] } ;
1424
1425         -- Fail if nothing good happened, else add warnings
1426     if null good_names then
1427                 -- No lookup succeeded, so
1428                 -- pick the first error message and report it
1429                 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
1430                 --       while the other is "X is not in scope", 
1431                 --       we definitely want the former; but we might pick the latter
1432         do { addMessages (head errs_s) ; failM }
1433       else                      -- Add deprecation warnings
1434         mapM_ addMessages warns_s ;
1435     
1436     return good_names
1437  }
1438 #endif
1439
1440 tcRnLookupName :: HscEnv -> Name -> IO (Messages, Maybe TyThing)
1441 tcRnLookupName hsc_env name
1442   = initTcPrintErrors hsc_env iNTERACTIVE $ 
1443     setInteractiveContext hsc_env (hsc_IC hsc_env) $
1444     tcRnLookupName' name
1445
1446 -- To look up a name we have to look in the local environment (tcl_lcl)
1447 -- as well as the global environment, which is what tcLookup does. 
1448 -- But we also want a TyThing, so we have to convert:
1449
1450 tcRnLookupName' :: Name -> TcRn TyThing
1451 tcRnLookupName' name = do
1452    tcthing <- tcLookup name
1453    case tcthing of
1454      AGlobal thing    -> return thing
1455      ATcId{tct_id=id} -> return (AnId id)
1456      _ -> panic "tcRnLookupName'"
1457
1458 tcRnGetInfo :: HscEnv
1459             -> Name
1460             -> IO (Messages, Maybe (TyThing, Fixity, [Instance]))
1461
1462 -- Used to implement :info in GHCi
1463 --
1464 -- Look up a RdrName and return all the TyThings it might be
1465 -- A capitalised RdrName is given to us in the DataName namespace,
1466 -- but we want to treat it as *both* a data constructor 
1467 --  *and* as a type or class constructor; 
1468 -- hence the call to dataTcOccs, and we return up to two results
1469 tcRnGetInfo hsc_env name
1470   = initTcPrintErrors hsc_env iNTERACTIVE $
1471     tcRnGetInfo' hsc_env name
1472
1473 tcRnGetInfo' :: HscEnv
1474              -> Name
1475              -> TcRn (TyThing, Fixity, [Instance])
1476 tcRnGetInfo' hsc_env name
1477   = let ictxt = hsc_IC hsc_env in
1478     setInteractiveContext hsc_env ictxt $ do
1479
1480         -- Load the interface for all unqualified types and classes
1481         -- That way we will find all the instance declarations
1482         -- (Packages have not orphan modules, and we assume that
1483         --  in the home package all relevant modules are loaded.)
1484     loadUnqualIfaces ictxt
1485
1486     thing  <- tcRnLookupName' name
1487     fixity <- lookupFixityRn name
1488     ispecs <- lookupInsts thing
1489     return (thing, fixity, ispecs)
1490
1491 lookupInsts :: TyThing -> TcM [Instance]
1492 lookupInsts (ATyCon tc)
1493   | Just cls <- tyConClass_maybe tc
1494   = do  { inst_envs <- tcGetInstEnvs
1495         ; return (classInstances inst_envs cls) }
1496
1497   | otherwise
1498   = do  { (pkg_ie, home_ie) <- tcGetInstEnvs
1499                 -- Load all instances for all classes that are
1500                 -- in the type environment (which are all the ones
1501                 -- we've seen in any interface file so far)
1502         ; return [ ispec        -- Search all
1503                  | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
1504                  , let dfun = instanceDFunId ispec
1505                  , relevant dfun ] } 
1506   where
1507     relevant df = tc_name `elemNameSet` orphNamesOfDFunHead (idType df)
1508     tc_name     = tyConName tc            
1509
1510 lookupInsts _ = return []
1511
1512 loadUnqualIfaces :: InteractiveContext -> TcM ()
1513 -- Load the home module for everything that is in scope unqualified
1514 -- This is so that we can accurately report the instances for 
1515 -- something
1516 loadUnqualIfaces ictxt
1517   = initIfaceTcRn $
1518     mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
1519   where
1520     unqual_mods = [ nameModule name
1521                   | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt),
1522                     let name = gre_name gre,
1523                     not (isInternalName name),
1524                     isTcOcc (nameOccName name),  -- Types and classes only
1525                     unQualOK gre ]               -- In scope unqualified
1526     doc = ptext (sLit "Need interface for module whose export(s) are in scope unqualified")
1527 \end{code}
1528
1529 %************************************************************************
1530 %*                                                                      *
1531                 Degugging output
1532 %*                                                                      *
1533 %************************************************************************
1534
1535 \begin{code}
1536 rnDump :: SDoc -> TcRn ()
1537 -- Dump, with a banner, if -ddump-rn
1538 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1539
1540 tcDump :: TcGblEnv -> TcRn ()
1541 tcDump env
1542  = do { dflags <- getDOpts ;
1543
1544         -- Dump short output if -ddump-types or -ddump-tc
1545         when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1546              (dumpTcRn short_dump) ;
1547
1548         -- Dump bindings if -ddump-tc
1549         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1550    }
1551   where
1552     short_dump = pprTcGblEnv env
1553     full_dump  = pprLHsBinds (tcg_binds env)
1554         -- NB: foreign x-d's have undefined's in their types; 
1555         --     hence can't show the tc_fords
1556
1557 tcCoreDump :: ModGuts -> TcM ()
1558 tcCoreDump mod_guts
1559  = do { dflags <- getDOpts ;
1560         when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1561              (dumpTcRn (pprModGuts mod_guts)) ;
1562
1563         -- Dump bindings if -ddump-tc
1564         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1565   where
1566     full_dump = pprCoreBindings (mg_binds mod_guts)
1567
1568 -- It's unpleasant having both pprModGuts and pprModDetails here
1569 pprTcGblEnv :: TcGblEnv -> SDoc
1570 pprTcGblEnv (TcGblEnv { tcg_type_env  = type_env, 
1571                         tcg_insts     = insts, 
1572                         tcg_fam_insts = fam_insts, 
1573                         tcg_rules     = rules,
1574                         tcg_vects     = vects,
1575                         tcg_imports   = imports })
1576   = vcat [ ppr_types insts type_env
1577          , ppr_tycons fam_insts type_env
1578          , ppr_insts insts
1579          , ppr_fam_insts fam_insts
1580          , vcat (map ppr rules)
1581          , vcat (map ppr vects)
1582          , ptext (sLit "Dependent modules:") <+> 
1583                 ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports))
1584          , ptext (sLit "Dependent packages:") <+> 
1585                 ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)]
1586   where         -- The two uses of sortBy are just to reduce unnecessary
1587                 -- wobbling in testsuite output
1588     cmp_mp (mod_name1, is_boot1) (mod_name2, is_boot2)
1589         = (mod_name1 `stableModuleNameCmp` mod_name2)
1590                   `thenCmp`     
1591           (is_boot1 `compare` is_boot2)
1592
1593 pprModGuts :: ModGuts -> SDoc
1594 pprModGuts (ModGuts { mg_types = type_env,
1595                       mg_rules = rules })
1596   = vcat [ ppr_types [] type_env,
1597            ppr_rules rules ]
1598
1599 ppr_types :: [Instance] -> TypeEnv -> SDoc
1600 ppr_types insts type_env
1601   = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1602   where
1603     dfun_ids = map instanceDFunId insts
1604     ids = [id | id <- typeEnvIds type_env, want_sig id]
1605     want_sig id | opt_PprStyle_Debug = True
1606                 | otherwise          = isLocalId id && 
1607                                        isExternalName (idName id) && 
1608                                        not (id `elem` dfun_ids)
1609         -- isLocalId ignores data constructors, records selectors etc.
1610         -- The isExternalName ignores local dictionary and method bindings
1611         -- that the type checker has invented.  Top-level user-defined things 
1612         -- have External names.
1613
1614 ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
1615 ppr_tycons fam_insts type_env
1616   = vcat [ text "TYPE CONSTRUCTORS"
1617          ,   nest 2 (ppr_tydecls tycons)
1618          , text "COERCION AXIOMS" 
1619          ,   nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ]
1620   where
1621     fi_tycons = map famInstTyCon fam_insts
1622     tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
1623     want_tycon tycon | opt_PprStyle_Debug = True
1624                      | otherwise          = not (isImplicitTyCon tycon) &&
1625                                             isExternalName (tyConName tycon) &&
1626                                             not (tycon `elem` fi_tycons)
1627
1628 ppr_insts :: [Instance] -> SDoc
1629 ppr_insts []     = empty
1630 ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
1631
1632 ppr_fam_insts :: [FamInst] -> SDoc
1633 ppr_fam_insts []        = empty
1634 ppr_fam_insts fam_insts = 
1635   text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts)
1636
1637 ppr_sigs :: [Var] -> SDoc
1638 ppr_sigs ids
1639         -- Print type signatures; sort by OccName 
1640   = vcat (map ppr_sig (sortLe le_sig ids))
1641   where
1642     le_sig id1 id2 = getOccName id1 <= getOccName id2
1643     ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
1644
1645 ppr_tydecls :: [TyCon] -> SDoc
1646 ppr_tydecls tycons
1647         -- Print type constructor info; sort by OccName 
1648   = vcat (map ppr_tycon (sortLe le_sig tycons))
1649   where
1650     le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
1651     ppr_tycon tycon = ppr (tyThingToIfaceDecl (ATyCon tycon))
1652
1653 ppr_rules :: [CoreRule] -> SDoc
1654 ppr_rules [] = empty
1655 ppr_rules rs = vcat [ptext (sLit "{-# RULES"),
1656                       nest 2 (pprRules rs),
1657                       ptext (sLit "#-}")]
1658 \end{code}