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 HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..),
25 Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..),
26 HsGroup(..), SpliceDecl(..),
27 mkSimpleMatch, placeHolderType, toHsType, andMonoBinds,
28 isSrcRule, collectStmtsBinders
30 import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr,
31 emptyGroup, mkGroup, findSplice, addImpDecls, main_RDR_Unqual )
33 import PrelNames ( iNTERACTIVE, ioTyConName, printName,
34 returnIOName, bindIOName, failIOName, thenIOName, runIOName,
35 dollarMainName, itName, mAIN_Name
37 import MkId ( unsafeCoerceId )
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 )
50 import TcMType ( newTyVarTy, zonkTcType )
51 import TcType ( Type, liftedTypeKind,
52 tyVarsOfType, tcFunResultTy,
53 mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
55 import TcMatches ( tcStmtsAndThen )
56 import Inst ( showLIE )
57 import TcBinds ( tcTopBinds )
58 import TcClassDcl ( tcClassDecls2 )
59 import TcDefaults ( tcDefaults )
60 import TcEnv ( tcExtendGlobalValEnv,
61 tcExtendInstEnv, tcExtendRules,
62 tcLookupTyCon, tcLookupGlobal,
65 import TcRules ( tcRules )
66 import TcForeign ( tcForeignImports, tcForeignExports )
67 import TcIfaceSig ( tcInterfaceSigs, tcCoreBinds )
68 import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls, tcInstDecls2 )
69 import TcSimplify ( tcSimplifyTop, tcSimplifyInfer )
70 import TcTyClsDecls ( tcTyAndClassDecls )
72 import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
74 import RnIfaces ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate )
75 import RnHiFiles ( readIface, loadOldIface )
76 import RnEnv ( lookupSrcName, lookupOccRn, plusGlobalRdrEnv,
77 ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs )
78 import RnExpr ( rnStmts, rnExpr )
79 import RnSource ( rnSrcDecls, checkModDeprec, rnStats )
81 import CoreUnfold ( unfoldingTemplate )
82 import CoreSyn ( IdCoreRule, Bind(..) )
83 import PprCore ( pprIdRules, pprCoreBindings )
84 import TysWiredIn ( mkListTy, unitTy )
85 import ErrUtils ( mkDumpDoc, showPass, pprBagOfErrors )
86 import Id ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported )
87 import IdInfo ( GlobalIdDetails(..) )
88 import Var ( Var, setGlobalIdDetails )
89 import Module ( Module, moduleName, moduleUserString, moduleEnvElts )
90 import Name ( Name, isExternalName, getSrcLoc, nameOccName )
91 import NameEnv ( delListFromNameEnv )
93 import TyCon ( tyConGenInfo )
94 import BasicTypes ( EP(..), RecFlag(..) )
95 import SrcLoc ( noSrcLoc )
97 import HscTypes ( PersistentCompilerState(..), InteractiveContext(..),
98 ModIface, ModDetails(..), ModGuts(..),
100 ModIface(..), ModDetails(..), IfaceDecls(..),
101 GhciMode(..), noDependencies,
102 Deprecations(..), plusDeprecs,
104 GenAvailInfo(Avail), availsToNameSet,
106 TypeEnv, TyThing, typeEnvTyCons,
107 extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
108 extendLocalRdrEnv, emptyFixityEnv
111 import RdrName ( rdrEnvElts )
112 import RnHiFiles ( loadInterface )
113 import RnEnv ( mkGlobalRdrEnv )
114 import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(..),
118 import Panic ( showException )
119 import List ( partition )
120 import Util ( sortLt )
125 %************************************************************************
127 Typecheck and rename a module
129 %************************************************************************
133 tcRnModule :: HscEnv -> PersistentCompilerState
135 -> IO (PersistentCompilerState, Maybe TcGblEnv)
137 tcRnModule hsc_env pcs
138 (HsModule this_mod _ exports import_decls local_decls mod_deprec loc)
139 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
141 initTc hsc_env pcs this_mod $ addSrcLoc loc $
142 do { -- Deal with imports; sets tcg_rdr_env, tcg_imports
143 (rdr_env, imports) <- rnImports import_decls ;
144 updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
145 tcg_imports = tcg_imports gbl `plusImportAvails` imports })
147 traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
148 -- Fail if there are any errors so far
149 -- The error printing (if needed) takes advantage
150 -- of the tcg_env we have now set
153 traceRn (text "rn1a") ;
154 -- Rename and type check the declarations
155 (tcg_env, src_dus) <- tcRnSrcDecls local_decls ;
156 setGblEnv tcg_env $ do {
158 traceRn (text "rn3") ;
159 -- Check whether the entire module is deprecated
160 -- This happens only once per module
161 -- Returns the full new deprecations; a module deprecation
162 -- over-rides the earlier ones
163 let { mod_deprecs = checkModDeprec mod_deprec } ;
164 updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` mod_deprecs })
167 -- Process the export list
168 export_avails <- exportsFromAvail exports ;
169 updGblEnv (\gbl -> gbl { tcg_exports = export_avails })
172 -- Get any supporting decls for the exports that have not already
173 -- been sucked in for the declarations in the body of the module.
174 -- (This can happen if something is imported only to be re-exported.)
176 -- Importing these supporting declarations is required
177 -- *only* to gether usage information
178 -- (see comments with MkIface.mkImportInfo for why)
179 -- For OneShot compilation we could just throw away the decls
180 -- but for Batch or Interactive we must put them in the type
181 -- envt because they've been removed from the holding pen
182 let { export_fvs = availsToNameSet export_avails } ;
183 tcg_env <- importSupportingDecls export_fvs ;
184 setGblEnv tcg_env $ do {
186 -- Report unused names
187 let { all_dus = src_dus `plusDU` usesOnly export_fvs } ;
188 reportUnusedNames tcg_env all_dus ;
190 -- Dump output and return
197 %*********************************************************
199 \subsection{Closing up the interface decls}
201 %*********************************************************
203 Suppose we discover we don't need to recompile. Then we start from the
204 IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need.
208 -> PersistentCompilerState
209 -> ModIface -- Get the decls from here
210 -> IO (PersistentCompilerState, Maybe ModDetails)
211 -- Nothing <=> errors happened
212 tcRnIface hsc_env pcs
213 (ModIface {mi_module = mod, mi_decls = iface_decls})
214 = initTc hsc_env pcs mod $ do {
216 -- Get the supporting decls, and typecheck them all together
217 -- so that any mutually recursive types are done right
218 extra_decls <- slurpImpDecls needed ;
219 env <- typecheckIfaceDecls (group `addImpDecls` extra_decls) ;
221 returnM (ModDetails { md_types = tcg_type_env env,
222 md_insts = tcg_insts env,
223 md_rules = hsCoreRules (tcg_rules env)
224 -- All the rules from an interface are of the IfaceRuleOut form
227 rule_decls = dcl_rules iface_decls
228 inst_decls = dcl_insts iface_decls
229 tycl_decls = dcl_tycl iface_decls
230 group = emptyGroup { hs_ruleds = rule_decls,
231 hs_instds = inst_decls,
232 hs_tyclds = tycl_decls }
233 needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets`
234 unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets`
235 unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets`
237 -- Data type decls with record selectors,
238 -- which may appear in the decls, need unpackCString
239 -- and friends. It's easier to just grab them right now.
241 hsCoreRules :: [TypecheckedRuleDecl] -> [IdCoreRule]
242 -- All post-typechecking Iface rules have the form IfaceRuleOut
243 hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules]
247 %************************************************************************
249 The interactive interface
251 %************************************************************************
254 tcRnStmt :: HscEnv -> PersistentCompilerState
255 -> InteractiveContext
257 -> IO (PersistentCompilerState,
258 Maybe (InteractiveContext, [Name], TypecheckedHsExpr))
259 -- The returned [Name] is the same as the input except for
260 -- ExprStmt, in which case the returned [Name] is [itName]
262 -- The returned TypecheckedHsExpr is of type IO [ () ],
263 -- a list of the bound values, coerced to ().
265 tcRnStmt hsc_env pcs ictxt rdr_stmt
266 = initTc hsc_env pcs iNTERACTIVE $
267 setInteractiveContext ictxt $ do {
269 -- Rename; use CmdLineMode because tcRnStmt is only used interactively
270 ([rn_stmt], fvs) <- initRnInteractive ictxt
271 (rnStmts DoExpr [rdr_stmt]) ;
272 traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
275 -- Suck in the supporting declarations and typecheck them
276 tcg_env <- importSupportingDecls (fvs `plusFV` implicitStmtFVs fvs) ;
277 -- NB: an earlier version deleted (rdrEnvElts local_env) from
278 -- the fvs. But (a) that isn't necessary, because previously
279 -- bound things in the local_env will be in the TypeEnv, and
280 -- the renamer doesn't re-slurp such things, and
281 -- (b) it's WRONG to delete them. Consider in GHCi:
282 -- Mod> let x = e :: T
283 -- Mod> let y = x + 3
284 -- We need to pass 'x' among the fvs to slurpImpDecls, so that
285 -- the latter can see that T is a gate, and hence import the Num T
286 -- instance decl. (See the InTypEnv case in RnIfaces.slurpSourceRefs.)
287 setGblEnv tcg_env $ do {
289 -- The real work is done here
290 ((bound_ids, tc_expr), lie) <- getLIE (tcUserStmt rn_stmt) ;
292 traceTc (text "tcs 1") ;
293 let { -- Make all the bound ids "global" ids, now that
294 -- they're notionally top-level bindings. This is
295 -- important: otherwise when we come to compile an expression
296 -- using these ids later, the byte code generator will consider
297 -- the occurrences to be free rather than global.
298 global_ids = map globaliseId bound_ids ;
299 globaliseId id = setGlobalIdDetails id VanillaGlobal ;
301 -- Update the interactive context
302 rn_env = ic_rn_local_env ictxt ;
303 type_env = ic_type_env ictxt ;
305 bound_names = map idName global_ids ;
306 new_rn_env = extendLocalRdrEnv rn_env bound_names ;
308 -- Remove any shadowed bindings from the type_env;
309 -- they are inaccessible but might, I suppose, cause
310 -- a space leak if we leave them there
311 shadowed = [ n | name <- bound_names,
312 let rdr_name = mkRdrUnqual (nameOccName name),
313 Just n <- [lookupRdrEnv rn_env rdr_name] ] ;
315 filtered_type_env = delListFromNameEnv type_env shadowed ;
316 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
318 new_ic = ictxt { ic_rn_local_env = new_rn_env,
319 ic_type_env = new_type_env }
322 dumpOptTcRn Opt_D_dump_tc
323 (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
324 text "Typechecked expr" <+> ppr tc_expr]) ;
326 returnM (new_ic, bound_names, tc_expr)
331 Here is the grand plan, implemented in tcUserStmt
333 What you type The IO [HValue] that hscStmt returns
334 ------------- ------------------------------------
335 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
338 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
341 expr (of IO type) ==> expr >>= \ v -> return [coerce HVal v]
342 [NB: result not printed] bindings: [it]
344 expr (of non-IO type, ==> let v = expr in print v >> return [coerce HVal v]
345 result showable) bindings: [it]
347 expr (of non-IO type,
348 result not showable) ==> error
352 ---------------------------
353 tcUserStmt :: RenamedStmt -> TcM ([Id], TypecheckedHsExpr)
354 tcUserStmt (ExprStmt expr _ loc)
355 = newUnique `thenM` \ uniq ->
357 fresh_it = itName uniq
358 the_bind = FunMonoBind fresh_it False
359 [ mkSimpleMatch [] expr placeHolderType loc ] loc
361 tryTcLIE_ (do { -- Try this if the other fails
362 traceTc (text "tcs 1b") ;
364 LetStmt (MonoBind the_bind [] NonRecursive),
365 ExprStmt (HsApp (HsVar printName) (HsVar fresh_it))
366 placeHolderType loc] })
367 (do { -- Try this first
368 traceTc (text "tcs 1a") ;
369 tc_stmts [BindStmt (VarPat fresh_it) expr loc] })
371 tcUserStmt stmt = tc_stmts [stmt]
373 ---------------------------
375 = do { io_ids <- mappM tcLookupId
376 [returnIOName, failIOName, bindIOName, thenIOName] ;
377 ioTyCon <- tcLookupTyCon ioTyConName ;
378 res_ty <- newTyVarTy liftedTypeKind ;
380 names = collectStmtsBinders stmts ;
381 return_id = head io_ids ; -- Rather gruesome
383 io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty) ;
385 -- mk_return builds the expression
386 -- returnIO @ [()] [coerce () x, .., coerce () z]
387 mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy])
388 (ExplicitList unitTy (map mk_item ids)) ;
390 mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
393 -- OK, we're ready to typecheck the stmts
394 traceTc (text "tcs 2") ;
395 ((ids, tc_stmts), lie) <-
396 getLIE $ tcStmtsAndThen combine DoExpr io_ty stmts $
398 -- Look up the names right in the middle,
399 -- where they will all be in scope
400 ids <- mappM tcLookupId names ;
401 return (ids, [ResultStmt (mk_return ids) noSrcLoc])
404 -- Simplify the context right here, so that we fail
405 -- if there aren't enough instances. Notably, when we see
407 -- we use recoverTc_ to try it <- e
408 -- and then let it = e
409 -- It's the simplify step that rejects the first.
410 traceTc (text "tcs 3") ;
411 const_binds <- tcSimplifyTop lie ;
413 -- Build result expression and zonk it
414 let { expr = mkHsLet const_binds $
415 HsDo DoExpr tc_stmts io_ids
416 (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc } ;
417 zonked_expr <- zonkTopExpr expr ;
418 zonked_ids <- zonkTopBndrs ids ;
420 return (zonked_ids, zonked_expr)
423 combine stmt (ids, stmts) = (ids, stmt:stmts)
427 tcRnExpr just finds the type of an expression
430 tcRnExpr :: HscEnv -> PersistentCompilerState
431 -> InteractiveContext
433 -> IO (PersistentCompilerState, Maybe Type)
434 tcRnExpr hsc_env pcs ictxt rdr_expr
435 = initTc hsc_env pcs iNTERACTIVE $
436 setInteractiveContext ictxt $ do {
438 (rn_expr, fvs) <- initRnInteractive ictxt (rnExpr rdr_expr) ;
441 -- Suck in the supporting declarations and typecheck them
442 tcg_env <- importSupportingDecls (fvs `plusFV` ubiquitousNames) ;
443 setGblEnv tcg_env $ do {
445 -- Now typecheck the expression;
446 -- it might have a rank-2 type (e.g. :t runST)
447 ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
448 ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
449 tcSimplifyTop lie_top ;
451 let { all_expr_ty = mkForAllTys qtvs $
452 mkFunTys (map idType dict_ids) $
454 zonkTcType all_expr_ty
457 smpl_doc = ptext SLIT("main expression")
462 tcRnThing :: HscEnv -> PersistentCompilerState
463 -> InteractiveContext
465 -> IO (PersistentCompilerState, Maybe [TyThing])
466 -- Look up a RdrName and return all the TyThings it might be
467 -- We treat a capitalised RdrName as both a data constructor
468 -- and as a type or class constructor; hence we return up to two results
469 tcRnThing hsc_env pcs ictxt rdr_name
470 = initTc hsc_env pcs iNTERACTIVE $
471 setInteractiveContext ictxt $ do {
473 -- If the identifier is a constructor (begins with an
474 -- upper-case letter), then we need to consider both
475 -- constructor and type class identifiers.
476 let { rdr_names = dataTcOccs rdr_name } ;
478 -- results :: [(Messages, Maybe Name)]
479 results <- initRnInteractive ictxt
480 (mapM (tryTc . lookupOccRn) rdr_names) ;
482 -- The successful lookups will be (Just name)
483 let { (warns_s, good_names) = unzip [ (msgs, name)
484 | (msgs, Just name) <- results] ;
485 errs_s = [msgs | (msgs, Nothing) <- results] } ;
487 -- Fail if nothing good happened, else add warnings
488 if null good_names then -- Fail
489 do { addMessages (head errs_s) ; failM }
490 else -- Add deprecation warnings
491 mapM_ addMessages warns_s ;
493 -- Slurp in the supporting declarations
494 tcg_env <- importSupportingDecls (mkFVs good_names) ;
495 setGblEnv tcg_env $ do {
497 -- And lookup up the entities
498 mapM tcLookupGlobal good_names
504 setInteractiveContext :: InteractiveContext -> TcRn m a -> TcRn m a
505 setInteractiveContext icxt thing_inside
506 = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_`
507 updGblEnv (\ env -> env { tcg_rdr_env = ic_rn_gbl_env icxt,
508 tcg_type_env = ic_type_env icxt })
511 initRnInteractive :: InteractiveContext -> RnM a -> TcM a
512 -- Set the local RdrEnv from the interactive context
513 initRnInteractive ictxt rn_thing
514 = initRn CmdLineMode $
515 setLocalRdrEnv (ic_rn_local_env ictxt) $
519 %************************************************************************
521 Type-checking external-core modules
523 %************************************************************************
526 tcRnExtCore :: HscEnv -> PersistentCompilerState
528 -> IO (PersistentCompilerState, Maybe ModGuts)
529 -- Nothing => some error occurred
531 tcRnExtCore hsc_env pcs
532 (HsModule this_mod _ _ _ local_decls _ loc)
533 -- Rename the (Core) module. It's a bit like an interface
534 -- file: all names are original names
535 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
537 initTc hsc_env pcs this_mod $ addSrcLoc loc $ do {
539 -- Rename the source, only in interface mode.
540 -- rnSrcDecls handles fixity decls etc too, which won't occur
541 -- but that doesn't matter
542 let { local_group = mkGroup local_decls } ;
543 (_, rn_local_decls, dus) <- initRn (InterfaceMode this_mod)
544 (rnSrcDecls local_group) ;
547 -- Get the supporting decls
548 rn_imp_decls <- slurpImpDecls (duUses dus) ;
549 let { rn_decls = rn_local_decls `addImpDecls` rn_imp_decls } ;
551 -- Dump trace of renaming part
552 rnDump (ppr rn_decls) ;
553 rnStats rn_imp_decls ;
555 -- Typecheck them all together so that
556 -- any mutually recursive types are done right
557 tcg_env <- typecheckIfaceDecls rn_decls ;
558 setGblEnv tcg_env $ do {
560 -- Now the core bindings
561 core_prs <- tcCoreBinds (hs_coreds rn_local_decls) ;
562 tcExtendGlobalValEnv (map fst core_prs) $ do {
566 bndrs = map fst core_prs ;
567 my_exports = map (Avail . idName) bndrs ;
568 -- ToDo: export the data types also?
570 final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
572 mod_guts = ModGuts { mg_module = this_mod,
573 mg_usages = [], -- ToDo: compute usage
574 mg_dir_imps = [], -- ??
575 mg_deps = noDependencies, -- ??
576 mg_exports = my_exports,
577 mg_types = final_type_env,
578 mg_insts = tcg_insts tcg_env,
579 mg_rules = hsCoreRules (tcg_rules tcg_env),
580 mg_binds = [Rec core_prs],
583 mg_rdr_env = emptyGlobalRdrEnv,
584 mg_fix_env = emptyFixityEnv,
585 mg_deprecs = NoDeprecs,
589 tcCoreDump mod_guts ;
596 %************************************************************************
598 Type-checking the top level of a module
600 %************************************************************************
603 tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, DefUses)
604 -- Returns the variables free in the decls
605 -- Reason: solely to report unused imports and bindings
607 = do { -- Do all the declarations
608 ((tc_envs, dus), lie) <- getLIE (tc_rn_src_decls decls) ;
610 -- tcSimplifyTop deals with constant or ambiguous InstIds.
611 -- How could there be ambiguous ones? They can only arise if a
612 -- top-level decl falls under the monomorphism
613 -- restriction, and no subsequent decl instantiates its
614 -- type. (Usually, ambiguous type variables are resolved
615 -- during the generalisation step.)
616 traceTc (text "Tc8") ;
617 setEnvs tc_envs $ do {
618 -- Setting the global env exposes the instances to tcSimplifyTop
619 -- Setting the local env exposes the local Ids, so that
620 -- we get better error messages (monomorphism restriction)
621 inst_binds <- tcSimplifyTop lie ;
623 -- Backsubstitution. This must be done last.
624 -- Even tcSimplifyTop may do some unification.
625 traceTc (text "Tc9") ;
626 let { (tcg_env, _) = tc_envs ;
627 TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
628 tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
630 (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
633 return (tcg_env { tcg_type_env = extendTypeEnvWithIds type_env bind_ids,
634 tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' },
638 tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), DefUses)
641 = do { let { (first_group, group_tail) = findSplice ds } ;
642 -- If ds is [] we get ([], Nothing)
644 -- Type check the decls up to, but not including, the first splice
645 (tc_envs@(_,tcl_env), src_dus1) <- tcRnGroup first_group ;
647 -- Bale out if errors; for example, error recovery when checking
648 -- the RHS of 'main' can mean that 'main' is not in the envt for
649 -- the subsequent checkMain test
654 -- If there is no splice, we're nearlydone
656 Nothing -> do { -- Last thing: check for `main'
657 (tcg_env, main_fvs) <- checkMain ;
658 return ((tcg_env, tcl_env),
659 src_dus1 `plusDU` usesOnly main_fvs)
662 -- If there's a splice, we must carry on
663 Just (SpliceDecl splice_expr splice_loc, rest_ds) -> do {
665 failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
668 -- Rename the splice expression, and get its supporting decls
669 (rn_splice_expr, splice_fvs) <- initRn SourceMode $
670 addSrcLoc splice_loc $
672 tcg_env <- importSupportingDecls (splice_fvs `plusFV` templateHaskellNames) ;
673 setGblEnv tcg_env $ do {
675 -- Execute the splice
676 spliced_decls <- tcSpliceDecls rn_splice_expr ;
678 -- Glue them on the front of the remaining decls and loop
679 (tc_envs, src_dus2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ;
681 return (tc_envs, src_dus1 `plusDU` usesOnly splice_fvs `plusDU` src_dus2)
688 %************************************************************************
690 Type-checking the top level of a module
692 %************************************************************************
694 tcRnGroup takes a bunch of top-level source-code declarations, and
696 * gets supporting declarations from interface files
699 * and augments the TcGblEnv with the results
701 In Template Haskell it may be called repeatedly for each group of
702 declarations. It expects there to be an incoming TcGblEnv in the
703 monad; it augments it and returns the new TcGblEnv.
706 tcRnGroup :: HsGroup RdrName -> TcM ((TcGblEnv, TcLclEnv), DefUses)
707 -- Returns the variables free in the decls, for unused-binding reporting
709 = do { -- Rename the declarations
710 (tcg_env, rn_decls, src_dus) <- rnTopSrcDecls decls ;
711 setGblEnv tcg_env $ do {
713 -- Typecheck the declarations
714 tc_envs <- tcTopSrcDecls rn_decls ;
716 return (tc_envs, src_dus)
719 ------------------------------------------------
720 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, DefUses)
722 = do { -- Bring top level binders into scope
723 (rdr_env, imports) <- importsFromLocalDecls group ;
724 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv`
726 tcg_imports = imports `plusImportAvails`
730 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
732 -- Rename the source decls
733 (tcg_env, rn_src_decls, src_dus) <- initRn SourceMode (rnSrcDecls group) ;
734 setGblEnv tcg_env $ do {
738 -- Import consquential imports
739 let { src_fvs = duUses src_dus } ;
740 rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ;
741 let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ;
743 -- Dump trace of renaming part
744 rnDump (ppr rn_decls) ;
745 rnStats rn_imp_decls ;
747 return (tcg_env, rn_decls, src_dus)
750 ------------------------------------------------
751 tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
753 (HsGroup { hs_tyclds = tycl_decls,
754 hs_instds = inst_decls,
755 hs_fords = foreign_decls,
756 hs_defds = default_decls,
757 hs_ruleds = rule_decls,
758 hs_valds = val_binds })
759 = do { -- Type-check the type and class decls, and all imported decls
760 -- The latter come in via tycl_decls
761 traceTc (text "Tc2") ;
762 tcg_env <- tcTyClDecls tycl_decls ;
763 setGblEnv tcg_env $ do {
765 -- Source-language instances, including derivings,
766 -- and import the supporting declarations
767 traceTc (text "Tc3") ;
768 (tcg_env, inst_infos, deriv_binds, fvs) <- tcInstDecls1 tycl_decls inst_decls ;
769 setGblEnv tcg_env $ do {
770 tcg_env <- importSupportingDecls fvs ;
771 setGblEnv tcg_env $ do {
773 -- Foreign import declarations next. No zonking necessary
774 -- here; we can tuck them straight into the global environment.
775 traceTc (text "Tc4") ;
776 (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
777 tcExtendGlobalValEnv fi_ids $
778 updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls })
781 -- Default declarations
782 traceTc (text "Tc4a") ;
783 default_tys <- tcDefaults default_decls ;
784 updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
786 -- Value declarations next
787 -- We also typecheck any extra binds that came out
788 -- of the "deriving" process
789 traceTc (text "Tc5") ;
790 (tc_val_binds, lcl_env) <- tcTopBinds (val_binds `ThenBinds` deriv_binds) ;
791 setLclTypeEnv lcl_env $ do {
793 -- Second pass over class and instance declarations,
794 -- plus rules and foreign exports, to generate bindings
795 traceTc (text "Tc6") ;
796 (cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ;
797 tcExtendGlobalValEnv dm_ids $ do {
798 inst_binds <- tcInstDecls2 inst_infos ;
799 showLIE (text "after instDecls2") ;
802 -- They need to be zonked, so we return them
803 traceTc (text "Tc7") ;
804 (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
807 -- Need to partition them because the source rules
808 -- must be zonked before adding them to tcg_rules
809 -- NB: built-in rules come in as IfaceRuleOut's, and
810 -- get added to tcg_rules right here by tcExtendRules
811 rules <- tcRules rule_decls ;
812 let { (src_rules, iface_rules) = partition isSrcRule rules } ;
813 tcExtendRules iface_rules $ do {
816 tcg_env <- getGblEnv ;
817 let { all_binds = tc_val_binds `AndMonoBinds`
818 inst_binds `AndMonoBinds`
819 cls_dm_binds `AndMonoBinds`
822 -- Extend the GblEnv with the (as yet un-zonked)
823 -- bindings, rules, foreign decls
824 tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `andMonoBinds` all_binds,
825 tcg_rules = tcg_rules tcg_env ++ src_rules,
826 tcg_fords = tcg_fords tcg_env ++ foe_decls } } ;
828 return (tcg_env', lcl_env)
833 tcTyClDecls :: [RenamedTyClDecl]
836 -- tcTyClDecls deals with
837 -- type and class decls (some source, some imported)
838 -- interface signatures (checked lazily)
840 -- It returns the TcGblEnv for this module, and side-effects the
841 -- persistent compiler state to reflect the things imported from
844 tcTyClDecls tycl_decls
846 -- tcTyAndClassDecls recovers internally, but if anything gave rise to
847 -- an error we'd better stop now, to avoid a cascade
849 traceTc (text "TyCl1") `thenM_`
850 tcTyAndClassDecls tycl_decls `thenM` \ tcg_env ->
851 -- Returns the extended environment
854 traceTc (text "TyCl2") `thenM_`
855 tcInterfaceSigs tycl_decls `thenM` \ tcg_env ->
856 -- Returns the extended environment
863 %************************************************************************
865 Load the old interface file for this module (unless
866 we have it aleady), and check whether it is up to date
869 %************************************************************************
872 checkOldIface :: HscEnv
873 -> PersistentCompilerState
875 -> FilePath -- Where the interface file is
876 -> Bool -- Source unchanged
877 -> Maybe ModIface -- Old interface from compilation manager, if any
878 -> IO (PersistentCompilerState, Maybe (RecompileRequired, Maybe ModIface))
879 -- Nothing <=> errors happened
881 checkOldIface hsc_env pcs mod iface_path source_unchanged maybe_iface
882 = do { showPass (hsc_dflags hsc_env)
883 ("Checking old interface for " ++ moduleUserString mod) ;
885 initTc hsc_env pcs mod
886 (check_old_iface iface_path source_unchanged maybe_iface)
889 check_old_iface iface_path source_unchanged maybe_iface
890 = -- CHECK WHETHER THE SOURCE HAS CHANGED
891 ifM (not source_unchanged)
892 (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
895 -- If the source has changed and we're in interactive mode, avoid reading
896 -- an interface; just return the one we might have been supplied with.
897 getGhciMode `thenM` \ ghci_mode ->
898 if (ghci_mode == Interactive) && not source_unchanged then
899 returnM (outOfDate, maybe_iface)
902 case maybe_iface of {
903 Just old_iface -> -- Use the one we already have
904 checkVersions source_unchanged old_iface `thenM` \ recomp ->
905 returnM (recomp, Just old_iface)
909 -- Try and read the old interface for the current module
910 -- from the .hi file left from the last time we compiled it
911 getModule `thenM` \ this_mod ->
912 readIface this_mod iface_path False `thenM` \ read_result ->
913 case read_result of {
914 Left err -> -- Old interface file not found, or garbled; give up
915 traceHiDiffs (text "FYI: cannot read old interface file:"
916 $$ nest 4 (text (showException err))) `thenM_`
917 returnM (outOfDate, Nothing)
919 ; Right parsed_iface ->
921 -- We found the file and parsed it; now load it
922 tryTc (initRn (InterfaceMode this_mod)
923 (loadOldIface parsed_iface)) `thenM` \ ((_,errs), mb_iface) ->
925 Nothing -> -- Something went wrong in loading. The main likely thing
926 -- is that the usages mentioned B.f, where B.hi and B.hs no
927 -- longer exist. Then newGlobalName2 fails with an error message
928 -- This isn't an error; we just don't have an old iface file to
929 -- look at. Spit out a traceHiDiffs for info though.
930 traceHiDiffs (text "FYI: loading old interface file failed"
931 $$ nest 4 (docToSDoc (pprBagOfErrors errs))) `thenM_`
932 return (outOfDate, Nothing)
936 -- At last, we have got the old iface; check its versions
937 checkVersions source_unchanged iface `thenM` \ recomp ->
938 returnM (recomp, Just iface)
943 %************************************************************************
945 Type-check and rename supporting declarations
946 This is used to deal with the free vars of a splice,
947 or derived code: slurp in the necessary declarations,
948 typecheck them, and add them to the EPS
950 %************************************************************************
953 importSupportingDecls :: FreeVars -> TcM TcGblEnv
954 -- Completely deal with the supporting imports needed
955 -- by the specified free-var set
956 importSupportingDecls fvs
957 = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ;
958 decls <- slurpImpDecls fvs ;
959 traceRn (text "...namely:" <+> vcat (map ppr decls)) ;
960 typecheckIfaceDecls (mkGroup decls) }
962 typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv
963 -- The decls are all interface-file declarations
964 -- Usually they are all from other modules, but when we are reading
965 -- this module's interface from a file, it's possible that some of
966 -- them are for the module being compiled.
967 -- That is why the tcExtendX functions need to do partitioning.
969 -- If all the decls are from other modules, the returned TcGblEnv
970 -- will have an empty tc_genv, but its tc_inst_env
971 -- cache may have been augmented.
972 typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls,
973 hs_instds = inst_decls,
974 hs_ruleds = rule_decls })
975 = do { -- Typecheck the type, class, and interface-sig decls
976 tcg_env <- tcTyClDecls tycl_decls ;
977 setGblEnv tcg_env $ do {
979 -- Typecheck the instance decls, and rules
980 -- Note that imported dictionary functions are already
981 -- in scope from the preceding tcTyClDecls
982 tcIfaceInstDecls inst_decls `thenM` \ dfuns ->
983 tcExtendInstEnv dfuns $
984 tcRules rule_decls `thenM` \ rules ->
985 tcExtendRules rules $
987 getGblEnv -- Return the environment
993 %*********************************************************
995 mkGlobalContext: make up an interactive context
997 Used for initialising the lexical environment
998 of the interactive read-eval-print loop
1000 %*********************************************************
1005 :: HscEnv -> PersistentCompilerState
1006 -> [Module] -- Expose these modules' top-level scope
1007 -> [Module] -- Expose these modules' exports only
1008 -> IO (PersistentCompilerState, Maybe GlobalRdrEnv)
1010 mkGlobalContext hsc_env pcs toplevs exports
1011 = initTc hsc_env pcs iNTERACTIVE $ do {
1013 toplev_envs <- mappM getTopLevScope toplevs ;
1014 export_envs <- mappM getModuleExports exports ;
1015 returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv
1016 (toplev_envs ++ export_envs))
1019 getTopLevScope :: Module -> TcRn m GlobalRdrEnv
1021 = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1022 case mi_globals iface of
1023 Nothing -> panic "getTopLevScope"
1024 Just env -> returnM env }
1026 getModuleExports :: Module -> TcRn m GlobalRdrEnv
1027 getModuleExports mod
1028 = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1029 returnM (foldl add emptyGlobalRdrEnv (mi_exports iface)) }
1031 prov_fn n = NonLocalDef ImplicitImport
1032 add env (mod,avails)
1033 = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs)
1035 contextDoc = text "context for compiling statements"
1041 -> PersistentCompilerState -- IN: persistent compiler state
1042 -> Module -- module to inspect
1043 -> Bool -- grab just the exports, or the whole toplev
1044 -> IO (PersistentCompilerState, Maybe [TyThing])
1046 getModuleContents hsc_env pcs mod exports_only
1047 = initTc hsc_env pcs iNTERACTIVE $ do {
1049 -- Load the interface if necessary (a home module will certainly
1050 -- alraedy be loaded, but a package module might not be)
1051 iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1053 let { export_names = availsToNameSet export_avails ;
1054 export_avails = [ avail | (mn, avails) <- mi_exports iface,
1055 avail <- avails ] } ;
1057 all_names <- if exports_only then
1059 else case mi_globals iface of {
1061 return (get_locals rdr_env) ;
1063 Nothing -> do { addErr (noRdrEnvErr mod) ;
1064 return export_names } } ;
1065 -- Invariant; we only have (not exports_only)
1066 -- for a home module so it must already be in the HIT
1067 -- So the Nothing case is a bug
1069 env <- importSupportingDecls all_names ;
1070 setGblEnv env (mappM tcLookupGlobal (nameSetToList all_names))
1073 -- Grab all the things from the global env that are locally def'd
1074 get_locals rdr_env = mkNameSet [ gre_name gre
1075 | elts <- rdrEnvElts rdr_env,
1078 -- Make a set because a name is often in the envt in
1079 -- both qualified and unqualified forms
1081 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
1082 <+> quotes (ppr mod)
1086 %************************************************************************
1090 %************************************************************************
1094 = do { ghci_mode <- getGhciMode ;
1095 tcg_env <- getGblEnv ;
1096 check_main ghci_mode tcg_env
1099 check_main ghci_mode tcg_env
1100 -- If we are in module Main, check that 'main' is defined.
1101 -- It may be imported from another module, in which case
1102 -- we have to drag in its.
1104 -- Also form the definition
1105 -- $main = runIO main
1106 -- so we need to slurp in runIO too.
1108 -- ToDo: We have to return the main_name separately, because it's a
1109 -- bona fide 'use', and should be recorded as such, but the others
1112 -- Blimey: a whole page of code to do this...
1114 | mod_name /= mAIN_Name
1115 = return (tcg_env, emptyFVs)
1117 -- Check that 'main' is in scope
1118 -- It might be imported from another module!
1120 -- We use a guard for this (rather than letting lookupSrcName fail)
1121 -- because it's not an error in ghci)
1122 | not (main_RDR_Unqual `elemRdrEnv` rdr_env)
1123 = do { complain_no_main; return (tcg_env, emptyFVs) }
1126 = do { main_name <- lookupSrcName main_RDR_Unqual ;
1128 tcg_env <- importSupportingDecls (unitFV runIOName) ;
1130 addSrcLoc (getSrcLoc main_name) $
1131 addErrCtxt mainCtxt $
1132 setGblEnv tcg_env $ do {
1134 -- $main :: IO () = runIO main
1135 let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ;
1136 (main_expr, ty) <- tcInferRho rhs ;
1138 let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) ;
1139 main_bind = VarMonoBind dollar_main_id main_expr ;
1140 tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env
1141 `andMonoBinds` main_bind } } ;
1143 return (tcg_env', unitFV main_name)
1146 mod_name = moduleName (tcg_mod tcg_env)
1147 rdr_env = tcg_rdr_env tcg_env
1149 complain_no_main | ghci_mode == Interactive = return ()
1150 | otherwise = failWithTc noMainMsg
1151 -- In interactive mode, don't worry about the absence of 'main'
1152 -- In other modes, fail altogether, so that we don't go on
1153 -- and complain a second time when processing the export list.
1155 mainCtxt = ptext SLIT("When checking the type of 'main'")
1156 noMainMsg = ptext SLIT("No 'main' defined in module Main")
1160 %************************************************************************
1164 %************************************************************************
1167 rnDump :: SDoc -> TcRn m ()
1168 -- Dump, with a banner, if -ddump-rn
1169 rnDump doc = dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc)
1171 tcDump :: TcGblEnv -> TcRn m ()
1173 = do { dflags <- getDOpts ;
1175 -- Dump short output if -ddump-types or -ddump-tc
1176 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1177 (dumpTcRn short_dump) ;
1179 -- Dump bindings if -ddump-tc
1180 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1183 short_dump = pprTcGblEnv env
1184 full_dump = ppr (tcg_binds env)
1185 -- NB: foreign x-d's have undefined's in their types;
1186 -- hence can't show the tc_fords
1189 = do { dflags <- getDOpts ;
1190 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1191 (dumpTcRn (pprModGuts mod_guts)) ;
1193 -- Dump bindings if -ddump-tc
1194 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1196 full_dump = pprCoreBindings (mg_binds mod_guts)
1198 -- It's unpleasant having both pprModGuts and pprModDetails here
1199 pprTcGblEnv :: TcGblEnv -> SDoc
1200 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1201 tcg_insts = dfun_ids,
1203 tcg_imports = imports })
1204 = vcat [ ppr_types dfun_ids type_env
1205 , ppr_insts dfun_ids
1206 , vcat (map ppr rules)
1207 , ppr_gen_tycons (typeEnvTyCons type_env)
1208 , ppr (moduleEnvElts (imp_dep_mods imports))
1209 , ppr (imp_dep_pkgs imports)]
1211 pprModGuts :: ModGuts -> SDoc
1212 pprModGuts (ModGuts { mg_types = type_env,
1214 = vcat [ ppr_types [] type_env,
1218 ppr_types :: [Var] -> TypeEnv -> SDoc
1219 ppr_types dfun_ids type_env
1220 = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1222 ids = [id | id <- typeEnvIds type_env, want_sig id]
1223 want_sig id | opt_PprStyle_Debug = True
1224 | otherwise = isLocalId id &&
1225 isExternalName (idName id) &&
1226 not (id `elem` dfun_ids)
1227 -- isLocalId ignores data constructors, records selectors etc.
1228 -- The isExternalName ignores local dictionary and method bindings
1229 -- that the type checker has invented. Top-level user-defined things
1230 -- have External names.
1232 ppr_insts :: [Var] -> SDoc
1233 ppr_insts [] = empty
1234 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1236 ppr_sigs :: [Var] -> SDoc
1238 -- Print type signatures
1239 -- Convert to HsType so that we get source-language style printing
1240 -- And sort by RdrName
1241 = vcat $ map ppr_sig $ sortLt lt_sig $
1242 [ (getRdrName id, toHsType (idType id))
1245 lt_sig (n1,_) (n2,_) = n1 < n2
1246 ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t
1249 ppr_rules :: [IdCoreRule] -> SDoc
1250 ppr_rules [] = empty
1251 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1252 nest 4 (pprIdRules rs),
1255 ppr_gen_tycons [] = empty
1256 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
1257 vcat (map ppr_gen_tycon tcs),
1261 -- x&y are now Id's, not CoreExpr's
1263 | Just ep <- tyConGenInfo tycon
1264 = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
1266 | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
1269 = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
1270 ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
1271 ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to))
1274 (_,from_tau) = tcSplitForAllTys (idType from)