2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcModule]{Typechecking a whole module}
9 mkGlobalContext, getModuleContents,
11 tcRnModule, checkOldIface,
12 importSupportingDecls, tcTopSrcDecls,
13 tcRnIface, tcRnExtCore, tcRnStmt, tcRnExpr, tcRnThing
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 DriverUtil ( split_longest_prefix )
26 import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..),
27 Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..),
28 HsGroup(..), SpliceDecl(..),
29 mkSimpleMatch, placeHolderType, toHsType, andMonoBinds,
30 isSrcRule, collectStmtsBinders
32 import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr,
33 emptyGroup, mkGroup, findSplice, addImpDecls, main_RDR_Unqual )
35 import PrelNames ( iNTERACTIVE, ioTyConName, printName,
36 returnIOName, bindIOName, failIOName, thenIOName, runIOName,
37 dollarMainName, itName, mAIN_Name
39 import MkId ( unsafeCoerceId )
40 import RdrName ( RdrName, getRdrName, mkRdrUnqual,
41 lookupRdrEnv, elemRdrEnv )
43 import RnHsSyn ( RenamedStmt, RenamedTyClDecl,
44 ruleDeclFVs, instDeclFVs, tyClDeclFVs )
45 import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl,
46 zonkTopDecls, mkHsLet,
47 zonkTopExpr, zonkTopBndrs
50 import TcExpr ( tcInferRho )
52 import TcMType ( newTyVarTy, zonkTcType )
53 import TcType ( Type, liftedTypeKind,
54 tyVarsOfType, tcFunResultTy, tidyTopType,
55 mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
57 import TcMatches ( tcStmtsAndThen )
58 import Inst ( showLIE )
59 import TcBinds ( tcTopBinds )
60 import TcClassDcl ( tcClassDecls2 )
61 import TcDefaults ( tcDefaults )
62 import TcEnv ( tcExtendGlobalValEnv,
63 tcExtendInstEnv, tcExtendRules,
64 tcLookupTyCon, tcLookupGlobal,
67 import TcRules ( tcRules )
68 import TcForeign ( tcForeignImports, tcForeignExports )
69 import TcIfaceSig ( tcInterfaceSigs, tcCoreBinds )
70 import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls, tcInstDecls2 )
71 import TcSimplify ( tcSimplifyTop, tcSimplifyInfer )
72 import TcTyClsDecls ( tcTyAndClassDecls )
74 import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
76 import RnIfaces ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate )
77 import RnHiFiles ( readIface, loadOldIface )
78 import RnEnv ( lookupSrcName, lookupOccRn, plusGlobalRdrEnv,
79 ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs )
80 import RnExpr ( rnStmts, rnExpr )
81 import RnSource ( rnSrcDecls, checkModDeprec, rnStats )
83 import CoreUnfold ( unfoldingTemplate )
84 import CoreSyn ( IdCoreRule, Bind(..) )
85 import PprCore ( pprIdRules, pprCoreBindings )
86 import TysWiredIn ( mkListTy, unitTy )
87 import ErrUtils ( mkDumpDoc, showPass, pprBagOfErrors )
88 import Id ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported )
89 import IdInfo ( GlobalIdDetails(..) )
90 import Var ( Var, setGlobalIdDetails )
91 import Module ( Module, ModuleName, mkHomeModule, mkModuleName, moduleName, moduleUserString, moduleEnvElts )
92 import OccName ( mkVarOcc )
93 import Name ( Name, isExternalName, getSrcLoc, nameOccName )
94 import NameEnv ( delListFromNameEnv )
96 import TyCon ( tyConGenInfo )
97 import BasicTypes ( EP(..), RecFlag(..) )
98 import SrcLoc ( noSrcLoc )
100 import HscTypes ( PersistentCompilerState(..), InteractiveContext(..),
101 ModIface, ModDetails(..), ModGuts(..),
103 ModIface(..), ModDetails(..), IfaceDecls(..),
104 GhciMode(..), noDependencies,
105 Deprecations(..), plusDeprecs,
107 GenAvailInfo(Avail), availsToNameSet,
109 TypeEnv, TyThing, typeEnvTyCons,
110 extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
111 extendLocalRdrEnv, emptyFixityEnv
114 import RdrName ( rdrEnvElts )
115 import RnHiFiles ( loadInterface )
116 import RnEnv ( mkGlobalRdrEnv )
117 import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(..),
121 import DATA_IOREF ( readIORef )
122 import FastString ( mkFastString )
123 import Panic ( showException )
124 import List ( partition )
125 import Util ( sortLt )
130 %************************************************************************
132 Typecheck and rename a module
134 %************************************************************************
138 tcRnModule :: HscEnv -> PersistentCompilerState
140 -> IO (PersistentCompilerState, Maybe TcGblEnv)
142 tcRnModule hsc_env pcs
143 (HsModule maybe_mod exports import_decls local_decls mod_deprec loc)
144 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
146 let { this_mod = case maybe_mod of
147 Nothing -> mkHomeModule mAIN_Name -- 'module M where' is omitted
148 Just mod -> mod } ; -- The normal case
150 initTc hsc_env pcs this_mod $ addSrcLoc loc $
151 do { -- Deal with imports; sets tcg_rdr_env, tcg_imports
152 (rdr_env, imports) <- rnImports import_decls ;
153 updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
154 tcg_imports = tcg_imports gbl `plusImportAvails` imports })
156 traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
157 -- Fail if there are any errors so far
158 -- The error printing (if needed) takes advantage
159 -- of the tcg_env we have now set
162 traceRn (text "rn1a") ;
163 -- Rename and type check the declarations
164 (tcg_env, src_dus) <- tcRnSrcDecls local_decls ;
165 setGblEnv tcg_env $ do {
167 traceRn (text "rn3") ;
168 -- Check whether the entire module is deprecated
169 -- This happens only once per module
170 -- Returns the full new deprecations; a module deprecation
171 -- over-rides the earlier ones
172 let { mod_deprecs = checkModDeprec mod_deprec } ;
173 updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` mod_deprecs })
176 -- Process the export list
177 export_avails <- exportsFromAvail maybe_mod exports ;
178 updGblEnv (\gbl -> gbl { tcg_exports = export_avails })
181 -- Get any supporting decls for the exports that have not already
182 -- been sucked in for the declarations in the body of the module.
183 -- (This can happen if something is imported only to be re-exported.)
185 -- Importing these supporting declarations is required
186 -- *only* to gether usage information
187 -- (see comments with MkIface.mkImportInfo for why)
188 -- For OneShot compilation we could just throw away the decls
189 -- but for Batch or Interactive we must put them in the type
190 -- envt because they've been removed from the holding pen
191 let { export_fvs = availsToNameSet export_avails } ;
192 tcg_env <- importSupportingDecls export_fvs ;
193 setGblEnv tcg_env $ do {
195 -- Report unused names
196 let { all_dus = src_dus `plusDU` usesOnly export_fvs } ;
197 reportUnusedNames tcg_env all_dus ;
199 -- Dump output and return
206 %*********************************************************
208 \subsection{Closing up the interface decls}
210 %*********************************************************
212 Suppose we discover we don't need to recompile. Then we start from the
213 IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need.
217 -> PersistentCompilerState
218 -> ModIface -- Get the decls from here
219 -> IO (PersistentCompilerState, Maybe ModDetails)
220 -- Nothing <=> errors happened
221 tcRnIface hsc_env pcs
222 (ModIface {mi_module = mod, mi_decls = iface_decls})
223 = initTc hsc_env pcs mod $ do {
225 -- Get the supporting decls, and typecheck them all together
226 -- so that any mutually recursive types are done right
227 extra_decls <- slurpImpDecls needed ;
228 env <- typecheckIfaceDecls (group `addImpDecls` extra_decls) ;
230 returnM (ModDetails { md_types = tcg_type_env env,
231 md_insts = tcg_insts env,
232 md_rules = hsCoreRules (tcg_rules env)
233 -- All the rules from an interface are of the IfaceRuleOut form
236 rule_decls = dcl_rules iface_decls
237 inst_decls = dcl_insts iface_decls
238 tycl_decls = dcl_tycl iface_decls
239 group = emptyGroup { hs_ruleds = rule_decls,
240 hs_instds = inst_decls,
241 hs_tyclds = tycl_decls }
242 needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets`
243 unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets`
244 unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets`
246 -- Data type decls with record selectors,
247 -- which may appear in the decls, need unpackCString
248 -- and friends. It's easier to just grab them right now.
250 hsCoreRules :: [TypecheckedRuleDecl] -> [IdCoreRule]
251 -- All post-typechecking Iface rules have the form IfaceRuleOut
252 hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules]
256 %************************************************************************
258 The interactive interface
260 %************************************************************************
263 tcRnStmt :: HscEnv -> PersistentCompilerState
264 -> InteractiveContext
266 -> IO (PersistentCompilerState,
267 Maybe (InteractiveContext, [Name], TypecheckedHsExpr))
268 -- The returned [Name] is the same as the input except for
269 -- ExprStmt, in which case the returned [Name] is [itName]
271 -- The returned TypecheckedHsExpr is of type IO [ () ],
272 -- a list of the bound values, coerced to ().
274 tcRnStmt hsc_env pcs ictxt rdr_stmt
275 = initTc hsc_env pcs iNTERACTIVE $
276 setInteractiveContext ictxt $ do {
278 -- Rename; use CmdLineMode because tcRnStmt is only used interactively
279 ([rn_stmt], fvs) <- initRnInteractive ictxt
280 (rnStmts DoExpr [rdr_stmt]) ;
281 traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
284 -- Suck in the supporting declarations and typecheck them
285 tcg_env <- importSupportingDecls (fvs `plusFV` implicitStmtFVs fvs) ;
286 -- NB: an earlier version deleted (rdrEnvElts local_env) from
287 -- the fvs. But (a) that isn't necessary, because previously
288 -- bound things in the local_env will be in the TypeEnv, and
289 -- the renamer doesn't re-slurp such things, and
290 -- (b) it's WRONG to delete them. Consider in GHCi:
291 -- Mod> let x = e :: T
292 -- Mod> let y = x + 3
293 -- We need to pass 'x' among the fvs to slurpImpDecls, so that
294 -- the latter can see that T is a gate, and hence import the Num T
295 -- instance decl. (See the InTypEnv case in RnIfaces.slurpSourceRefs.)
296 setGblEnv tcg_env $ do {
298 -- The real work is done here
299 ((bound_ids, tc_expr), lie) <- getLIE (tcUserStmt rn_stmt) ;
301 traceTc (text "tcs 1") ;
302 let { -- Make all the bound ids "global" ids, now that
303 -- they're notionally top-level bindings. This is
304 -- important: otherwise when we come to compile an expression
305 -- using these ids later, the byte code generator will consider
306 -- the occurrences to be free rather than global.
307 global_ids = map globaliseId bound_ids ;
308 globaliseId id = setGlobalIdDetails id VanillaGlobal ;
310 -- Update the interactive context
311 rn_env = ic_rn_local_env ictxt ;
312 type_env = ic_type_env ictxt ;
314 bound_names = map idName global_ids ;
315 new_rn_env = extendLocalRdrEnv rn_env bound_names ;
317 -- Remove any shadowed bindings from the type_env;
318 -- they are inaccessible but might, I suppose, cause
319 -- a space leak if we leave them there
320 shadowed = [ n | name <- bound_names,
321 let rdr_name = mkRdrUnqual (nameOccName name),
322 Just n <- [lookupRdrEnv rn_env rdr_name] ] ;
324 filtered_type_env = delListFromNameEnv type_env shadowed ;
325 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
327 new_ic = ictxt { ic_rn_local_env = new_rn_env,
328 ic_type_env = new_type_env }
331 dumpOptTcRn Opt_D_dump_tc
332 (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
333 text "Typechecked expr" <+> ppr tc_expr]) ;
335 returnM (new_ic, bound_names, tc_expr)
340 Here is the grand plan, implemented in tcUserStmt
342 What you type The IO [HValue] that hscStmt returns
343 ------------- ------------------------------------
344 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
347 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
350 expr (of IO type) ==> expr >>= \ v -> return [coerce HVal v]
351 [NB: result not printed] bindings: [it]
353 expr (of non-IO type, ==> let v = expr in print v >> return [coerce HVal v]
354 result showable) bindings: [it]
356 expr (of non-IO type,
357 result not showable) ==> error
361 ---------------------------
362 tcUserStmt :: RenamedStmt -> TcM ([Id], TypecheckedHsExpr)
363 tcUserStmt (ExprStmt expr _ loc)
364 = newUnique `thenM` \ uniq ->
366 fresh_it = itName uniq
367 the_bind = FunMonoBind fresh_it False
368 [ mkSimpleMatch [] expr placeHolderType loc ] loc
370 tryTcLIE_ (do { -- Try this if the other fails
371 traceTc (text "tcs 1b") ;
373 LetStmt (MonoBind the_bind [] NonRecursive),
374 ExprStmt (HsApp (HsVar printName) (HsVar fresh_it))
375 placeHolderType loc] })
376 (do { -- Try this first
377 traceTc (text "tcs 1a") ;
378 tc_stmts [BindStmt (VarPat fresh_it) expr loc] })
380 tcUserStmt stmt = tc_stmts [stmt]
382 ---------------------------
384 = do { io_ids <- mappM tcLookupId
385 [returnIOName, failIOName, bindIOName, thenIOName] ;
386 ioTyCon <- tcLookupTyCon ioTyConName ;
387 res_ty <- newTyVarTy liftedTypeKind ;
389 names = collectStmtsBinders stmts ;
390 return_id = head io_ids ; -- Rather gruesome
392 io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty) ;
394 -- mk_return builds the expression
395 -- returnIO @ [()] [coerce () x, .., coerce () z]
396 mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy])
397 (ExplicitList unitTy (map mk_item ids)) ;
399 mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
402 -- OK, we're ready to typecheck the stmts
403 traceTc (text "tcs 2") ;
404 ((ids, tc_stmts), lie) <-
405 getLIE $ tcStmtsAndThen combine DoExpr io_ty stmts $
407 -- Look up the names right in the middle,
408 -- where they will all be in scope
409 ids <- mappM tcLookupId names ;
410 return (ids, [ResultStmt (mk_return ids) noSrcLoc])
413 -- Simplify the context right here, so that we fail
414 -- if there aren't enough instances. Notably, when we see
416 -- we use recoverTc_ to try it <- e
417 -- and then let it = e
418 -- It's the simplify step that rejects the first.
419 traceTc (text "tcs 3") ;
420 const_binds <- tcSimplifyTop lie ;
422 -- Build result expression and zonk it
423 let { expr = mkHsLet const_binds $
424 HsDo DoExpr tc_stmts io_ids
425 (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc } ;
426 zonked_expr <- zonkTopExpr expr ;
427 zonked_ids <- zonkTopBndrs ids ;
429 return (zonked_ids, zonked_expr)
432 combine stmt (ids, stmts) = (ids, stmt:stmts)
436 tcRnExpr just finds the type of an expression
439 tcRnExpr :: HscEnv -> PersistentCompilerState
440 -> InteractiveContext
442 -> IO (PersistentCompilerState, Maybe Type)
443 tcRnExpr hsc_env pcs ictxt rdr_expr
444 = initTc hsc_env pcs iNTERACTIVE $
445 setInteractiveContext ictxt $ do {
447 (rn_expr, fvs) <- initRnInteractive ictxt (rnExpr rdr_expr) ;
450 -- Suck in the supporting declarations and typecheck them
451 tcg_env <- importSupportingDecls (fvs `plusFV` ubiquitousNames) ;
452 setGblEnv tcg_env $ do {
454 -- Now typecheck the expression;
455 -- it might have a rank-2 type (e.g. :t runST)
456 ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
457 ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
458 tcSimplifyTop lie_top ;
460 let { all_expr_ty = mkForAllTys qtvs $
461 mkFunTys (map idType dict_ids) $
463 zonkTcType all_expr_ty
466 smpl_doc = ptext SLIT("main expression")
471 tcRnThing :: HscEnv -> PersistentCompilerState
472 -> InteractiveContext
474 -> IO (PersistentCompilerState, Maybe [TyThing])
475 -- Look up a RdrName and return all the TyThings it might be
476 -- We treat a capitalised RdrName as both a data constructor
477 -- and as a type or class constructor; hence we return up to two results
478 tcRnThing hsc_env pcs ictxt rdr_name
479 = initTc hsc_env pcs iNTERACTIVE $
480 setInteractiveContext ictxt $ do {
482 -- If the identifier is a constructor (begins with an
483 -- upper-case letter), then we need to consider both
484 -- constructor and type class identifiers.
485 let { rdr_names = dataTcOccs rdr_name } ;
487 -- results :: [(Messages, Maybe Name)]
488 results <- initRnInteractive ictxt
489 (mapM (tryTc . lookupOccRn) rdr_names) ;
491 -- The successful lookups will be (Just name)
492 let { (warns_s, good_names) = unzip [ (msgs, name)
493 | (msgs, Just name) <- results] ;
494 errs_s = [msgs | (msgs, Nothing) <- results] } ;
496 -- Fail if nothing good happened, else add warnings
497 if null good_names then -- Fail
498 do { addMessages (head errs_s) ; failM }
499 else -- Add deprecation warnings
500 mapM_ addMessages warns_s ;
502 -- Slurp in the supporting declarations
503 tcg_env <- importSupportingDecls (mkFVs good_names) ;
504 setGblEnv tcg_env $ do {
506 -- And lookup up the entities
507 mapM tcLookupGlobal good_names
513 setInteractiveContext :: InteractiveContext -> TcRn m a -> TcRn m a
514 setInteractiveContext icxt thing_inside
515 = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_`
516 updGblEnv (\ env -> env { tcg_rdr_env = ic_rn_gbl_env icxt,
517 tcg_type_env = ic_type_env icxt })
520 initRnInteractive :: InteractiveContext -> RnM a -> TcM a
521 -- Set the local RdrEnv from the interactive context
522 initRnInteractive ictxt rn_thing
523 = initRn CmdLineMode $
524 setLocalRdrEnv (ic_rn_local_env ictxt) $
528 %************************************************************************
530 Type-checking external-core modules
532 %************************************************************************
535 tcRnExtCore :: HscEnv -> PersistentCompilerState
537 -> IO (PersistentCompilerState, Maybe ModGuts)
538 -- Nothing => some error occurred
540 tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc)
541 -- For external core, the module name is syntactically reqd
542 -- Rename the (Core) module. It's a bit like an interface
543 -- file: all names are original names
544 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
546 initTc hsc_env pcs this_mod $ addSrcLoc loc $ do {
548 -- Rename the source, only in interface mode.
549 -- rnSrcDecls handles fixity decls etc too, which won't occur
550 -- but that doesn't matter
551 let { local_group = mkGroup decls } ;
552 (_, rn_decls, dus) <- initRn (InterfaceMode this_mod)
553 (rnSrcDecls local_group) ;
556 -- Get the supporting decls
557 rn_imp_decls <- slurpImpDecls (duUses dus) ;
558 let { rn_decls = rn_decls `addImpDecls` rn_imp_decls } ;
560 -- Dump trace of renaming part
561 rnDump (ppr rn_decls) ;
562 rnStats rn_imp_decls ;
564 -- Typecheck them all together so that
565 -- any mutually recursive types are done right
566 tcg_env <- typecheckIfaceDecls rn_decls ;
567 setGblEnv tcg_env $ do {
569 -- Now the core bindings
570 core_prs <- tcCoreBinds (hs_coreds rn_decls) ;
571 tcExtendGlobalValEnv (map fst core_prs) $ do {
575 bndrs = map fst core_prs ;
576 my_exports = map (Avail . idName) bndrs ;
577 -- ToDo: export the data types also?
579 final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
581 mod_guts = ModGuts { mg_module = this_mod,
582 mg_usages = [], -- ToDo: compute usage
583 mg_dir_imps = [], -- ??
584 mg_deps = noDependencies, -- ??
585 mg_exports = my_exports,
586 mg_types = final_type_env,
587 mg_insts = tcg_insts tcg_env,
588 mg_rules = hsCoreRules (tcg_rules tcg_env),
589 mg_binds = [Rec core_prs],
592 mg_rdr_env = emptyGlobalRdrEnv,
593 mg_fix_env = emptyFixityEnv,
594 mg_deprecs = NoDeprecs,
598 tcCoreDump mod_guts ;
605 %************************************************************************
607 Type-checking the top level of a module
609 %************************************************************************
612 tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, DefUses)
613 -- Returns the variables free in the decls
614 -- Reason: solely to report unused imports and bindings
616 = do { -- Do all the declarations
617 ((tc_envs, dus), lie) <- getLIE (tc_rn_src_decls decls) ;
619 -- tcSimplifyTop deals with constant or ambiguous InstIds.
620 -- How could there be ambiguous ones? They can only arise if a
621 -- top-level decl falls under the monomorphism
622 -- restriction, and no subsequent decl instantiates its
623 -- type. (Usually, ambiguous type variables are resolved
624 -- during the generalisation step.)
625 traceTc (text "Tc8") ;
626 setEnvs tc_envs $ do {
627 -- Setting the global env exposes the instances to tcSimplifyTop
628 -- Setting the local env exposes the local Ids, so that
629 -- we get better error messages (monomorphism restriction)
630 inst_binds <- tcSimplifyTop lie ;
632 -- Backsubstitution. This must be done last.
633 -- Even tcSimplifyTop may do some unification.
634 traceTc (text "Tc9") ;
635 let { (tcg_env, _) = tc_envs ;
636 TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
637 tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
639 (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
642 return (tcg_env { tcg_type_env = extendTypeEnvWithIds type_env bind_ids,
643 tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' },
647 tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), DefUses)
650 = do { let { (first_group, group_tail) = findSplice ds } ;
651 -- If ds is [] we get ([], Nothing)
653 -- Type check the decls up to, but not including, the first splice
654 (tc_envs@(_,tcl_env), src_dus1) <- tcRnGroup first_group ;
656 -- Bale out if errors; for example, error recovery when checking
657 -- the RHS of 'main' can mean that 'main' is not in the envt for
658 -- the subsequent checkMain test
663 -- If there is no splice, we're nearly done
665 Nothing -> do { -- Last thing: check for `main'
666 (tcg_env, main_fvs) <- checkMain ;
667 return ((tcg_env, tcl_env),
668 src_dus1 `plusDU` usesOnly main_fvs)
671 -- If there's a splice, we must carry on
672 Just (SpliceDecl splice_expr splice_loc, rest_ds) -> do {
674 failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
677 -- Rename the splice expression, and get its supporting decls
678 (rn_splice_expr, splice_fvs) <- initRn SourceMode $
679 addSrcLoc splice_loc $
681 tcg_env <- importSupportingDecls (splice_fvs `plusFV` templateHaskellNames) ;
682 setGblEnv tcg_env $ do {
684 -- Execute the splice
685 spliced_decls <- tcSpliceDecls rn_splice_expr ;
687 -- Glue them on the front of the remaining decls and loop
688 (tc_envs, src_dus2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ;
690 return (tc_envs, src_dus1 `plusDU` usesOnly splice_fvs `plusDU` src_dus2)
697 %************************************************************************
699 Type-checking the top level of a module
701 %************************************************************************
703 tcRnGroup takes a bunch of top-level source-code declarations, and
705 * gets supporting declarations from interface files
708 * and augments the TcGblEnv with the results
710 In Template Haskell it may be called repeatedly for each group of
711 declarations. It expects there to be an incoming TcGblEnv in the
712 monad; it augments it and returns the new TcGblEnv.
715 tcRnGroup :: HsGroup RdrName -> TcM ((TcGblEnv, TcLclEnv), DefUses)
716 -- Returns the variables free in the decls, for unused-binding reporting
718 = do { -- Rename the declarations
719 (tcg_env, rn_decls, src_dus) <- rnTopSrcDecls decls ;
720 setGblEnv tcg_env $ do {
722 -- Typecheck the declarations
723 tc_envs <- tcTopSrcDecls rn_decls ;
725 return (tc_envs, src_dus)
728 ------------------------------------------------
729 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, DefUses)
731 = do { -- Bring top level binders into scope
732 (rdr_env, imports) <- importsFromLocalDecls group ;
733 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv`
735 tcg_imports = imports `plusImportAvails`
739 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
741 -- Rename the source decls
742 (tcg_env, rn_src_decls, src_dus) <- initRn SourceMode (rnSrcDecls group) ;
743 setGblEnv tcg_env $ do {
747 -- Import consquential imports
748 let { src_fvs = duUses src_dus } ;
749 rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ;
750 let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ;
752 -- Dump trace of renaming part
753 rnDump (ppr rn_decls) ;
754 rnStats rn_imp_decls ;
756 return (tcg_env, rn_decls, src_dus)
759 ------------------------------------------------
760 tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
762 (HsGroup { hs_tyclds = tycl_decls,
763 hs_instds = inst_decls,
764 hs_fords = foreign_decls,
765 hs_defds = default_decls,
766 hs_ruleds = rule_decls,
767 hs_valds = val_binds })
768 = do { -- Type-check the type and class decls, and all imported decls
769 -- The latter come in via tycl_decls
770 traceTc (text "Tc2") ;
771 tcg_env <- tcTyClDecls tycl_decls ;
772 setGblEnv tcg_env $ do {
774 -- Source-language instances, including derivings,
775 -- and import the supporting declarations
776 traceTc (text "Tc3") ;
777 (tcg_env, inst_infos, deriv_binds, fvs) <- tcInstDecls1 tycl_decls inst_decls ;
778 setGblEnv tcg_env $ do {
779 tcg_env <- importSupportingDecls fvs ;
780 setGblEnv tcg_env $ do {
782 -- Foreign import declarations next. No zonking necessary
783 -- here; we can tuck them straight into the global environment.
784 traceTc (text "Tc4") ;
785 (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
786 tcExtendGlobalValEnv fi_ids $
787 updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls })
790 -- Default declarations
791 traceTc (text "Tc4a") ;
792 default_tys <- tcDefaults default_decls ;
793 updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
795 -- Value declarations next
796 -- We also typecheck any extra binds that came out
797 -- of the "deriving" process
798 traceTc (text "Tc5") ;
799 (tc_val_binds, lcl_env) <- tcTopBinds (val_binds `ThenBinds` deriv_binds) ;
800 setLclTypeEnv lcl_env $ do {
802 -- Second pass over class and instance declarations,
803 -- plus rules and foreign exports, to generate bindings
804 traceTc (text "Tc6") ;
805 (cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ;
806 tcExtendGlobalValEnv dm_ids $ do {
807 inst_binds <- tcInstDecls2 inst_infos ;
808 showLIE (text "after instDecls2") ;
811 -- They need to be zonked, so we return them
812 traceTc (text "Tc7") ;
813 (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
816 -- Need to partition them because the source rules
817 -- must be zonked before adding them to tcg_rules
818 -- NB: built-in rules come in as IfaceRuleOut's, and
819 -- get added to tcg_rules right here by tcExtendRules
820 rules <- tcRules rule_decls ;
821 let { (src_rules, iface_rules) = partition isSrcRule rules } ;
822 tcExtendRules iface_rules $ do {
825 tcg_env <- getGblEnv ;
826 let { all_binds = tc_val_binds `AndMonoBinds`
827 inst_binds `AndMonoBinds`
828 cls_dm_binds `AndMonoBinds`
831 -- Extend the GblEnv with the (as yet un-zonked)
832 -- bindings, rules, foreign decls
833 tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `andMonoBinds` all_binds,
834 tcg_rules = tcg_rules tcg_env ++ src_rules,
835 tcg_fords = tcg_fords tcg_env ++ foe_decls } } ;
837 return (tcg_env', lcl_env)
842 tcTyClDecls :: [RenamedTyClDecl]
845 -- tcTyClDecls deals with
846 -- type and class decls (some source, some imported)
847 -- interface signatures (checked lazily)
849 -- It returns the TcGblEnv for this module, and side-effects the
850 -- persistent compiler state to reflect the things imported from
853 tcTyClDecls tycl_decls
855 -- tcTyAndClassDecls recovers internally, but if anything gave rise to
856 -- an error we'd better stop now, to avoid a cascade
858 traceTc (text "TyCl1") `thenM_`
859 tcTyAndClassDecls tycl_decls `thenM` \ tcg_env ->
860 -- Returns the extended environment
863 traceTc (text "TyCl2") `thenM_`
864 tcInterfaceSigs tycl_decls `thenM` \ tcg_env ->
865 -- Returns the extended environment
872 %************************************************************************
874 Load the old interface file for this module (unless
875 we have it aleady), and check whether it is up to date
878 %************************************************************************
881 checkOldIface :: HscEnv
882 -> PersistentCompilerState
884 -> FilePath -- Where the interface file is
885 -> Bool -- Source unchanged
886 -> Maybe ModIface -- Old interface from compilation manager, if any
887 -> IO (PersistentCompilerState, Maybe (RecompileRequired, Maybe ModIface))
888 -- Nothing <=> errors happened
890 checkOldIface hsc_env pcs mod iface_path source_unchanged maybe_iface
891 = do { showPass (hsc_dflags hsc_env)
892 ("Checking old interface for " ++ moduleUserString mod) ;
894 initTc hsc_env pcs mod
895 (check_old_iface iface_path source_unchanged maybe_iface)
898 check_old_iface iface_path source_unchanged maybe_iface
899 = -- CHECK WHETHER THE SOURCE HAS CHANGED
900 ifM (not source_unchanged)
901 (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
904 -- If the source has changed and we're in interactive mode, avoid reading
905 -- an interface; just return the one we might have been supplied with.
906 getGhciMode `thenM` \ ghci_mode ->
907 if (ghci_mode == Interactive) && not source_unchanged then
908 returnM (outOfDate, maybe_iface)
911 case maybe_iface of {
912 Just old_iface -> -- Use the one we already have
913 checkVersions source_unchanged old_iface `thenM` \ recomp ->
914 returnM (recomp, Just old_iface)
918 -- Try and read the old interface for the current module
919 -- from the .hi file left from the last time we compiled it
920 getModule `thenM` \ this_mod ->
921 readIface this_mod iface_path False `thenM` \ read_result ->
922 case read_result of {
923 Left err -> -- Old interface file not found, or garbled; give up
924 traceHiDiffs (text "FYI: cannot read old interface file:"
925 $$ nest 4 (text (showException err))) `thenM_`
926 returnM (outOfDate, Nothing)
928 ; Right parsed_iface ->
930 -- We found the file and parsed it; now load it
931 tryTc (initRn (InterfaceMode this_mod)
932 (loadOldIface parsed_iface)) `thenM` \ ((_,errs), mb_iface) ->
934 Nothing -> -- Something went wrong in loading. The main likely thing
935 -- is that the usages mentioned B.f, where B.hi and B.hs no
936 -- longer exist. Then newGlobalName2 fails with an error message
937 -- This isn't an error; we just don't have an old iface file to
938 -- look at. Spit out a traceHiDiffs for info though.
939 traceHiDiffs (text "FYI: loading old interface file failed"
940 $$ nest 4 (docToSDoc (pprBagOfErrors errs))) `thenM_`
941 return (outOfDate, Nothing)
945 -- At last, we have got the old iface; check its versions
946 checkVersions source_unchanged iface `thenM` \ recomp ->
947 returnM (recomp, Just iface)
952 %************************************************************************
954 Type-check and rename supporting declarations
955 This is used to deal with the free vars of a splice,
956 or derived code: slurp in the necessary declarations,
957 typecheck them, and add them to the EPS
959 %************************************************************************
962 importSupportingDecls :: FreeVars -> TcM TcGblEnv
963 -- Completely deal with the supporting imports needed
964 -- by the specified free-var set
965 importSupportingDecls fvs
966 = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ;
967 decls <- slurpImpDecls fvs ;
968 traceRn (text "...namely:" <+> vcat (map ppr decls)) ;
969 typecheckIfaceDecls (mkGroup decls) }
971 typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv
972 -- The decls are all interface-file declarations
973 -- Usually they are all from other modules, but when we are reading
974 -- this module's interface from a file, it's possible that some of
975 -- them are for the module being compiled.
976 -- That is why the tcExtendX functions need to do partitioning.
978 -- If all the decls are from other modules, the returned TcGblEnv
979 -- will have an empty tc_genv, but its tc_inst_env
980 -- cache may have been augmented.
981 typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls,
982 hs_instds = inst_decls,
983 hs_ruleds = rule_decls })
984 = do { -- Typecheck the type, class, and interface-sig decls
985 tcg_env <- tcTyClDecls tycl_decls ;
986 setGblEnv tcg_env $ do {
988 -- Typecheck the instance decls, and rules
989 -- Note that imported dictionary functions are already
990 -- in scope from the preceding tcTyClDecls
991 tcIfaceInstDecls inst_decls `thenM` \ dfuns ->
992 tcExtendInstEnv dfuns $
993 tcRules rule_decls `thenM` \ rules ->
994 tcExtendRules rules $
996 getGblEnv -- Return the environment
1002 %*********************************************************
1004 mkGlobalContext: make up an interactive context
1006 Used for initialising the lexical environment
1007 of the interactive read-eval-print loop
1009 %*********************************************************
1014 :: HscEnv -> PersistentCompilerState
1015 -> [Module] -- Expose these modules' top-level scope
1016 -> [Module] -- Expose these modules' exports only
1017 -> IO (PersistentCompilerState, Maybe GlobalRdrEnv)
1019 mkGlobalContext hsc_env pcs toplevs exports
1020 = initTc hsc_env pcs iNTERACTIVE $ do {
1022 toplev_envs <- mappM getTopLevScope toplevs ;
1023 export_envs <- mappM getModuleExports exports ;
1024 returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv
1025 (toplev_envs ++ export_envs))
1028 getTopLevScope :: Module -> TcRn m GlobalRdrEnv
1030 = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1031 case mi_globals iface of
1032 Nothing -> panic "getTopLevScope"
1033 Just env -> returnM env }
1035 getModuleExports :: Module -> TcRn m GlobalRdrEnv
1036 getModuleExports mod
1037 = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1038 returnM (foldl add emptyGlobalRdrEnv (mi_exports iface)) }
1040 prov_fn n = NonLocalDef ImplicitImport
1041 add env (mod,avails)
1042 = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs)
1044 contextDoc = text "context for compiling statements"
1050 -> PersistentCompilerState -- IN: persistent compiler state
1051 -> Module -- module to inspect
1052 -> Bool -- grab just the exports, or the whole toplev
1053 -> IO (PersistentCompilerState, Maybe [TyThing])
1055 getModuleContents hsc_env pcs mod exports_only
1056 = initTc hsc_env pcs iNTERACTIVE $ do {
1058 -- Load the interface if necessary (a home module will certainly
1059 -- alraedy be loaded, but a package module might not be)
1060 iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1062 let { export_names = availsToNameSet export_avails ;
1063 export_avails = [ avail | (mn, avails) <- mi_exports iface,
1064 avail <- avails ] } ;
1066 all_names <- if exports_only then
1068 else case mi_globals iface of {
1070 return (get_locals rdr_env) ;
1072 Nothing -> do { addErr (noRdrEnvErr mod) ;
1073 return export_names } } ;
1074 -- Invariant; we only have (not exports_only)
1075 -- for a home module so it must already be in the HIT
1076 -- So the Nothing case is a bug
1078 env <- importSupportingDecls all_names ;
1079 setGblEnv env (mappM tcLookupGlobal (nameSetToList all_names))
1082 -- Grab all the things from the global env that are locally def'd
1083 get_locals rdr_env = mkNameSet [ gre_name gre
1084 | elts <- rdrEnvElts rdr_env,
1087 -- Make a set because a name is often in the envt in
1088 -- both qualified and unqualified forms
1090 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
1091 <+> quotes (ppr mod)
1095 %************************************************************************
1099 %************************************************************************
1103 = do { ghci_mode <- getGhciMode ;
1104 tcg_env <- getGblEnv ;
1106 mb_main_mod <- readMutVar v_MainModIs ;
1107 mb_main_fn <- readMutVar v_MainFunIs ;
1108 let { main_mod = case mb_main_mod of {
1109 Just mod -> mkModuleName mod ;
1110 Nothing -> mAIN_Name } ;
1111 main_fn = case mb_main_fn of {
1112 Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
1113 Nothing -> main_RDR_Unqual } } ;
1115 check_main ghci_mode tcg_env main_mod main_fn
1119 check_main ghci_mode tcg_env main_mod main_fn
1120 -- If we are in module Main, check that 'main' is defined.
1121 -- It may be imported from another module, in which case
1122 -- we have to drag in its.
1124 -- Also form the definition
1125 -- $main = runIO main
1126 -- so we need to slurp in runIO too.
1128 -- ToDo: We have to return the main_name separately, because it's a
1129 -- bona fide 'use', and should be recorded as such, but the others
1132 -- Blimey: a whole page of code to do this...
1134 | mod_name /= main_mod
1135 = return (tcg_env, emptyFVs)
1137 -- Check that 'main' is in scope
1138 -- It might be imported from another module!
1140 -- We use a guard for this (rather than letting lookupSrcName fail)
1141 -- because it's not an error in ghci)
1142 | not (main_fn `elemRdrEnv` rdr_env)
1143 = do { complain_no_main; return (tcg_env, emptyFVs) }
1145 | otherwise -- OK, so the appropriate 'main' is in scope
1147 = do { main_name <- lookupSrcName main_fn ;
1149 tcg_env <- importSupportingDecls (unitFV runIOName) ;
1151 addSrcLoc (getSrcLoc main_name) $
1152 addErrCtxt mainCtxt $
1153 setGblEnv tcg_env $ do {
1155 -- $main :: IO () = runIO main
1156 let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ;
1157 (main_expr, ty) <- tcInferRho rhs ;
1159 let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) ;
1160 main_bind = VarMonoBind dollar_main_id main_expr ;
1161 tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env
1162 `andMonoBinds` main_bind } } ;
1164 return (tcg_env', unitFV main_name)
1167 mod_name = moduleName (tcg_mod tcg_env)
1168 rdr_env = tcg_rdr_env tcg_env
1170 complain_no_main | ghci_mode == Interactive = return ()
1171 | otherwise = failWithTc noMainMsg
1172 -- In interactive mode, don't worry about the absence of 'main'
1173 -- In other modes, fail altogether, so that we don't go on
1174 -- and complain a second time when processing the export list.
1176 mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
1177 noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
1178 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
1182 %************************************************************************
1186 %************************************************************************
1189 rnDump :: SDoc -> TcRn m ()
1190 -- Dump, with a banner, if -ddump-rn
1191 rnDump doc = dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc)
1193 tcDump :: TcGblEnv -> TcRn m ()
1195 = do { dflags <- getDOpts ;
1197 -- Dump short output if -ddump-types or -ddump-tc
1198 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1199 (dumpTcRn short_dump) ;
1201 -- Dump bindings if -ddump-tc
1202 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1205 short_dump = pprTcGblEnv env
1206 full_dump = ppr (tcg_binds env)
1207 -- NB: foreign x-d's have undefined's in their types;
1208 -- hence can't show the tc_fords
1211 = do { dflags <- getDOpts ;
1212 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1213 (dumpTcRn (pprModGuts mod_guts)) ;
1215 -- Dump bindings if -ddump-tc
1216 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1218 full_dump = pprCoreBindings (mg_binds mod_guts)
1220 -- It's unpleasant having both pprModGuts and pprModDetails here
1221 pprTcGblEnv :: TcGblEnv -> SDoc
1222 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1223 tcg_insts = dfun_ids,
1225 tcg_imports = imports })
1226 = vcat [ ppr_types dfun_ids type_env
1227 , ppr_insts dfun_ids
1228 , vcat (map ppr rules)
1229 , ppr_gen_tycons (typeEnvTyCons type_env)
1230 , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports))
1231 , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1233 pprModGuts :: ModGuts -> SDoc
1234 pprModGuts (ModGuts { mg_types = type_env,
1236 = vcat [ ppr_types [] type_env,
1240 ppr_types :: [Var] -> TypeEnv -> SDoc
1241 ppr_types dfun_ids type_env
1242 = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1244 ids = [id | id <- typeEnvIds type_env, want_sig id]
1245 want_sig id | opt_PprStyle_Debug = True
1246 | otherwise = isLocalId id &&
1247 isExternalName (idName id) &&
1248 not (id `elem` dfun_ids)
1249 -- isLocalId ignores data constructors, records selectors etc.
1250 -- The isExternalName ignores local dictionary and method bindings
1251 -- that the type checker has invented. Top-level user-defined things
1252 -- have External names.
1254 ppr_insts :: [Var] -> SDoc
1255 ppr_insts [] = empty
1256 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1258 ppr_sigs :: [Var] -> SDoc
1260 -- Print type signatures
1261 -- Convert to HsType so that we get source-language style printing
1262 -- And sort by RdrName
1263 = vcat $ map ppr_sig $ sortLt lt_sig $
1264 [ (getRdrName id, toHsType (tidyTopType (idType id)))
1267 lt_sig (n1,_) (n2,_) = n1 < n2
1268 ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t
1271 ppr_rules :: [IdCoreRule] -> SDoc
1272 ppr_rules [] = empty
1273 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1274 nest 4 (pprIdRules rs),
1277 ppr_gen_tycons [] = empty
1278 ppr_gen_tycons tcs = vcat [ptext SLIT("Generic type constructor details:"),
1279 nest 2 (vcat (map ppr_gen_tycon tcs))
1282 -- x&y are now Id's, not CoreExpr's
1284 | Just ep <- tyConGenInfo tycon
1285 = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
1287 | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
1290 = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
1291 ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
1292 ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to))
1295 (_,from_tau) = tcSplitForAllTys (idType from)