2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcModule]{Typechecking a whole module}
9 mkExportEnv, getModuleContents, tcRnStmt,
10 tcRnGetInfo, tcRnExpr, tcRnType,
17 #include "HsVersions.h"
20 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
23 import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
24 import DriverState ( v_MainModIs, v_MainFunIs )
25 import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..),
26 nlHsApp, nlHsVar, pprLHsBinds )
27 import RdrHsSyn ( findSplice )
29 import PrelNames ( runIOName, rootMainName, mAIN_Name,
31 import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv,
33 import TcHsSyn ( zonkTopDecls )
34 import TcExpr ( tcInferRho )
36 import TcType ( tidyTopType, isUnLiftedType )
37 import Inst ( showLIE )
38 import TcBinds ( tcTopBinds )
39 import TcDefaults ( tcDefaults )
40 import TcEnv ( tcExtendGlobalValEnv )
41 import TcRules ( tcRules )
42 import TcForeign ( tcForeignImports, tcForeignExports )
43 import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
44 import TcIface ( tcExtCoreBindings, loadImportedInsts )
45 import TcSimplify ( tcSimplifyTop )
46 import TcTyClsDecls ( tcTyAndClassDecls )
47 import LoadIface ( loadOrphanModules )
48 import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
49 reportUnusedNames, reportDeprecations )
50 import RnEnv ( lookupSrcOcc_maybe )
51 import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec )
52 import PprCore ( pprIdRules, pprCoreBindings )
53 import CoreSyn ( IdCoreRule, bindersOfBinds )
54 import ErrUtils ( Messages, mkDumpDoc, showPass )
55 import Id ( mkExportedLocalId, isLocalId, idName, idType )
57 import Module ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts )
58 import OccName ( mkVarOcc )
59 import Name ( Name, isExternalName, getSrcLoc, getOccName, nameSrcLoc )
61 import TyCon ( tyConHasGenerics )
62 import SrcLoc ( SrcLoc, srcLocSpan, Located(..), noLoc )
64 import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState( eps_is_boot ),
65 GhciMode(..), isOneShot, Dependencies(..), noDependencies,
66 Deprecs( NoDeprecs ), plusDeprecs,
67 ForeignStubs(NoStubs), TypeEnv,
68 extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
72 import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
73 LStmt, LHsExpr, LHsType,
74 collectStmtsBinders, mkSimpleMatch, placeHolderType,
75 nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat )
76 import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
77 Provenance(..), ImportSpec(..),
78 lookupLocalRdrEnv, extendLocalRdrEnv )
79 import RnSource ( addTcgDUs )
80 import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs )
81 import TcHsType ( kcHsType )
82 import TcExpr ( tcCheckRho )
83 import TcMType ( zonkTcType )
84 import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) )
85 import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer )
86 import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, tyClsNamesOfDFunHead )
87 import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
88 import RnTypes ( rnLHsType )
89 import Inst ( tcStdSyntaxName, tcGetInstEnvs )
90 import InstEnv ( DFunId, classInstances, instEnvElts )
91 import RnExpr ( rnStmts, rnLExpr )
92 import RnNames ( exportsToAvails )
93 import LoadIface ( loadSrcInterface )
94 import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
95 IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
96 tyThingToIfaceDecl, dfunToIfaceInst )
97 import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
98 import Id ( Id, isImplicitId, globalIdDetails )
99 import FieldLabel ( fieldLabelTyCon )
100 import MkId ( unsafeCoerceId )
101 import DataCon ( dataConTyCon )
102 import TyCon ( tyConName )
103 import TysWiredIn ( mkListTy, unitTy )
104 import IdInfo ( GlobalIdDetails(..) )
105 import SrcLoc ( interactiveSrcLoc, unLoc )
107 import Var ( globaliseId )
108 import Name ( nameOccName, nameModuleName )
109 import NameEnv ( delListFromNameEnv )
110 import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName )
111 import Module ( ModuleName, lookupModuleEnvByName )
112 import HscTypes ( InteractiveContext(..), ExternalPackageState( eps_PTE ),
113 HomeModInfo(..), typeEnvElts, typeEnvClasses,
114 TyThing(..), availName, availNames, icPrintUnqual,
115 ModIface(..), ModDetails(..) )
116 import BasicTypes ( RecFlag(..), Fixity )
117 import Bag ( unitBag )
118 import ListSetOps ( removeDups )
119 import Panic ( ghcError, GhcException(..) )
122 import FastString ( mkFastString )
123 import Util ( sortLe )
124 import Bag ( unionBags, snocBag )
126 import Maybe ( isJust )
131 %************************************************************************
133 Typecheck and rename a module
135 %************************************************************************
140 -> Located (HsModule RdrName)
141 -> IO (Messages, Maybe TcGblEnv)
143 tcRnModule hsc_env (L loc (HsModule maybe_mod exports
144 import_decls local_decls mod_deprec))
145 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
147 let { this_mod = case maybe_mod of
148 Nothing -> mkHomeModule mAIN_Name
149 -- 'module M where' is omitted
150 Just (L _ mod) -> mod } ;
153 initTc hsc_env this_mod $
155 do { -- Deal with imports; sets tcg_rdr_env, tcg_imports
156 (rdr_env, imports) <- rnImports import_decls ;
158 -- In one-shot mode, record boot-file info in the EPS
159 ifM (isOneShot (hsc_mode hsc_env)) $
160 updateEps_ (\eps -> eps { eps_is_boot = imp_dep_mods imports }) ;
162 -- Update the gbl env
163 updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
164 tcg_imports = tcg_imports gbl `plusImportAvails` imports })
166 traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
167 -- Fail if there are any errors so far
168 -- The error printing (if needed) takes advantage
169 -- of the tcg_env we have now set
172 -- Load any orphan-module interfaces, so that
173 -- their rules and instance decls will be found
174 loadOrphanModules (imp_orphs imports) ;
176 traceRn (text "rn1a") ;
177 -- Rename and type check the declarations
178 tcg_env <- tcRnSrcDecls local_decls ;
179 setGblEnv tcg_env $ do {
181 traceRn (text "rn3") ;
183 -- Report the use of any deprecated things
184 -- We do this before processsing the export list so
185 -- that we don't bleat about re-exporting a deprecated
186 -- thing (especially via 'module Foo' export item)
187 -- Only uses in the body of the module are complained about
188 reportDeprecations tcg_env ;
190 -- Process the export list
191 exports <- exportsFromAvail (isJust maybe_mod) exports ;
193 {- Jan 04: I don't think this is necessary any more; usage info is derived from tcg_dus
194 -- Get any supporting decls for the exports that have not already
195 -- been sucked in for the declarations in the body of the module.
196 -- (This can happen if something is imported only to be re-exported.)
198 -- Importing these supporting declarations is required
199 -- *only* to gether usage information
200 -- (see comments with MkIface.mkImportInfo for why)
201 -- We don't need the results, but sucking them in may side-effect
202 -- the ExternalPackageState, apart from recording usage
203 mappM (tcLookupGlobal . availName) export_avails ;
206 -- Check whether the entire module is deprecated
207 -- This happens only once per module
208 let { mod_deprecs = checkModDeprec mod_deprec } ;
210 -- Add exports and deprecations to envt
211 let { final_env = tcg_env { tcg_exports = exports,
212 tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
213 tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
215 -- A module deprecation over-rides the earlier ones
218 -- Report unused names
219 reportUnusedNames final_env ;
221 -- Dump output and return
228 %************************************************************************
230 Type-checking external-core modules
232 %************************************************************************
235 tcRnExtCore :: HscEnv
237 -> IO (Messages, Maybe ModGuts)
238 -- Nothing => some error occurred
240 tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
241 -- The decls are IfaceDecls; all names are original names
242 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
244 initTc hsc_env this_mod $ do {
246 let { ldecls = map noLoc decls } ;
248 -- Deal with the type declarations; first bring their stuff
249 -- into scope, then rname them, then type check them
250 (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ;
252 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
253 tcg_imports = imports `plusImportAvails` tcg_imports gbl })
256 rn_decls <- rnTyClDecls ldecls ;
259 -- Dump trace of renaming part
260 rnDump (ppr rn_decls) ;
262 -- Typecheck them all together so that
263 -- any mutually recursive types are done right
264 tcg_env <- checkNoErrs (tcTyAndClassDecls rn_decls) ;
265 -- Make the new type env available to stuff slurped from interface files
267 setGblEnv tcg_env $ do {
269 -- Now the core bindings
270 core_binds <- initIfaceExtCore (tcExtCoreBindings this_mod src_binds) ;
274 bndrs = bindersOfBinds core_binds ;
275 my_exports = mkNameSet (map idName bndrs) ;
276 -- ToDo: export the data types also?
278 final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
280 mod_guts = ModGuts { mg_module = this_mod,
281 mg_usages = [], -- ToDo: compute usage
282 mg_dir_imps = [], -- ??
283 mg_deps = noDependencies, -- ??
284 mg_exports = my_exports,
285 mg_types = final_type_env,
286 mg_insts = tcg_insts tcg_env,
288 mg_binds = core_binds,
291 mg_rdr_env = emptyGlobalRdrEnv,
292 mg_fix_env = emptyFixityEnv,
293 mg_deprecs = NoDeprecs,
297 tcCoreDump mod_guts ;
302 mkFakeGroup decls -- Rather clumsy; lots of unused fields
303 = HsGroup { hs_tyclds = decls, -- This is the one we want
304 hs_valds = [], hs_fords = [],
305 hs_instds = [], hs_fixds = [], hs_depds = [],
306 hs_ruleds = [], hs_defds = [] }
310 %************************************************************************
312 Type-checking the top level of a module
314 %************************************************************************
317 tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
318 -- Returns the variables free in the decls
319 -- Reason: solely to report unused imports and bindings
321 = do { -- Do all the declarations
322 (tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ;
324 -- tcSimplifyTop deals with constant or ambiguous InstIds.
325 -- How could there be ambiguous ones? They can only arise if a
326 -- top-level decl falls under the monomorphism
327 -- restriction, and no subsequent decl instantiates its
328 -- type. (Usually, ambiguous type variables are resolved
329 -- during the generalisation step.)
330 traceTc (text "Tc8") ;
331 inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
332 -- Setting the global env exposes the instances to tcSimplifyTop
333 -- Setting the local env exposes the local Ids to tcSimplifyTop,
334 -- so that we get better error messages (monomorphism restriction)
336 -- Backsubstitution. This must be done last.
337 -- Even tcSimplifyTop may do some unification.
338 traceTc (text "Tc9") ;
339 let { (tcg_env, _) = tc_envs ;
340 TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
341 tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
343 (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
346 let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
348 -- Make the new type env available to stuff slurped from interface files
349 writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
351 return (tcg_env { tcg_type_env = final_type_env,
352 tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' })
355 tc_rn_src_decls :: [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
356 -- Loops around dealing with each top level inter-splice group
357 -- in turn, until it's dealt with the entire module
359 = do { let { (first_group, group_tail) = findSplice ds } ;
360 -- If ds is [] we get ([], Nothing)
362 -- Type check the decls up to, but not including, the first splice
363 tc_envs@(tcg_env,tcl_env) <- tcRnGroup first_group ;
365 -- Bale out if errors; for example, error recovery when checking
366 -- the RHS of 'main' can mean that 'main' is not in the envt for
367 -- the subsequent checkMain test
372 -- If there is no splice, we're nearly done
374 Nothing -> do { -- Last thing: check for `main'
375 tcg_env <- checkMain ;
376 return (tcg_env, tcl_env)
379 -- If there's a splice, we must carry on
380 Just (SpliceDecl splice_expr, rest_ds) -> do {
382 failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
385 -- Rename the splice expression, and get its supporting decls
386 (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
387 failIfErrsM ; -- Don't typecheck if renaming failed
389 -- Execute the splice
390 spliced_decls <- tcSpliceDecls rn_splice_expr ;
392 -- Glue them on the front of the remaining decls and loop
393 setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
394 tc_rn_src_decls (spliced_decls ++ rest_ds)
400 %************************************************************************
402 Type-checking the top level of a module
404 %************************************************************************
406 tcRnGroup takes a bunch of top-level source-code declarations, and
408 * gets supporting declarations from interface files
411 * and augments the TcGblEnv with the results
413 In Template Haskell it may be called repeatedly for each group of
414 declarations. It expects there to be an incoming TcGblEnv in the
415 monad; it augments it and returns the new TcGblEnv.
418 tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
419 -- Returns the variables free in the decls, for unused-binding reporting
421 = do { -- Rename the declarations
422 (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
423 setGblEnv tcg_env $ do {
425 -- Typecheck the declarations
426 tcTopSrcDecls rn_decls
429 ------------------------------------------------
430 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
432 = do { -- Bring top level binders into scope
433 (rdr_env, imports) <- importsFromLocalDecls group ;
434 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
435 tcg_imports = imports `plusImportAvails` tcg_imports gbl })
438 traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
439 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
441 -- Rename the source decls
442 (tcg_env, rn_decls) <- rnSrcDecls group ;
445 -- Dump trace of renaming part
446 rnDump (ppr rn_decls) ;
448 return (tcg_env, rn_decls)
451 ------------------------------------------------
452 tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
454 (HsGroup { hs_tyclds = tycl_decls,
455 hs_instds = inst_decls,
456 hs_fords = foreign_decls,
457 hs_defds = default_decls,
458 hs_ruleds = rule_decls,
459 hs_valds = val_binds })
460 = do { -- Type-check the type and class decls, and all imported decls
461 -- The latter come in via tycl_decls
462 traceTc (text "Tc2") ;
464 tcg_env <- checkNoErrs (tcTyAndClassDecls tycl_decls) ;
465 -- tcTyAndClassDecls recovers internally, but if anything gave rise to
466 -- an error we'd better stop now, to avoid a cascade
468 -- Make these type and class decls available to stuff slurped from interface files
469 writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
472 setGblEnv tcg_env $ do {
473 -- Source-language instances, including derivings,
474 -- and import the supporting declarations
475 traceTc (text "Tc3") ;
476 (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
477 setGblEnv tcg_env $ do {
479 -- Foreign import declarations next. No zonking necessary
480 -- here; we can tuck them straight into the global environment.
481 traceTc (text "Tc4") ;
482 (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
483 tcExtendGlobalValEnv fi_ids $ do {
485 -- Default declarations
486 traceTc (text "Tc4a") ;
487 default_tys <- tcDefaults default_decls ;
488 updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
490 -- Value declarations next
491 -- We also typecheck any extra binds that came out
492 -- of the "deriving" process (deriv_binds)
493 traceTc (text "Tc5") ;
494 (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ;
495 setLclTypeEnv lcl_env $ do {
497 -- Second pass over class and instance declarations,
498 traceTc (text "Tc6") ;
499 (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
500 showLIE (text "after instDecls2") ;
503 -- They need to be zonked, so we return them
504 traceTc (text "Tc7") ;
505 (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
508 rules <- tcRules rule_decls ;
511 traceTc (text "Tc7a") ;
512 tcg_env <- getGblEnv ;
513 let { all_binds = tc_val_binds `unionBags`
514 inst_binds `unionBags`
517 -- Extend the GblEnv with the (as yet un-zonked)
518 -- bindings, rules, foreign decls
519 tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
520 tcg_rules = tcg_rules tcg_env ++ rules,
521 tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
522 return (tcg_env', lcl_env)
527 %************************************************************************
531 %************************************************************************
535 = do { ghci_mode <- getGhciMode ;
536 tcg_env <- getGblEnv ;
538 mb_main_mod <- readMutVar v_MainModIs ;
539 mb_main_fn <- readMutVar v_MainFunIs ;
540 let { main_mod = case mb_main_mod of {
541 Just mod -> mkModuleName mod ;
542 Nothing -> mAIN_Name } ;
543 main_fn = case mb_main_fn of {
544 Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
545 Nothing -> main_RDR_Unqual } } ;
547 check_main ghci_mode tcg_env main_mod main_fn
551 check_main ghci_mode tcg_env main_mod main_fn
552 -- If we are in module Main, check that 'main' is defined.
553 -- It may be imported from another module!
555 -- ToDo: We have to return the main_name separately, because it's a
556 -- bona fide 'use', and should be recorded as such, but the others
559 -- Blimey: a whole page of code to do this...
560 | mod_name /= main_mod
564 = addErrCtxt mainCtxt $
565 do { mb_main <- lookupSrcOcc_maybe main_fn
566 -- Check that 'main' is in scope
567 -- It might be imported from another module!
569 Nothing -> do { complain_no_main
572 { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) }
573 -- :Main.main :: IO () = runIO main
575 ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $
578 ; let { root_main_id = mkExportedLocalId rootMainName ty ;
579 main_bind = noLoc (VarBind root_main_id main_expr) }
581 ; return (tcg_env { tcg_binds = tcg_binds tcg_env
583 tcg_dus = tcg_dus tcg_env
584 `plusDU` usesOnly (unitFV main_name)
588 mod_name = moduleName (tcg_mod tcg_env)
590 complain_no_main | ghci_mode == Interactive = return ()
591 | otherwise = failWithTc noMainMsg
592 -- In interactive mode, don't worry about the absence of 'main'
593 -- In other modes, fail altogether, so that we don't go on
594 -- and complain a second time when processing the export list.
596 mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
597 noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
598 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
602 %*********************************************************
606 %*********************************************************
610 setInteractiveContext :: InteractiveContext -> TcRn a -> TcRn a
611 setInteractiveContext icxt thing_inside
612 = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_`
613 (updGblEnv (\env -> env {tcg_rdr_env = ic_rn_gbl_env icxt,
614 tcg_type_env = ic_type_env icxt}) $
615 updLclEnv (\env -> env {tcl_rdr = ic_rn_local_env icxt}) $
622 -> InteractiveContext
624 -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
625 -- The returned [Name] is the same as the input except for
626 -- ExprStmt, in which case the returned [Name] is [itName]
628 -- The returned TypecheckedHsExpr is of type IO [ () ],
629 -- a list of the bound values, coerced to ().
631 tcRnStmt hsc_env ictxt rdr_stmt
632 = initTcPrintErrors hsc_env iNTERACTIVE $
633 setInteractiveContext ictxt $ do {
635 -- Rename; use CmdLineMode because tcRnStmt is only used interactively
636 ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ;
637 traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
640 -- The real work is done here
641 (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
643 traceTc (text "tcs 1") ;
644 let { -- Make all the bound ids "global" ids, now that
645 -- they're notionally top-level bindings. This is
646 -- important: otherwise when we come to compile an expression
647 -- using these ids later, the byte code generator will consider
648 -- the occurrences to be free rather than global.
649 global_ids = map (globaliseId VanillaGlobal) bound_ids ;
651 -- Update the interactive context
652 rn_env = ic_rn_local_env ictxt ;
653 type_env = ic_type_env ictxt ;
655 bound_names = map idName global_ids ;
656 new_rn_env = extendLocalRdrEnv rn_env bound_names ;
658 -- Remove any shadowed bindings from the type_env;
659 -- they are inaccessible but might, I suppose, cause
660 -- a space leak if we leave them there
661 shadowed = [ n | name <- bound_names,
662 let rdr_name = mkRdrUnqual (nameOccName name),
663 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
665 filtered_type_env = delListFromNameEnv type_env shadowed ;
666 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
668 new_ic = ictxt { ic_rn_local_env = new_rn_env,
669 ic_type_env = new_type_env }
672 dumpOptTcRn Opt_D_dump_tc
673 (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
674 text "Typechecked expr" <+> ppr tc_expr]) ;
676 returnM (new_ic, bound_names, tc_expr)
681 Here is the grand plan, implemented in tcUserStmt
683 What you type The IO [HValue] that hscStmt returns
684 ------------- ------------------------------------
685 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
688 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
691 expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it]
692 [NB: result not printed] bindings: [it]
694 expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it]
695 result showable) bindings: [it]
697 expr (of non-IO type,
698 result not showable) ==> error
702 ---------------------------
703 tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
704 tcUserStmt (L _ (ExprStmt expr _))
705 = newUnique `thenM` \ uniq ->
707 fresh_it = itName uniq
708 the_bind = noLoc $ FunBind (noLoc fresh_it) False
709 [ mkSimpleMatch [] expr placeHolderType ]
711 tryTcLIE_ (do { -- Try this if the other fails
712 traceTc (text "tcs 1b") ;
714 nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
715 nlExprStmt (nlHsApp (nlHsVar printName)
718 (do { -- Try this first
719 traceTc (text "tcs 1a") ;
720 tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] })
722 tcUserStmt stmt = tc_stmts [stmt]
724 ---------------------------
726 = do { ioTyCon <- tcLookupTyCon ioTyConName ;
728 ret_ty = mkListTy unitTy ;
729 io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
731 names = map unLoc (collectStmtsBinders stmts) ;
733 stmt_ctxt = SC { sc_what = DoExpr,
735 sc_body = check_body,
738 check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ;
739 check_body body = tcCheckRho body io_ret_ty ;
741 -- mk_return builds the expression
742 -- returnIO @ [()] [coerce () x, .., coerce () z]
744 -- Despite the inconvenience of building the type applications etc,
745 -- this *has* to be done in type-annotated post-typecheck form
746 -- because we are going to return a list of *polymorphic* values
747 -- coerced to type (). If we built a *source* stmt
748 -- return [coerce x, ..., coerce z]
749 -- then the type checker would instantiate x..z, and we wouldn't
750 -- get their *polymorphic* values. (And we'd get ambiguity errs
751 -- if they were overloaded, since they aren't applied to anything.)
752 mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
753 (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
754 mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
757 io_ty = mkTyConApp ioTyCon []
760 -- OK, we're ready to typecheck the stmts
761 traceTc (text "tcs 2") ;
762 ((ids, tc_expr), lie) <- getLIE $ do {
763 (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts $
765 -- Look up the names right in the middle,
766 -- where they will all be in scope
767 ids <- mappM tcLookupId names ;
768 ret_id <- tcLookupId returnIOName ; -- return @ IO
769 return (ids, [nlResultStmt (mk_return ret_id ids)]) } ;
771 io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
772 return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty))
775 -- Simplify the context right here, so that we fail
776 -- if there aren't enough instances. Notably, when we see
778 -- we use recoverTc_ to try it <- e
779 -- and then let it = e
780 -- It's the simplify step that rejects the first.
781 traceTc (text "tcs 3") ;
782 const_binds <- tcSimplifyInteractive lie ;
784 -- Build result expression and zonk it
785 let { expr = mkHsLet const_binds tc_expr } ;
786 zonked_expr <- zonkTopLExpr expr ;
787 zonked_ids <- zonkTopBndrs ids ;
789 -- None of the Ids should be of unboxed type, because we
790 -- cast them all to HValues in the end!
791 mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
793 return (zonked_ids, zonked_expr)
796 combine stmt (ids, stmts) = (ids, stmt:stmts)
797 bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
798 nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
802 tcRnExpr just finds the type of an expression
806 -> InteractiveContext
809 tcRnExpr hsc_env ictxt rdr_expr
810 = initTcPrintErrors hsc_env iNTERACTIVE $
811 setInteractiveContext ictxt $ do {
813 (rn_expr, fvs) <- rnLExpr rdr_expr ;
816 -- Now typecheck the expression;
817 -- it might have a rank-2 type (e.g. :t runST)
818 ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
819 ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
820 tcSimplifyInteractive lie_top ;
822 let { all_expr_ty = mkForAllTys qtvs $
823 mkFunTys (map idType dict_ids) $
825 zonkTcType all_expr_ty
828 smpl_doc = ptext SLIT("main expression")
831 tcRnType just finds the kind of a type
835 -> InteractiveContext
838 tcRnType hsc_env ictxt rdr_type
839 = initTcPrintErrors hsc_env iNTERACTIVE $
840 setInteractiveContext ictxt $ do {
842 rn_type <- rnLHsType doc rdr_type ;
845 -- Now kind-check the type
846 (ty', kind) <- kcHsType rn_type ;
850 doc = ptext SLIT("In GHCi input")
856 %************************************************************************
858 More GHCi stuff, to do with browsing and getting info
860 %************************************************************************
864 mkExportEnv :: HscEnv -> [ModuleName] -- Expose these modules' exports only
866 mkExportEnv hsc_env exports
867 = do { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $
868 mappM getModuleExports exports
870 Just envs -> return (foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs)
871 Nothing -> return emptyGlobalRdrEnv
872 -- Some error; initTc will have printed it
875 getModuleExports :: ModuleName -> TcM GlobalRdrEnv
877 = do { iface <- load_iface mod
878 ; loadOrphanModules (dep_orphs (mi_deps iface))
879 -- Load any orphan-module interfaces,
880 -- so their instances are visible
881 ; avails <- exportsToAvails (mi_exports iface)
882 ; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod }
883 | avail <- avails, name <- availNames avail ] }
884 ; returnM (mkGlobalRdrEnv gres) }
886 vanillaProv :: ModuleName -> Provenance
887 -- We're building a GlobalRdrEnv as if the user imported
888 -- all the specified modules into the global interactive module
889 vanillaProv mod = Imported [ImportSpec mod mod False
890 (srcLocSpan interactiveSrcLoc)] False
896 -> InteractiveContext
897 -> ModuleName -- Module to inspect
898 -> Bool -- Grab just the exports, or the whole toplev
899 -> IO (Maybe [IfaceDecl])
901 getModuleContents hsc_env ictxt mod exports_only
902 = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only)
904 get_mod_contents exports_only
905 | not exports_only -- We want the whole top-level type env
906 -- so it had better be a home module
908 ; case lookupModuleEnvByName hpt mod of
909 Just mod_info -> return (map toIfaceDecl $
912 md_types (hm_details mod_info))
913 Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod)))
914 -- This is a system error; the module should be in the HPT
917 | otherwise -- Want the exports only
918 = do { iface <- load_iface mod
919 ; avails <- exportsToAvails (mi_exports iface)
920 ; mappM get_decl avails
924 = do { thing <- tcLookupGlobal (availName avail)
925 ; return (filter_decl (availOccs avail) (toIfaceDecl thing)) }
927 ---------------------
928 filter_decl occs decl@(IfaceClass {ifSigs = sigs})
929 = decl { ifSigs = filter (keep_sig occs) sigs }
930 filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon cons})
931 = decl { ifCons = IfDataTyCon (filter (keep_con occs) cons) }
932 filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
933 | keep_con occs con = decl
934 | otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm?
935 filter_decl occs decl
938 keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs
939 keep_con occs (IfaceConDecl occ _ _ _ _ _ _) = occ `elem` occs
941 availOccs avail = map nameOccName (availNames avail)
943 wantToSee (AnId id) = not (isImplicitId id)
944 wantToSee (ADataCon _) = False -- They'll come via their TyCon
947 ---------------------
948 load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
950 doc = ptext SLIT("context for compiling statements")
952 ---------------------
953 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
958 tcRnGetInfo :: HscEnv
959 -> InteractiveContext
961 -> IO (Maybe [(IfaceDecl,
963 [(IfaceInst, SrcLoc)])])
964 -- Used to implemnent :info in GHCi
966 -- Look up a RdrName and return all the TyThings it might be
967 -- A capitalised RdrName is given to us in the DataName namespace,
968 -- but we want to treat it as *both* a data constructor
969 -- *and* as a type or class constructor;
970 -- hence the call to dataTcOccs, and we return up to two results
971 tcRnGetInfo hsc_env ictxt rdr_name
972 = initTcPrintErrors hsc_env iNTERACTIVE $
973 setInteractiveContext ictxt $ do {
975 -- If the identifier is a constructor (begins with an
976 -- upper-case letter), then we need to consider both
977 -- constructor and type class identifiers.
978 let { rdr_names = dataTcOccs rdr_name } ;
980 -- results :: [(Messages, Maybe Name)]
981 results <- mapM (tryTc . lookupOccRn) rdr_names ;
983 traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
984 -- The successful lookups will be (Just name)
985 let { (warns_s, good_names) = unzip [ (msgs, name)
986 | (msgs, Just name) <- results] ;
987 errs_s = [msgs | (msgs, Nothing) <- results] } ;
989 -- Fail if nothing good happened, else add warnings
990 if null good_names then
991 -- No lookup succeeded, so
992 -- pick the first error message and report it
993 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
994 -- while the other is "X is not in scope",
995 -- we definitely want the former; but we might pick the latter
996 do { addMessages (head errs_s) ; failM }
997 else -- Add deprecation warnings
998 mapM_ addMessages warns_s ;
1000 -- And lookup up the entities, avoiding duplicates, which arise
1001 -- because constructors and record selectors are represented by
1002 -- their parent declaration
1003 let { do_one name = do { thing <- tcLookupGlobal name
1004 ; let decl = toIfaceDecl thing
1005 ; fixity <- lookupFixityRn name
1006 ; insts <- lookupInsts thing
1007 ; return (decl, fixity, getSrcLoc thing,
1008 map mk_inst insts) } ;
1009 -- For the SrcLoc, the 'thing' has better info than
1010 -- the 'name' because getting the former forced the
1011 -- declaration to be loaded into the cache
1012 mk_inst dfun = (dfunToIfaceInst dfun, getSrcLoc dfun) ;
1013 cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2 } ;
1014 results <- mapM do_one good_names ;
1015 return (fst (removeDups cmp results))
1018 lookupInsts :: TyThing -> TcM [DFunId]
1019 lookupInsts (AClass cls)
1020 = do { loadImportedInsts cls [] -- [] means load all instances for cls
1021 ; inst_envs <- tcGetInstEnvs
1022 ; return [df | (_,_,df) <- classInstances inst_envs cls] }
1024 lookupInsts (ATyCon tc)
1025 = do { eps <- getEps -- Load all instances for all classes that are
1026 -- in the type environment (which are all the ones
1027 -- we've seen in any interface file so far
1028 ; mapM_ (\c -> loadImportedInsts c [])
1029 (typeEnvClasses (eps_PTE eps))
1030 ; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all
1031 ; return (get home_ie ++ get pkg_ie) }
1033 get ie = [df | (_,_,df) <- instEnvElts ie, relevant df]
1034 relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
1035 tc_name = tyConName tc
1037 lookupInsts other = return []
1040 toIfaceDecl :: TyThing -> IfaceDecl
1042 = tyThingToIfaceDecl True -- Discard IdInfo
1043 emptyNameSet -- Show data cons
1044 ext_nm (munge thing)
1046 ext_nm n = ExtPkg (nameModuleName n) (nameOccName n)
1048 -- munge transforms a thing to it's "parent" thing
1049 munge (ADataCon dc) = ATyCon (dataConTyCon dc)
1050 munge (AnId id) = case globalIdDetails id of
1051 RecordSelId lbl -> ATyCon (fieldLabelTyCon lbl)
1052 ClassOpId cls -> AClass cls
1054 munge other_thing = other_thing
1059 %************************************************************************
1063 %************************************************************************
1066 rnDump :: SDoc -> TcRn ()
1067 -- Dump, with a banner, if -ddump-rn
1068 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1070 tcDump :: TcGblEnv -> TcRn ()
1072 = do { dflags <- getDOpts ;
1074 -- Dump short output if -ddump-types or -ddump-tc
1075 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1076 (dumpTcRn short_dump) ;
1078 -- Dump bindings if -ddump-tc
1079 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1082 short_dump = pprTcGblEnv env
1083 full_dump = pprLHsBinds (tcg_binds env)
1084 -- NB: foreign x-d's have undefined's in their types;
1085 -- hence can't show the tc_fords
1088 = do { dflags <- getDOpts ;
1089 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1090 (dumpTcRn (pprModGuts mod_guts)) ;
1092 -- Dump bindings if -ddump-tc
1093 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1095 full_dump = pprCoreBindings (mg_binds mod_guts)
1097 -- It's unpleasant having both pprModGuts and pprModDetails here
1098 pprTcGblEnv :: TcGblEnv -> SDoc
1099 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1100 tcg_insts = dfun_ids,
1102 tcg_imports = imports })
1103 = vcat [ ppr_types dfun_ids type_env
1104 , ppr_insts dfun_ids
1105 , vcat (map ppr rules)
1106 , ppr_gen_tycons (typeEnvTyCons type_env)
1107 , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports))
1108 , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1110 pprModGuts :: ModGuts -> SDoc
1111 pprModGuts (ModGuts { mg_types = type_env,
1113 = vcat [ ppr_types [] type_env,
1117 ppr_types :: [Var] -> TypeEnv -> SDoc
1118 ppr_types dfun_ids type_env
1119 = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1121 ids = [id | id <- typeEnvIds type_env, want_sig id]
1122 want_sig id | opt_PprStyle_Debug = True
1123 | otherwise = isLocalId id &&
1124 isExternalName (idName id) &&
1125 not (id `elem` dfun_ids)
1126 -- isLocalId ignores data constructors, records selectors etc.
1127 -- The isExternalName ignores local dictionary and method bindings
1128 -- that the type checker has invented. Top-level user-defined things
1129 -- have External names.
1131 ppr_insts :: [Var] -> SDoc
1132 ppr_insts [] = empty
1133 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1135 ppr_sigs :: [Var] -> SDoc
1137 -- Print type signatures; sort by OccName
1138 = vcat (map ppr_sig (sortLe le_sig ids))
1140 le_sig id1 id2 = getOccName id1 <= getOccName id2
1141 ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
1143 ppr_rules :: [IdCoreRule] -> SDoc
1144 ppr_rules [] = empty
1145 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1146 nest 4 (pprIdRules rs),
1149 ppr_gen_tycons [] = empty
1150 ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"),
1151 nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]