2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcModule]{Typechecking a whole module}
9 mkGlobalContext, getModuleContents, tcRnStmt, tcRnThing, tcRnExpr,
11 tcRnModule, checkOldIface,
12 importSupportingDecls, tcTopSrcDecls,
13 tcRnIface, tcRnExtCore
16 #include "HsVersions.h"
19 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
20 import DsMeta ( templateHaskellNames )
23 import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
24 import DriverState ( v_MainModIs, v_MainFunIs )
25 import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..),
26 Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..),
27 HsGroup(..), SpliceDecl(..),
28 mkSimpleMatch, placeHolderType, toHsType, andMonoBinds,
29 isSrcRule, collectStmtsBinders
31 import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr,
32 emptyGroup, mkGroup, findSplice, addImpDecls, main_RDR_Unqual )
34 import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames,
35 returnIOName, runIOName,
36 dollarMainName, itName, mAIN_Name, unsafeCoerceName
38 import RdrName ( RdrName, getRdrName, mkRdrUnqual,
39 lookupRdrEnv, elemRdrEnv )
41 import RnHsSyn ( RenamedStmt, RenamedTyClDecl,
42 ruleDeclFVs, instDeclFVs, tyClDeclFVs )
43 import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl,
44 zonkTopDecls, mkHsLet,
45 zonkTopExpr, zonkTopBndrs
48 import TcExpr ( tcInferRho, tcCheckRho )
51 tyVarsOfType, tcFunResultTy, tidyTopType,
52 mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
54 import Inst ( showLIE, tcStdSyntaxName )
55 import TcBinds ( tcTopBinds )
56 import TcClassDcl ( tcClassDecls2 )
57 import TcDefaults ( tcDefaults )
58 import TcEnv ( tcExtendGlobalValEnv,
59 tcExtendInstEnv, tcExtendRules,
60 tcLookupTyCon, tcLookupGlobal,
63 import TcRules ( tcRules )
64 import TcForeign ( tcForeignImports, tcForeignExports )
65 import TcIfaceSig ( tcInterfaceSigs, tcCoreBinds )
66 import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls, tcInstDecls2 )
67 import TcSimplify ( tcSimplifyTop, tcSimplifyInfer )
68 import TcTyClsDecls ( tcTyAndClassDecls )
70 import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
72 import RnIfaces ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate )
73 import RnHiFiles ( readIface, loadOldIface )
74 import RnEnv ( lookupSrcName, lookupOccRn, plusGlobalRdrEnv,
75 ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs )
76 import RnSource ( rnSrcDecls, checkModDeprec, rnStats )
78 import CoreUnfold ( unfoldingTemplate )
79 import CoreSyn ( IdCoreRule, Bind(..) )
80 import PprCore ( pprIdRules, pprCoreBindings )
81 import ErrUtils ( mkDumpDoc, showPass, pprBagOfErrors )
82 import Id ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported )
83 import Var ( Var, setGlobalIdDetails )
84 import Module ( Module, mkHomeModule, mkModuleName, moduleName, moduleUserString, moduleEnvElts )
85 import OccName ( mkVarOcc )
86 import Name ( Name, isExternalName, getSrcLoc, nameOccName )
88 import TyCon ( tyConGenInfo )
89 import BasicTypes ( EP(..), RecFlag(..) )
91 import HscTypes ( PersistentCompilerState(..), InteractiveContext(..),
92 ModIface, ModDetails(..), ModGuts(..),
94 ModIface(..), ModDetails(..), IfaceDecls(..),
95 GhciMode(..), noDependencies,
96 Deprecations(..), plusDeprecs,
98 GenAvailInfo(Avail), availsToNameSet,
100 TypeEnv, TyThing, typeEnvTyCons,
101 extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
102 extendLocalRdrEnv, emptyFixityEnv
105 import TcMType ( zonkTcType )
106 import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) )
107 import RdrName ( rdrEnvElts )
108 import RnExpr ( rnStmts, rnExpr )
109 import RnHiFiles ( loadInterface )
110 import RnEnv ( mkGlobalRdrEnv )
111 import TysWiredIn ( mkListTy, unitTy )
112 import IdInfo ( GlobalIdDetails(..) )
113 import SrcLoc ( noSrcLoc )
114 import NameEnv ( delListFromNameEnv )
115 import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(..),
119 import FastString ( mkFastString )
120 import Panic ( showException )
121 import List ( partition )
122 import Util ( sortLt )
127 %************************************************************************
129 Typecheck and rename a module
131 %************************************************************************
135 tcRnModule :: HscEnv -> PersistentCompilerState
137 -> IO (PersistentCompilerState, Maybe TcGblEnv)
139 tcRnModule hsc_env pcs
140 (HsModule maybe_mod exports import_decls local_decls mod_deprec loc)
141 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
143 let { this_mod = case maybe_mod of
144 Nothing -> mkHomeModule mAIN_Name -- 'module M where' is omitted
145 Just mod -> mod } ; -- The normal case
147 initTc hsc_env pcs this_mod $ addSrcLoc loc $
148 do { -- Deal with imports; sets tcg_rdr_env, tcg_imports
149 (rdr_env, imports) <- rnImports import_decls ;
150 updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
151 tcg_imports = tcg_imports gbl `plusImportAvails` imports })
153 traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
154 -- Fail if there are any errors so far
155 -- The error printing (if needed) takes advantage
156 -- of the tcg_env we have now set
159 traceRn (text "rn1a") ;
160 -- Rename and type check the declarations
161 (tcg_env, src_dus) <- tcRnSrcDecls local_decls ;
162 setGblEnv tcg_env $ do {
164 traceRn (text "rn3") ;
165 -- Check whether the entire module is deprecated
166 -- This happens only once per module
167 -- Returns the full new deprecations; a module deprecation
168 -- over-rides the earlier ones
169 let { mod_deprecs = checkModDeprec mod_deprec } ;
170 updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` mod_deprecs })
173 -- Process the export list
174 export_avails <- exportsFromAvail maybe_mod exports ;
175 updGblEnv (\gbl -> gbl { tcg_exports = export_avails })
178 -- Get any supporting decls for the exports that have not already
179 -- been sucked in for the declarations in the body of the module.
180 -- (This can happen if something is imported only to be re-exported.)
182 -- Importing these supporting declarations is required
183 -- *only* to gether usage information
184 -- (see comments with MkIface.mkImportInfo for why)
185 -- For OneShot compilation we could just throw away the decls
186 -- but for Batch or Interactive we must put them in the type
187 -- envt because they've been removed from the holding pen
188 let { export_fvs = availsToNameSet export_avails } ;
189 tcg_env <- importSupportingDecls export_fvs ;
190 setGblEnv tcg_env $ do {
192 -- Report unused names
193 let { all_dus = src_dus `plusDU` usesOnly export_fvs } ;
194 reportUnusedNames tcg_env all_dus ;
196 -- Dump output and return
203 %*********************************************************
205 \subsection{Closing up the interface decls}
207 %*********************************************************
209 Suppose we discover we don't need to recompile. Then we start from the
210 IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need.
214 -> PersistentCompilerState
215 -> ModIface -- Get the decls from here
216 -> IO (PersistentCompilerState, Maybe ModDetails)
217 -- Nothing <=> errors happened
218 tcRnIface hsc_env pcs
219 (ModIface {mi_module = mod, mi_decls = iface_decls})
220 = initTc hsc_env pcs mod $ do {
222 -- Get the supporting decls, and typecheck them all together
223 -- so that any mutually recursive types are done right
224 extra_decls <- slurpImpDecls needed ;
225 env <- typecheckIfaceDecls (group `addImpDecls` extra_decls) ;
227 returnM (ModDetails { md_types = tcg_type_env env,
228 md_insts = tcg_insts env,
229 md_rules = hsCoreRules (tcg_rules env)
230 -- All the rules from an interface are of the IfaceRuleOut form
233 rule_decls = dcl_rules iface_decls
234 inst_decls = dcl_insts iface_decls
235 tycl_decls = dcl_tycl iface_decls
236 group = emptyGroup { hs_ruleds = rule_decls,
237 hs_instds = inst_decls,
238 hs_tyclds = tycl_decls }
239 needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets`
240 unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets`
241 unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets`
243 -- Data type decls with record selectors,
244 -- which may appear in the decls, need unpackCString
245 -- and friends. It's easier to just grab them right now.
247 hsCoreRules :: [TypecheckedRuleDecl] -> [IdCoreRule]
248 -- All post-typechecking Iface rules have the form IfaceRuleOut
249 hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules]
253 %************************************************************************
255 The interactive interface
257 %************************************************************************
261 tcRnStmt :: HscEnv -> PersistentCompilerState
262 -> InteractiveContext
264 -> IO (PersistentCompilerState,
265 Maybe (InteractiveContext, [Name], TypecheckedHsExpr))
266 -- The returned [Name] is the same as the input except for
267 -- ExprStmt, in which case the returned [Name] is [itName]
269 -- The returned TypecheckedHsExpr is of type IO [ () ],
270 -- a list of the bound values, coerced to ().
272 tcRnStmt hsc_env pcs ictxt rdr_stmt
273 = initTc hsc_env pcs iNTERACTIVE $
274 setInteractiveContext ictxt $ do {
276 -- Rename; use CmdLineMode because tcRnStmt is only used interactively
277 ([rn_stmt], fvs) <- initRnInteractive ictxt
278 (rnStmts DoExpr [rdr_stmt]) ;
279 traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
282 -- Suck in the supporting declarations and typecheck them
283 tcg_env <- importSupportingDecls (fvs `plusFV` implicitStmtFVs fvs) ;
284 -- NB: an earlier version deleted (rdrEnvElts local_env) from
285 -- the fvs. But (a) that isn't necessary, because previously
286 -- bound things in the local_env will be in the TypeEnv, and
287 -- the renamer doesn't re-slurp such things, and
288 -- (b) it's WRONG to delete them. Consider in GHCi:
289 -- Mod> let x = e :: T
290 -- Mod> let y = x + 3
291 -- We need to pass 'x' among the fvs to slurpImpDecls, so that
292 -- the latter can see that T is a gate, and hence import the Num T
293 -- instance decl. (See the InTypEnv case in RnIfaces.slurpSourceRefs.)
294 setGblEnv tcg_env $ do {
296 -- The real work is done here
297 (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
299 traceTc (text "tcs 1") ;
300 let { -- Make all the bound ids "global" ids, now that
301 -- they're notionally top-level bindings. This is
302 -- important: otherwise when we come to compile an expression
303 -- using these ids later, the byte code generator will consider
304 -- the occurrences to be free rather than global.
305 global_ids = map globaliseId bound_ids ;
306 globaliseId id = setGlobalIdDetails id VanillaGlobal ;
308 -- Update the interactive context
309 rn_env = ic_rn_local_env ictxt ;
310 type_env = ic_type_env ictxt ;
312 bound_names = map idName global_ids ;
313 new_rn_env = extendLocalRdrEnv rn_env bound_names ;
315 -- Remove any shadowed bindings from the type_env;
316 -- they are inaccessible but might, I suppose, cause
317 -- a space leak if we leave them there
318 shadowed = [ n | name <- bound_names,
319 let rdr_name = mkRdrUnqual (nameOccName name),
320 Just n <- [lookupRdrEnv rn_env rdr_name] ] ;
322 filtered_type_env = delListFromNameEnv type_env shadowed ;
323 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
325 new_ic = ictxt { ic_rn_local_env = new_rn_env,
326 ic_type_env = new_type_env }
329 dumpOptTcRn Opt_D_dump_tc
330 (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
331 text "Typechecked expr" <+> ppr tc_expr]) ;
333 returnM (new_ic, bound_names, tc_expr)
338 Here is the grand plan, implemented in tcUserStmt
340 What you type The IO [HValue] that hscStmt returns
341 ------------- ------------------------------------
342 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
345 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
348 expr (of IO type) ==> expr >>= \ v -> return [coerce HVal v]
349 [NB: result not printed] bindings: [it]
351 expr (of non-IO type, ==> let v = expr in print v >> return [coerce HVal v]
352 result showable) bindings: [it]
354 expr (of non-IO type,
355 result not showable) ==> error
359 ---------------------------
360 tcUserStmt :: RenamedStmt -> TcM ([Id], TypecheckedHsExpr)
361 tcUserStmt (ExprStmt expr _ loc)
362 = newUnique `thenM` \ uniq ->
364 fresh_it = itName uniq
365 the_bind = FunMonoBind fresh_it False
366 [ mkSimpleMatch [] expr placeHolderType loc ] loc
368 tryTcLIE_ (do { -- Try this if the other fails
369 traceTc (text "tcs 1b") ;
371 LetStmt (MonoBind the_bind [] NonRecursive),
372 ExprStmt (HsApp (HsVar printName) (HsVar fresh_it))
373 placeHolderType loc] })
374 (do { -- Try this first
375 traceTc (text "tcs 1a") ;
376 tc_stmts [BindStmt (VarPat fresh_it) expr loc] })
378 tcUserStmt stmt = tc_stmts [stmt]
380 ---------------------------
382 = do { ioTyCon <- tcLookupTyCon ioTyConName ;
384 ret_ty = mkListTy unitTy ;
385 names = collectStmtsBinders stmts ;
387 stmt_ctxt = SC { sc_what = DoExpr,
389 sc_body = check_body,
392 check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ;
393 check_body body = tcCheckRho body (mkTyConApp ioTyCon [ret_ty]) ;
395 -- ret_expr is the expression
396 -- returnIO [coerce () x, .., coerce () z]
397 ret_stmt = ResultStmt ret_expr noSrcLoc ;
398 ret_expr = HsApp (HsVar returnIOName)
399 (ExplicitList placeHolderType (map mk_item names)) ;
400 mk_item name = HsApp (HsVar unsafeCoerceName) (HsVar name) ;
402 all_stmts = stmts ++ [ret_stmt] ;
404 io_ty = mkTyConApp ioTyCon []
407 -- OK, we're ready to typecheck the stmts
408 traceTc (text "tcs 2") ;
409 ((ids, tc_expr), lie) <- getLIE $ do {
410 (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt all_stmts $
412 -- Look up the names right in the middle,
413 -- where they will all be in scope
414 ids <- mappM tcLookupId names ;
416 io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
417 return (ids, HsDo DoExpr tc_stmts io_ids
418 (mkTyConApp ioTyCon [ret_ty]) noSrcLoc)
421 -- Simplify the context right here, so that we fail
422 -- if there aren't enough instances. Notably, when we see
424 -- we use recoverTc_ to try it <- e
425 -- and then let it = e
426 -- It's the simplify step that rejects the first.
427 traceTc (text "tcs 3") ;
428 const_binds <- tcSimplifyTop lie ;
430 -- Build result expression and zonk it
431 let { expr = mkHsLet const_binds tc_expr } ;
432 zonked_expr <- zonkTopExpr expr ;
433 zonked_ids <- zonkTopBndrs ids ;
435 return (zonked_ids, zonked_expr)
438 combine stmt (ids, stmts) = (ids, stmt:stmts)
442 tcRnExpr just finds the type of an expression
445 tcRnExpr :: HscEnv -> PersistentCompilerState
446 -> InteractiveContext
448 -> IO (PersistentCompilerState, Maybe Type)
449 tcRnExpr hsc_env pcs ictxt rdr_expr
450 = initTc hsc_env pcs iNTERACTIVE $
451 setInteractiveContext ictxt $ do {
453 (rn_expr, fvs) <- initRnInteractive ictxt (rnExpr rdr_expr) ;
456 -- Suck in the supporting declarations and typecheck them
457 tcg_env <- importSupportingDecls (fvs `plusFV` ubiquitousNames) ;
458 setGblEnv tcg_env $ do {
460 -- Now typecheck the expression;
461 -- it might have a rank-2 type (e.g. :t runST)
462 ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
463 ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
464 tcSimplifyTop lie_top ;
466 let { all_expr_ty = mkForAllTys qtvs $
467 mkFunTys (map idType dict_ids) $
469 zonkTcType all_expr_ty
472 smpl_doc = ptext SLIT("main expression")
477 tcRnThing :: HscEnv -> PersistentCompilerState
478 -> InteractiveContext
480 -> IO (PersistentCompilerState, Maybe [TyThing])
481 -- Look up a RdrName and return all the TyThings it might be
482 -- We treat a capitalised RdrName as both a data constructor
483 -- and as a type or class constructor; hence we return up to two results
484 tcRnThing hsc_env pcs ictxt rdr_name
485 = initTc hsc_env pcs iNTERACTIVE $
486 setInteractiveContext ictxt $ do {
488 -- If the identifier is a constructor (begins with an
489 -- upper-case letter), then we need to consider both
490 -- constructor and type class identifiers.
491 let { rdr_names = dataTcOccs rdr_name } ;
493 -- results :: [(Messages, Maybe Name)]
494 results <- initRnInteractive ictxt
495 (mapM (tryTc . lookupOccRn) rdr_names) ;
497 -- The successful lookups will be (Just name)
498 let { (warns_s, good_names) = unzip [ (msgs, name)
499 | (msgs, Just name) <- results] ;
500 errs_s = [msgs | (msgs, Nothing) <- results] } ;
502 -- Fail if nothing good happened, else add warnings
503 if null good_names then -- Fail
504 do { addMessages (head errs_s) ; failM }
505 else -- Add deprecation warnings
506 mapM_ addMessages warns_s ;
508 -- Slurp in the supporting declarations
509 tcg_env <- importSupportingDecls (mkFVs good_names) ;
510 setGblEnv tcg_env $ do {
512 -- And lookup up the entities
513 mapM tcLookupGlobal good_names
519 setInteractiveContext :: InteractiveContext -> TcRn m a -> TcRn m a
520 setInteractiveContext icxt thing_inside
521 = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_`
522 updGblEnv (\ env -> env { tcg_rdr_env = ic_rn_gbl_env icxt,
523 tcg_type_env = ic_type_env icxt })
526 initRnInteractive :: InteractiveContext -> RnM a -> TcM a
527 -- Set the local RdrEnv from the interactive context
528 initRnInteractive ictxt rn_thing
529 = initRn CmdLineMode $
530 setLocalRdrEnv (ic_rn_local_env ictxt) $
535 %************************************************************************
537 Type-checking external-core modules
539 %************************************************************************
542 tcRnExtCore :: HscEnv -> PersistentCompilerState
544 -> IO (PersistentCompilerState, Maybe ModGuts)
545 -- Nothing => some error occurred
547 tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc)
548 -- For external core, the module name is syntactically reqd
549 -- Rename the (Core) module. It's a bit like an interface
550 -- file: all names are original names
551 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
553 initTc hsc_env pcs this_mod $ addSrcLoc loc $ do {
555 -- Rename the source, only in interface mode.
556 -- rnSrcDecls handles fixity decls etc too, which won't occur
557 -- but that doesn't matter
558 let { local_group = mkGroup decls } ;
559 (_, rn_decls, dus) <- initRn (InterfaceMode this_mod)
560 (rnSrcDecls local_group) ;
563 -- Get the supporting decls
564 rn_imp_decls <- slurpImpDecls (duUses dus) ;
565 let { rn_decls = rn_decls `addImpDecls` rn_imp_decls } ;
567 -- Dump trace of renaming part
568 rnDump (ppr rn_decls) ;
569 rnStats rn_imp_decls ;
571 -- Typecheck them all together so that
572 -- any mutually recursive types are done right
573 tcg_env <- typecheckIfaceDecls rn_decls ;
574 setGblEnv tcg_env $ do {
576 -- Now the core bindings
577 core_prs <- tcCoreBinds (hs_coreds rn_decls) ;
578 tcExtendGlobalValEnv (map fst core_prs) $ do {
582 bndrs = map fst core_prs ;
583 my_exports = map (Avail . idName) bndrs ;
584 -- ToDo: export the data types also?
586 final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
588 mod_guts = ModGuts { mg_module = this_mod,
589 mg_usages = [], -- ToDo: compute usage
590 mg_dir_imps = [], -- ??
591 mg_deps = noDependencies, -- ??
592 mg_exports = my_exports,
593 mg_types = final_type_env,
594 mg_insts = tcg_insts tcg_env,
595 mg_rules = hsCoreRules (tcg_rules tcg_env),
596 mg_binds = [Rec core_prs],
599 mg_rdr_env = emptyGlobalRdrEnv,
600 mg_fix_env = emptyFixityEnv,
601 mg_deprecs = NoDeprecs,
605 tcCoreDump mod_guts ;
612 %************************************************************************
614 Type-checking the top level of a module
616 %************************************************************************
619 tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, DefUses)
620 -- Returns the variables free in the decls
621 -- Reason: solely to report unused imports and bindings
623 = do { -- Do all the declarations
624 ((tc_envs, dus), lie) <- getLIE (tc_rn_src_decls decls) ;
626 -- tcSimplifyTop deals with constant or ambiguous InstIds.
627 -- How could there be ambiguous ones? They can only arise if a
628 -- top-level decl falls under the monomorphism
629 -- restriction, and no subsequent decl instantiates its
630 -- type. (Usually, ambiguous type variables are resolved
631 -- during the generalisation step.)
632 traceTc (text "Tc8") ;
633 setEnvs tc_envs $ do {
634 -- Setting the global env exposes the instances to tcSimplifyTop
635 -- Setting the local env exposes the local Ids, so that
636 -- we get better error messages (monomorphism restriction)
637 inst_binds <- tcSimplifyTop lie ;
639 -- Backsubstitution. This must be done last.
640 -- Even tcSimplifyTop may do some unification.
641 traceTc (text "Tc9") ;
642 let { (tcg_env, _) = tc_envs ;
643 TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
644 tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
646 (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
649 return (tcg_env { tcg_type_env = extendTypeEnvWithIds type_env bind_ids,
650 tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' },
654 tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), DefUses)
657 = do { let { (first_group, group_tail) = findSplice ds } ;
658 -- If ds is [] we get ([], Nothing)
660 -- Type check the decls up to, but not including, the first splice
661 (tc_envs@(_,tcl_env), src_dus1) <- tcRnGroup first_group ;
663 -- Bale out if errors; for example, error recovery when checking
664 -- the RHS of 'main' can mean that 'main' is not in the envt for
665 -- the subsequent checkMain test
670 -- If there is no splice, we're nearly done
672 Nothing -> do { -- Last thing: check for `main'
673 (tcg_env, main_fvs) <- checkMain ;
674 return ((tcg_env, tcl_env),
675 src_dus1 `plusDU` usesOnly main_fvs)
678 -- If there's a splice, we must carry on
679 Just (SpliceDecl splice_expr splice_loc, rest_ds) -> do {
681 failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
684 -- Rename the splice expression, and get its supporting decls
685 (rn_splice_expr, splice_fvs) <- initRn SourceMode $
686 addSrcLoc splice_loc $
688 tcg_env <- importSupportingDecls (splice_fvs `plusFV` templateHaskellNames) ;
689 setGblEnv tcg_env $ do {
691 -- Execute the splice
692 spliced_decls <- tcSpliceDecls rn_splice_expr ;
694 -- Glue them on the front of the remaining decls and loop
695 (tc_envs, src_dus2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ;
697 return (tc_envs, src_dus1 `plusDU` usesOnly splice_fvs `plusDU` src_dus2)
704 %************************************************************************
706 Type-checking the top level of a module
708 %************************************************************************
710 tcRnGroup takes a bunch of top-level source-code declarations, and
712 * gets supporting declarations from interface files
715 * and augments the TcGblEnv with the results
717 In Template Haskell it may be called repeatedly for each group of
718 declarations. It expects there to be an incoming TcGblEnv in the
719 monad; it augments it and returns the new TcGblEnv.
722 tcRnGroup :: HsGroup RdrName -> TcM ((TcGblEnv, TcLclEnv), DefUses)
723 -- Returns the variables free in the decls, for unused-binding reporting
725 = do { -- Rename the declarations
726 (tcg_env, rn_decls, src_dus) <- rnTopSrcDecls decls ;
727 setGblEnv tcg_env $ do {
729 -- Typecheck the declarations
730 tc_envs <- tcTopSrcDecls rn_decls ;
732 return (tc_envs, src_dus)
735 ------------------------------------------------
736 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, DefUses)
738 = do { -- Bring top level binders into scope
739 (rdr_env, imports) <- importsFromLocalDecls group ;
740 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv`
742 tcg_imports = imports `plusImportAvails`
746 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
748 -- Rename the source decls
749 (tcg_env, rn_src_decls, src_dus) <- initRn SourceMode (rnSrcDecls group) ;
750 setGblEnv tcg_env $ do {
754 -- Import consquential imports
755 let { src_fvs = duUses src_dus } ;
756 rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ;
757 let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ;
759 -- Dump trace of renaming part
760 rnDump (ppr rn_decls) ;
761 rnStats rn_imp_decls ;
763 return (tcg_env, rn_decls, src_dus)
766 ------------------------------------------------
767 tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
769 (HsGroup { hs_tyclds = tycl_decls,
770 hs_instds = inst_decls,
771 hs_fords = foreign_decls,
772 hs_defds = default_decls,
773 hs_ruleds = rule_decls,
774 hs_valds = val_binds })
775 = do { -- Type-check the type and class decls, and all imported decls
776 -- The latter come in via tycl_decls
777 traceTc (text "Tc2") ;
778 tcg_env <- tcTyClDecls tycl_decls ;
779 setGblEnv tcg_env $ do {
781 -- Source-language instances, including derivings,
782 -- and import the supporting declarations
783 traceTc (text "Tc3") ;
784 (tcg_env, inst_infos, deriv_binds, fvs) <- tcInstDecls1 tycl_decls inst_decls ;
785 setGblEnv tcg_env $ do {
786 tcg_env <- importSupportingDecls fvs ;
787 setGblEnv tcg_env $ do {
789 -- Foreign import declarations next. No zonking necessary
790 -- here; we can tuck them straight into the global environment.
791 traceTc (text "Tc4") ;
792 (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
793 tcExtendGlobalValEnv fi_ids $
794 updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls })
797 -- Default declarations
798 traceTc (text "Tc4a") ;
799 default_tys <- tcDefaults default_decls ;
800 updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
802 -- Value declarations next
803 -- We also typecheck any extra binds that came out
804 -- of the "deriving" process
805 traceTc (text "Tc5") ;
806 (tc_val_binds, lcl_env) <- tcTopBinds (val_binds `ThenBinds` deriv_binds) ;
807 setLclTypeEnv lcl_env $ do {
809 -- Second pass over class and instance declarations,
810 -- plus rules and foreign exports, to generate bindings
811 traceTc (text "Tc6") ;
812 (cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ;
813 tcExtendGlobalValEnv dm_ids $ do {
814 inst_binds <- tcInstDecls2 inst_infos ;
815 showLIE (text "after instDecls2") ;
818 -- They need to be zonked, so we return them
819 traceTc (text "Tc7") ;
820 (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
823 -- Need to partition them because the source rules
824 -- must be zonked before adding them to tcg_rules
825 -- NB: built-in rules come in as IfaceRuleOut's, and
826 -- get added to tcg_rules right here by tcExtendRules
827 rules <- tcRules rule_decls ;
828 let { (src_rules, iface_rules) = partition isSrcRule rules } ;
829 tcExtendRules iface_rules $ do {
832 tcg_env <- getGblEnv ;
833 let { all_binds = tc_val_binds `AndMonoBinds`
834 inst_binds `AndMonoBinds`
835 cls_dm_binds `AndMonoBinds`
838 -- Extend the GblEnv with the (as yet un-zonked)
839 -- bindings, rules, foreign decls
840 tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `andMonoBinds` all_binds,
841 tcg_rules = tcg_rules tcg_env ++ src_rules,
842 tcg_fords = tcg_fords tcg_env ++ foe_decls } } ;
844 return (tcg_env', lcl_env)
849 tcTyClDecls :: [RenamedTyClDecl]
852 -- tcTyClDecls deals with
853 -- type and class decls (some source, some imported)
854 -- interface signatures (checked lazily)
856 -- It returns the TcGblEnv for this module, and side-effects the
857 -- persistent compiler state to reflect the things imported from
860 tcTyClDecls tycl_decls
862 -- tcTyAndClassDecls recovers internally, but if anything gave rise to
863 -- an error we'd better stop now, to avoid a cascade
865 traceTc (text "TyCl1") `thenM_`
866 tcTyAndClassDecls tycl_decls `thenM` \ tcg_env ->
867 -- Returns the extended environment
870 traceTc (text "TyCl2") `thenM_`
871 tcInterfaceSigs tycl_decls `thenM` \ tcg_env ->
872 -- Returns the extended environment
879 %************************************************************************
881 Load the old interface file for this module (unless
882 we have it aleady), and check whether it is up to date
885 %************************************************************************
888 checkOldIface :: HscEnv
889 -> PersistentCompilerState
891 -> FilePath -- Where the interface file is
892 -> Bool -- Source unchanged
893 -> Maybe ModIface -- Old interface from compilation manager, if any
894 -> IO (PersistentCompilerState, Maybe (RecompileRequired, Maybe ModIface))
895 -- Nothing <=> errors happened
897 checkOldIface hsc_env pcs mod iface_path source_unchanged maybe_iface
898 = do { showPass (hsc_dflags hsc_env)
899 ("Checking old interface for " ++ moduleUserString mod) ;
901 initTc hsc_env pcs mod
902 (check_old_iface iface_path source_unchanged maybe_iface)
905 check_old_iface iface_path source_unchanged maybe_iface
906 = -- CHECK WHETHER THE SOURCE HAS CHANGED
907 ifM (not source_unchanged)
908 (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
911 -- If the source has changed and we're in interactive mode, avoid reading
912 -- an interface; just return the one we might have been supplied with.
913 getGhciMode `thenM` \ ghci_mode ->
914 if (ghci_mode == Interactive) && not source_unchanged then
915 returnM (outOfDate, maybe_iface)
918 case maybe_iface of {
919 Just old_iface -> -- Use the one we already have
920 checkVersions source_unchanged old_iface `thenM` \ recomp ->
921 returnM (recomp, Just old_iface)
925 -- Try and read the old interface for the current module
926 -- from the .hi file left from the last time we compiled it
927 getModule `thenM` \ this_mod ->
928 readIface this_mod iface_path False `thenM` \ read_result ->
929 case read_result of {
930 Left err -> -- Old interface file not found, or garbled; give up
931 traceHiDiffs (text "FYI: cannot read old interface file:"
932 $$ nest 4 (text (showException err))) `thenM_`
933 returnM (outOfDate, Nothing)
935 ; Right parsed_iface ->
937 -- We found the file and parsed it; now load it
938 tryTc (initRn (InterfaceMode this_mod)
939 (loadOldIface parsed_iface)) `thenM` \ ((_,errs), mb_iface) ->
941 Nothing -> -- Something went wrong in loading. The main likely thing
942 -- is that the usages mentioned B.f, where B.hi and B.hs no
943 -- longer exist. Then newGlobalName2 fails with an error message
944 -- This isn't an error; we just don't have an old iface file to
945 -- look at. Spit out a traceHiDiffs for info though.
946 traceHiDiffs (text "FYI: loading old interface file failed"
947 $$ nest 4 (docToSDoc (pprBagOfErrors errs))) `thenM_`
948 return (outOfDate, Nothing)
952 -- At last, we have got the old iface; check its versions
953 checkVersions source_unchanged iface `thenM` \ recomp ->
954 returnM (recomp, Just iface)
959 %************************************************************************
961 Type-check and rename supporting declarations
962 This is used to deal with the free vars of a splice,
963 or derived code: slurp in the necessary declarations,
964 typecheck them, and add them to the EPS
966 %************************************************************************
969 importSupportingDecls :: FreeVars -> TcM TcGblEnv
970 -- Completely deal with the supporting imports needed
971 -- by the specified free-var set
972 importSupportingDecls fvs
973 = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ;
974 decls <- slurpImpDecls fvs ;
975 traceRn (text "...namely:" <+> vcat (map ppr decls)) ;
976 typecheckIfaceDecls (mkGroup decls) }
978 typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv
979 -- The decls are all interface-file declarations
980 -- Usually they are all from other modules, but when we are reading
981 -- this module's interface from a file, it's possible that some of
982 -- them are for the module being compiled.
983 -- That is why the tcExtendX functions need to do partitioning.
985 -- If all the decls are from other modules, the returned TcGblEnv
986 -- will have an empty tc_genv, but its tc_inst_env
987 -- cache may have been augmented.
988 typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls,
989 hs_instds = inst_decls,
990 hs_ruleds = rule_decls })
991 = do { -- Typecheck the type, class, and interface-sig decls
992 tcg_env <- tcTyClDecls tycl_decls ;
993 setGblEnv tcg_env $ do {
995 -- Typecheck the instance decls, and rules
996 -- Note that imported dictionary functions are already
997 -- in scope from the preceding tcTyClDecls
998 tcIfaceInstDecls inst_decls `thenM` \ dfuns ->
999 tcExtendInstEnv dfuns $
1000 tcRules rule_decls `thenM` \ rules ->
1001 tcExtendRules rules $
1003 getGblEnv -- Return the environment
1009 %*********************************************************
1011 mkGlobalContext: make up an interactive context
1013 Used for initialising the lexical environment
1014 of the interactive read-eval-print loop
1016 %*********************************************************
1021 :: HscEnv -> PersistentCompilerState
1022 -> [Module] -- Expose these modules' top-level scope
1023 -> [Module] -- Expose these modules' exports only
1024 -> IO (PersistentCompilerState, Maybe GlobalRdrEnv)
1026 mkGlobalContext hsc_env pcs toplevs exports
1027 = initTc hsc_env pcs iNTERACTIVE $ do {
1029 toplev_envs <- mappM getTopLevScope toplevs ;
1030 export_envs <- mappM getModuleExports exports ;
1031 returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv
1032 (toplev_envs ++ export_envs))
1035 getTopLevScope :: Module -> TcRn m GlobalRdrEnv
1037 = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1038 case mi_globals iface of
1039 Nothing -> panic "getTopLevScope"
1040 Just env -> returnM env }
1042 getModuleExports :: Module -> TcRn m GlobalRdrEnv
1043 getModuleExports mod
1044 = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1045 returnM (foldl add emptyGlobalRdrEnv (mi_exports iface)) }
1047 prov_fn n = NonLocalDef ImplicitImport
1048 add env (mod,avails)
1049 = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs)
1051 contextDoc = text "context for compiling statements"
1057 -> PersistentCompilerState -- IN: persistent compiler state
1058 -> Module -- module to inspect
1059 -> Bool -- grab just the exports, or the whole toplev
1060 -> IO (PersistentCompilerState, Maybe [TyThing])
1062 getModuleContents hsc_env pcs mod exports_only
1063 = initTc hsc_env pcs iNTERACTIVE $ do {
1065 -- Load the interface if necessary (a home module will certainly
1066 -- alraedy be loaded, but a package module might not be)
1067 iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1069 let { export_names = availsToNameSet export_avails ;
1070 export_avails = [ avail | (mn, avails) <- mi_exports iface,
1071 avail <- avails ] } ;
1073 all_names <- if exports_only then
1075 else case mi_globals iface of {
1077 return (get_locals rdr_env) ;
1079 Nothing -> do { addErr (noRdrEnvErr mod) ;
1080 return export_names } } ;
1081 -- Invariant; we only have (not exports_only)
1082 -- for a home module so it must already be in the HIT
1083 -- So the Nothing case is a bug
1085 env <- importSupportingDecls all_names ;
1086 setGblEnv env (mappM tcLookupGlobal (nameSetToList all_names))
1089 -- Grab all the things from the global env that are locally def'd
1090 get_locals rdr_env = mkNameSet [ gre_name gre
1091 | elts <- rdrEnvElts rdr_env,
1094 -- Make a set because a name is often in the envt in
1095 -- both qualified and unqualified forms
1097 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
1098 <+> quotes (ppr mod)
1102 %************************************************************************
1106 %************************************************************************
1110 = do { ghci_mode <- getGhciMode ;
1111 tcg_env <- getGblEnv ;
1113 mb_main_mod <- readMutVar v_MainModIs ;
1114 mb_main_fn <- readMutVar v_MainFunIs ;
1115 let { main_mod = case mb_main_mod of {
1116 Just mod -> mkModuleName mod ;
1117 Nothing -> mAIN_Name } ;
1118 main_fn = case mb_main_fn of {
1119 Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
1120 Nothing -> main_RDR_Unqual } } ;
1122 check_main ghci_mode tcg_env main_mod main_fn
1126 check_main ghci_mode tcg_env main_mod main_fn
1127 -- If we are in module Main, check that 'main' is defined.
1128 -- It may be imported from another module, in which case
1129 -- we have to drag in its.
1131 -- Also form the definition
1132 -- $main = runIO main
1133 -- so we need to slurp in runIO too.
1135 -- ToDo: We have to return the main_name separately, because it's a
1136 -- bona fide 'use', and should be recorded as such, but the others
1139 -- Blimey: a whole page of code to do this...
1141 | mod_name /= main_mod
1142 = return (tcg_env, emptyFVs)
1144 -- Check that 'main' is in scope
1145 -- It might be imported from another module!
1147 -- We use a guard for this (rather than letting lookupSrcName fail)
1148 -- because it's not an error in ghci)
1149 | not (main_fn `elemRdrEnv` rdr_env)
1150 = do { complain_no_main; return (tcg_env, emptyFVs) }
1152 | otherwise -- OK, so the appropriate 'main' is in scope
1154 = do { main_name <- lookupSrcName main_fn ;
1156 tcg_env <- importSupportingDecls (unitFV runIOName) ;
1158 addSrcLoc (getSrcLoc main_name) $
1159 addErrCtxt mainCtxt $
1160 setGblEnv tcg_env $ do {
1162 -- $main :: IO () = runIO main
1163 let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ;
1164 (main_expr, ty) <- tcInferRho rhs ;
1166 let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) ;
1167 main_bind = VarMonoBind dollar_main_id main_expr ;
1168 tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env
1169 `andMonoBinds` main_bind } } ;
1171 return (tcg_env', unitFV main_name)
1174 mod_name = moduleName (tcg_mod tcg_env)
1175 rdr_env = tcg_rdr_env tcg_env
1177 complain_no_main | ghci_mode == Interactive = return ()
1178 | otherwise = failWithTc noMainMsg
1179 -- In interactive mode, don't worry about the absence of 'main'
1180 -- In other modes, fail altogether, so that we don't go on
1181 -- and complain a second time when processing the export list.
1183 mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
1184 noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
1185 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
1189 %************************************************************************
1193 %************************************************************************
1196 rnDump :: SDoc -> TcRn m ()
1197 -- Dump, with a banner, if -ddump-rn
1198 rnDump doc = dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc)
1200 tcDump :: TcGblEnv -> TcRn m ()
1202 = do { dflags <- getDOpts ;
1204 -- Dump short output if -ddump-types or -ddump-tc
1205 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1206 (dumpTcRn short_dump) ;
1208 -- Dump bindings if -ddump-tc
1209 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1212 short_dump = pprTcGblEnv env
1213 full_dump = ppr (tcg_binds env)
1214 -- NB: foreign x-d's have undefined's in their types;
1215 -- hence can't show the tc_fords
1218 = do { dflags <- getDOpts ;
1219 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1220 (dumpTcRn (pprModGuts mod_guts)) ;
1222 -- Dump bindings if -ddump-tc
1223 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1225 full_dump = pprCoreBindings (mg_binds mod_guts)
1227 -- It's unpleasant having both pprModGuts and pprModDetails here
1228 pprTcGblEnv :: TcGblEnv -> SDoc
1229 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1230 tcg_insts = dfun_ids,
1232 tcg_imports = imports })
1233 = vcat [ ppr_types dfun_ids type_env
1234 , ppr_insts dfun_ids
1235 , vcat (map ppr rules)
1236 , ppr_gen_tycons (typeEnvTyCons type_env)
1237 , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports))
1238 , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1240 pprModGuts :: ModGuts -> SDoc
1241 pprModGuts (ModGuts { mg_types = type_env,
1243 = vcat [ ppr_types [] type_env,
1247 ppr_types :: [Var] -> TypeEnv -> SDoc
1248 ppr_types dfun_ids type_env
1249 = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1251 ids = [id | id <- typeEnvIds type_env, want_sig id]
1252 want_sig id | opt_PprStyle_Debug = True
1253 | otherwise = isLocalId id &&
1254 isExternalName (idName id) &&
1255 not (id `elem` dfun_ids)
1256 -- isLocalId ignores data constructors, records selectors etc.
1257 -- The isExternalName ignores local dictionary and method bindings
1258 -- that the type checker has invented. Top-level user-defined things
1259 -- have External names.
1261 ppr_insts :: [Var] -> SDoc
1262 ppr_insts [] = empty
1263 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1265 ppr_sigs :: [Var] -> SDoc
1267 -- Print type signatures
1268 -- Convert to HsType so that we get source-language style printing
1269 -- And sort by RdrName
1270 = vcat $ map ppr_sig $ sortLt lt_sig $
1271 [ (getRdrName id, toHsType (tidyTopType (idType id)))
1274 lt_sig (n1,_) (n2,_) = n1 < n2
1275 ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t
1278 ppr_rules :: [IdCoreRule] -> SDoc
1279 ppr_rules [] = empty
1280 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1281 nest 4 (pprIdRules rs),
1284 ppr_gen_tycons [] = empty
1285 ppr_gen_tycons tcs = vcat [ptext SLIT("Generic type constructor details:"),
1286 nest 2 (vcat (map ppr_gen_tycon tcs))
1289 -- x&y are now Id's, not CoreExpr's
1291 | Just ep <- tyConGenInfo tycon
1292 = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
1294 | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
1297 = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
1298 ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
1299 ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to))
1302 (_,from_tau) = tcSplitForAllTys (idType from)