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