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 )
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 ( tcExpr_id )
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,
73 reportUnusedNames, main_RDR_Unqual )
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 )
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 -- Hence the hole type (c.f. TcExpr.tcExpr_id)
448 ((tc_expr, res_ty), lie) <- getLIE (tcExpr_id rn_expr) ;
449 ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
450 tcSimplifyTop lie_top ;
452 let { all_expr_ty = mkForAllTys qtvs $
453 mkFunTys (map idType dict_ids) $
455 zonkTcType all_expr_ty
458 smpl_doc = ptext SLIT("main expression")
463 tcRnThing :: HscEnv -> PersistentCompilerState
464 -> InteractiveContext
466 -> IO (PersistentCompilerState, Maybe [TyThing])
467 -- Look up a RdrName and return all the TyThings it might be
468 -- We treat a capitalised RdrName as both a data constructor
469 -- and as a type or class constructor; hence we return up to two results
470 tcRnThing hsc_env pcs ictxt rdr_name
471 = initTc hsc_env pcs iNTERACTIVE $
472 setInteractiveContext ictxt $ do {
474 -- If the identifier is a constructor (begins with an
475 -- upper-case letter), then we need to consider both
476 -- constructor and type class identifiers.
477 let { rdr_names = dataTcOccs rdr_name } ;
479 -- results :: [(Messages, Maybe Name)]
480 results <- initRnInteractive ictxt
481 (mapM (tryTc . lookupOccRn) rdr_names) ;
483 -- The successful lookups will be (Just name)
484 let { (warns_s, good_names) = unzip [ (msgs, name)
485 | (msgs, Just name) <- results] ;
486 errs_s = [msgs | (msgs, Nothing) <- results] } ;
488 -- Fail if nothing good happened, else add warnings
489 if null good_names then -- Fail
490 do { addMessages (head errs_s) ; failM }
491 else -- Add deprecation warnings
492 mapM_ addMessages warns_s ;
494 -- Slurp in the supporting declarations
495 tcg_env <- importSupportingDecls (mkFVs good_names) ;
496 setGblEnv tcg_env $ do {
498 -- And lookup up the entities
499 mapM tcLookupGlobal good_names
505 setInteractiveContext :: InteractiveContext -> TcRn m a -> TcRn m a
506 setInteractiveContext icxt thing_inside
507 = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_`
508 updGblEnv (\ env -> env { tcg_rdr_env = ic_rn_gbl_env icxt,
509 tcg_type_env = ic_type_env icxt })
512 initRnInteractive :: InteractiveContext -> RnM a -> TcM a
513 -- Set the local RdrEnv from the interactive context
514 initRnInteractive ictxt rn_thing
515 = initRn CmdLineMode $
516 setLocalRdrEnv (ic_rn_local_env ictxt) $
520 %************************************************************************
522 Type-checking external-core modules
524 %************************************************************************
527 tcRnExtCore :: HscEnv -> PersistentCompilerState
529 -> IO (PersistentCompilerState, Maybe ModGuts)
530 -- Nothing => some error occurred
532 tcRnExtCore hsc_env pcs
533 (HsModule this_mod _ _ _ local_decls _ loc)
534 -- Rename the (Core) module. It's a bit like an interface
535 -- file: all names are original names
536 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
538 initTc hsc_env pcs this_mod $ addSrcLoc loc $ do {
540 -- Rename the source, only in interface mode.
541 -- rnSrcDecls handles fixity decls etc too, which won't occur
542 -- but that doesn't matter
543 let { local_group = mkGroup local_decls } ;
544 (_, rn_local_decls, dus) <- initRn (InterfaceMode this_mod)
545 (rnSrcDecls local_group) ;
548 -- Get the supporting decls
549 rn_imp_decls <- slurpImpDecls (duUses dus) ;
550 let { rn_decls = rn_local_decls `addImpDecls` rn_imp_decls } ;
552 -- Dump trace of renaming part
553 rnDump (ppr rn_decls) ;
554 rnStats rn_imp_decls ;
556 -- Typecheck them all together so that
557 -- any mutually recursive types are done right
558 tcg_env <- typecheckIfaceDecls rn_decls ;
559 setGblEnv tcg_env $ do {
561 -- Now the core bindings
562 core_prs <- tcCoreBinds (hs_coreds rn_local_decls) ;
563 tcExtendGlobalValEnv (map fst core_prs) $ do {
567 bndrs = map fst core_prs ;
568 my_exports = map (Avail . idName) bndrs ;
569 -- ToDo: export the data types also?
571 final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
573 mod_guts = ModGuts { mg_module = this_mod,
574 mg_usages = [], -- ToDo: compute usage
575 mg_dir_imps = [], -- ??
576 mg_deps = noDependencies, -- ??
577 mg_exports = my_exports,
578 mg_types = final_type_env,
579 mg_insts = tcg_insts tcg_env,
580 mg_rules = hsCoreRules (tcg_rules tcg_env),
581 mg_binds = [Rec core_prs],
584 mg_rdr_env = emptyGlobalRdrEnv,
585 mg_fix_env = emptyFixityEnv,
586 mg_deprecs = NoDeprecs,
590 tcCoreDump mod_guts ;
597 %************************************************************************
599 Type-checking the top level of a module
601 %************************************************************************
604 tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, DefUses)
605 -- Returns the variables free in the decls
606 -- Reason: solely to report unused imports and bindings
608 = do { -- Do all the declarations
609 ((tc_envs, dus), lie) <- getLIE (tc_rn_src_decls decls) ;
611 -- tcSimplifyTop deals with constant or ambiguous InstIds.
612 -- How could there be ambiguous ones? They can only arise if a
613 -- top-level decl falls under the monomorphism
614 -- restriction, and no subsequent decl instantiates its
615 -- type. (Usually, ambiguous type variables are resolved
616 -- during the generalisation step.)
617 traceTc (text "Tc8") ;
618 setEnvs tc_envs $ do {
619 -- Setting the global env exposes the instances to tcSimplifyTop
620 -- Setting the local env exposes the local Ids, so that
621 -- we get better error messages (monomorphism restriction)
622 inst_binds <- tcSimplifyTop lie ;
624 -- Backsubstitution. This must be done last.
625 -- Even tcSimplifyTop may do some unification.
626 traceTc (text "Tc9") ;
627 let { (tcg_env, _) = tc_envs ;
628 TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
629 tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
631 (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
634 return (tcg_env { tcg_type_env = extendTypeEnvWithIds type_env bind_ids,
635 tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' },
639 tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), DefUses)
642 = do { let { (first_group, group_tail) = findSplice ds } ;
643 -- If ds is [] we get ([], Nothing)
645 -- Type check the decls up to, but not including, the first splice
646 (tc_envs@(_,tcl_env), src_dus1) <- tcRnGroup first_group ;
648 -- Bale out if errors; for example, error recovery when checking
649 -- the RHS of 'main' can mean that 'main' is not in the envt for
650 -- the subsequent checkMain test
655 -- If there is no splice, we're nearlydone
657 Nothing -> do { -- Last thing: check for `main'
658 (tcg_env, main_fvs) <- checkMain ;
659 return ((tcg_env, tcl_env),
660 src_dus1 `plusDU` usesOnly main_fvs)
663 -- If there's a splice, we must carry on
664 Just (SpliceDecl splice_expr splice_loc, rest_ds) -> do {
666 failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
669 -- Rename the splice expression, and get its supporting decls
670 (rn_splice_expr, splice_fvs) <- initRn SourceMode $
671 addSrcLoc splice_loc $
673 tcg_env <- importSupportingDecls (splice_fvs `plusFV` templateHaskellNames) ;
674 setGblEnv tcg_env $ do {
676 -- Execute the splice
677 spliced_decls <- tcSpliceDecls rn_splice_expr ;
679 -- Glue them on the front of the remaining decls and loop
680 (tc_envs, src_dus2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ;
682 return (tcg_envs, src_dus1 `plusDU` usesOnly splice_fvs `plusDU` src_dus2)
689 %************************************************************************
691 Type-checking the top level of a module
693 %************************************************************************
695 tcRnGroup takes a bunch of top-level source-code declarations, and
697 * gets supporting declarations from interface files
700 * and augments the TcGblEnv with the results
702 In Template Haskell it may be called repeatedly for each group of
703 declarations. It expects there to be an incoming TcGblEnv in the
704 monad; it augments it and returns the new TcGblEnv.
707 tcRnGroup :: HsGroup RdrName -> TcM ((TcGblEnv, TcLclEnv), DefUses)
708 -- Returns the variables free in the decls, for unused-binding reporting
710 = do { showLIE (text "LIE at start of tcRnGroup" <+> ppr decls) ;
712 -- Rename the declarations
713 (tcg_env, rn_decls, src_dus) <- rnTopSrcDecls decls ;
714 setGblEnv tcg_env $ do {
716 -- Typecheck the declarations
717 tc_envs <- tcTopSrcDecls rn_decls ;
719 showLIE (text "LIE at end of tcRnGroup" <+> ppr decls) ;
720 return (tc_envs, src_dus)
723 ------------------------------------------------
724 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, DefUses)
726 = do { -- Bring top level binders into scope
727 (rdr_env, imports) <- importsFromLocalDecls group ;
728 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv`
730 tcg_imports = imports `plusImportAvails`
734 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
736 -- Rename the source decls
737 (tcg_env, rn_src_decls, src_dus) <- initRn SourceMode (rnSrcDecls group) ;
738 setGblEnv tcg_env $ do {
742 -- Import consquential imports
743 let { src_fvs = duUses src_dus } ;
744 rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ;
745 let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ;
747 -- Dump trace of renaming part
748 rnDump (ppr rn_decls) ;
749 rnStats rn_imp_decls ;
751 return (tcg_env, rn_decls, src_dus)
754 ------------------------------------------------
755 tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
757 (HsGroup { hs_tyclds = tycl_decls,
758 hs_instds = inst_decls,
759 hs_fords = foreign_decls,
760 hs_defds = default_decls,
761 hs_ruleds = rule_decls,
762 hs_valds = val_binds })
763 = do { -- Type-check the type and class decls, and all imported decls
764 -- The latter come in via tycl_decls
765 traceTc (text "Tc2") ;
766 tcg_env <- tcTyClDecls tycl_decls ;
767 setGblEnv tcg_env $ do {
769 -- Source-language instances, including derivings,
770 -- and import the supporting declarations
771 traceTc (text "Tc3") ;
772 (tcg_env, inst_infos, deriv_binds, fvs) <- tcInstDecls1 tycl_decls inst_decls ;
773 setGblEnv tcg_env $ do {
774 tcg_env <- importSupportingDecls fvs ;
775 setGblEnv tcg_env $ do {
777 -- Foreign import declarations next. No zonking necessary
778 -- here; we can tuck them straight into the global environment.
779 traceTc (text "Tc4") ;
780 (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
781 tcExtendGlobalValEnv fi_ids $
782 updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls })
785 -- Default declarations
786 traceTc (text "Tc4a") ;
787 default_tys <- tcDefaults default_decls ;
788 updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
790 -- Value declarations next
791 -- We also typecheck any extra binds that came out
792 -- of the "deriving" process
793 traceTc (text "Tc5") ;
794 (tc_val_binds, lcl_env) <- tcTopBinds (val_binds `ThenBinds` deriv_binds) ;
795 setLclTypeEnv lcl_env $ do {
797 -- Second pass over class and instance declarations,
798 -- plus rules and foreign exports, to generate bindings
799 traceTc (text "Tc6") ;
800 (cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ;
801 tcExtendGlobalValEnv dm_ids $ do {
802 inst_binds <- tcInstDecls2 inst_infos ;
803 showLIE (text "after instDecls2") ;
806 -- They need to be zonked, so we return them
807 traceTc (text "Tc7") ;
808 (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
811 -- Need to partition them because the source rules
812 -- must be zonked before adding them to tcg_rules
813 -- NB: built-in rules come in as IfaceRuleOut's, and
814 -- get added to tcg_rules right here by tcExtendRules
815 rules <- tcRules rule_decls ;
816 let { (src_rules, iface_rules) = partition isSrcRule rules } ;
817 tcExtendRules iface_rules $ do {
820 tcg_env <- getGblEnv ;
821 let { all_binds = tc_val_binds `AndMonoBinds`
822 inst_binds `AndMonoBinds`
823 cls_dm_binds `AndMonoBinds`
826 -- Extend the GblEnv with the (as yet un-zonked)
827 -- bindings, rules, foreign decls
828 tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `andMonoBinds` all_binds,
829 tcg_rules = tcg_rules tcg_env ++ src_rules,
830 tcg_fords = tcg_fords tcg_env ++ foe_decls } } ;
832 return (tcg_env', lcl_env)
837 tcTyClDecls :: [RenamedTyClDecl]
840 -- tcTyClDecls deals with
841 -- type and class decls (some source, some imported)
842 -- interface signatures (checked lazily)
844 -- It returns the TcGblEnv for this module, and side-effects the
845 -- persistent compiler state to reflect the things imported from
848 tcTyClDecls tycl_decls
850 -- tcTyAndClassDecls recovers internally, but if anything gave rise to
851 -- an error we'd better stop now, to avoid a cascade
853 traceTc (text "TyCl1") `thenM_`
854 tcTyAndClassDecls tycl_decls `thenM` \ tcg_env ->
855 -- Returns the extended environment
858 traceTc (text "TyCl2") `thenM_`
859 tcInterfaceSigs tycl_decls `thenM` \ tcg_env ->
860 -- Returns the extended environment
867 %************************************************************************
869 Load the old interface file for this module (unless
870 we have it aleady), and check whether it is up to date
873 %************************************************************************
876 checkOldIface :: HscEnv
877 -> PersistentCompilerState
879 -> FilePath -- Where the interface file is
880 -> Bool -- Source unchanged
881 -> Maybe ModIface -- Old interface from compilation manager, if any
882 -> IO (PersistentCompilerState, Maybe (RecompileRequired, Maybe ModIface))
883 -- Nothing <=> errors happened
885 checkOldIface hsc_env pcs mod iface_path source_unchanged maybe_iface
886 = do { showPass (hsc_dflags hsc_env)
887 ("Checking old interface for " ++ moduleUserString mod) ;
889 initTc hsc_env pcs mod
890 (check_old_iface iface_path source_unchanged maybe_iface)
893 check_old_iface iface_path source_unchanged maybe_iface
894 = -- CHECK WHETHER THE SOURCE HAS CHANGED
895 ifM (not source_unchanged)
896 (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
899 -- If the source has changed and we're in interactive mode, avoid reading
900 -- an interface; just return the one we might have been supplied with.
901 getGhciMode `thenM` \ ghci_mode ->
902 if (ghci_mode == Interactive) && not source_unchanged then
903 returnM (outOfDate, maybe_iface)
907 Just old_iface -> -- Use the one we already have
908 checkVersions source_unchanged old_iface `thenM` \ recomp ->
909 returnM (recomp, Just old_iface)
911 Nothing -- Try and read it from a file
912 -> getModule `thenM` \ this_mod ->
913 readIface this_mod iface_path False `thenM` \ read_result ->
915 Left err -> -- Old interface file not found, or garbled; give up
917 text "Cannot read old interface file:"
918 $$ nest 4 (text (showException err))) `thenM_`
919 returnM (outOfDate, Nothing)
921 Right parsed_iface ->
922 initRn (InterfaceMode this_mod)
923 (loadOldIface parsed_iface) `thenM` \ m_iface ->
924 checkVersions source_unchanged m_iface `thenM` \ recomp ->
925 returnM (recomp, Just m_iface)
929 %************************************************************************
931 Type-check and rename supporting declarations
932 This is used to deal with the free vars of a splice,
933 or derived code: slurp in the necessary declarations,
934 typecheck them, and add them to the EPS
936 %************************************************************************
939 importSupportingDecls :: FreeVars -> TcM TcGblEnv
940 -- Completely deal with the supporting imports needed
941 -- by the specified free-var set
942 importSupportingDecls fvs
943 = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ;
944 decls <- slurpImpDecls fvs ;
945 traceRn (text "...namely:" <+> vcat (map ppr decls)) ;
946 typecheckIfaceDecls (mkGroup decls) }
948 typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv
949 -- The decls are all interface-file declarations
950 -- Usually they are all from other modules, but when we are reading
951 -- this module's interface from a file, it's possible that some of
952 -- them are for the module being compiled.
953 -- That is why the tcExtendX functions need to do partitioning.
955 -- If all the decls are from other modules, the returned TcGblEnv
956 -- will have an empty tc_genv, but its tc_inst_env
957 -- cache may have been augmented.
958 typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls,
959 hs_instds = inst_decls,
960 hs_ruleds = rule_decls })
961 = do { -- Typecheck the type, class, and interface-sig decls
962 tcg_env <- tcTyClDecls tycl_decls ;
963 setGblEnv tcg_env $ do {
965 -- Typecheck the instance decls, and rules
966 -- Note that imported dictionary functions are already
967 -- in scope from the preceding tcTyClDecls
968 tcIfaceInstDecls inst_decls `thenM` \ dfuns ->
969 tcExtendInstEnv dfuns $
970 tcRules rule_decls `thenM` \ rules ->
971 tcExtendRules rules $
973 getGblEnv -- Return the environment
979 %*********************************************************
981 mkGlobalContext: make up an interactive context
983 Used for initialising the lexical environment
984 of the interactive read-eval-print loop
986 %*********************************************************
991 :: HscEnv -> PersistentCompilerState
992 -> [Module] -- Expose these modules' top-level scope
993 -> [Module] -- Expose these modules' exports only
994 -> IO (PersistentCompilerState, Maybe GlobalRdrEnv)
996 mkGlobalContext hsc_env pcs toplevs exports
997 = initTc hsc_env pcs iNTERACTIVE $ do {
999 toplev_envs <- mappM getTopLevScope toplevs ;
1000 export_envs <- mappM getModuleExports exports ;
1001 returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv
1002 (toplev_envs ++ export_envs))
1005 getTopLevScope :: Module -> TcRn m GlobalRdrEnv
1007 = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1008 case mi_globals iface of
1009 Nothing -> panic "getTopLevScope"
1010 Just env -> returnM env }
1012 getModuleExports :: Module -> TcRn m GlobalRdrEnv
1013 getModuleExports mod
1014 = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1015 returnM (foldl add emptyGlobalRdrEnv (mi_exports iface)) }
1017 prov_fn n = NonLocalDef ImplicitImport
1018 add env (mod,avails)
1019 = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs)
1021 contextDoc = text "context for compiling statements"
1027 -> PersistentCompilerState -- IN: persistent compiler state
1028 -> Module -- module to inspect
1029 -> Bool -- grab just the exports, or the whole toplev
1030 -> IO (PersistentCompilerState, Maybe [TyThing])
1032 getModuleContents hsc_env pcs mod exports_only
1033 = initTc hsc_env pcs iNTERACTIVE $ do {
1035 -- Load the interface if necessary (a home module will certainly
1036 -- alraedy be loaded, but a package module might not be)
1037 iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1039 let { export_names = availsToNameSet export_avails ;
1040 export_avails = [ avail | (mn, avails) <- mi_exports iface,
1041 avail <- avails ] } ;
1043 all_names <- if exports_only then
1045 else case mi_globals iface of {
1047 return (get_locals rdr_env) ;
1049 Nothing -> do { addErr (noRdrEnvErr mod) ;
1050 return export_names } } ;
1051 -- Invariant; we only have (not exports_only)
1052 -- for a home module so it must already be in the HIT
1053 -- So the Nothing case is a bug
1055 env <- importSupportingDecls all_names ;
1056 setGblEnv env (mappM tcLookupGlobal (nameSetToList all_names))
1059 -- Grab all the things from the global env that are locally def'd
1060 get_locals rdr_env = mkNameSet [ gre_name gre
1061 | elts <- rdrEnvElts rdr_env,
1064 -- Make a set because a name is often in the envt in
1065 -- both qualified and unqualified forms
1067 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
1068 <+> quotes (ppr mod)
1072 %************************************************************************
1076 %************************************************************************
1080 = do { ghci_mode <- getGhciMode ;
1081 tcg_env <- getGblEnv ;
1082 check_main ghci_mode tcg_env
1085 check_main ghci_mode tcg_env
1086 -- If we are in module Main, check that 'main' is defined.
1087 -- It may be imported from another module, in which case
1088 -- we have to drag in its.
1090 -- Also form the definition
1091 -- $main = runIO main
1092 -- so we need to slurp in runIO too.
1094 -- ToDo: We have to return the main_name separately, because it's a
1095 -- bona fide 'use', and should be recorded as such, but the others
1098 -- Blimey: a whole page of code to do this...
1100 | mod_name /= mAIN_Name
1101 = return (tcg_env, emptyFVs)
1103 -- Check that 'main' is in scope
1104 -- It might be imported from another module!
1106 -- We use a guard for this (rather than letting lookupSrcName fail)
1107 -- because it's not an error in ghci)
1108 | not (main_RDR_Unqual `elemRdrEnv` rdr_env)
1109 = do { complain_no_main; return (tcg_env, emptyFVs) }
1112 = do { main_name <- lookupSrcName main_RDR_Unqual ;
1114 tcg_env <- importSupportingDecls (unitFV runIOName) ;
1116 addSrcLoc (getSrcLoc main_name) $
1117 addErrCtxt mainCtxt $
1118 setGblEnv tcg_env $ do {
1120 -- $main :: IO () = runIO main
1121 let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ;
1122 (main_expr, ty) <- tcExpr_id rhs ;
1124 let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) ;
1125 main_bind = VarMonoBind dollar_main_id main_expr ;
1126 tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env
1127 `andMonoBinds` main_bind } } ;
1129 return (tcg_env', unitFV main_name)
1132 mod_name = moduleName (tcg_mod tcg_env)
1133 rdr_env = tcg_rdr_env tcg_env
1135 complain_no_main | ghci_mode == Interactive = return ()
1136 | otherwise = failWithTc noMainMsg
1137 -- In interactive mode, don't worry about the absence of 'main'
1138 -- In other modes, fail altogether, so that we don't go on
1139 -- and complain a second time when processing the export list.
1141 mainCtxt = ptext SLIT("When checking the type of 'main'")
1142 noMainMsg = ptext SLIT("No 'main' defined in module Main")
1146 %************************************************************************
1150 %************************************************************************
1153 rnDump :: SDoc -> TcRn m ()
1154 -- Dump, with a banner, if -ddump-rn
1155 rnDump doc = dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc)
1157 tcDump :: TcGblEnv -> TcRn m ()
1159 = do { dflags <- getDOpts ;
1161 -- Dump short output if -ddump-types or -ddump-tc
1162 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1163 (dumpTcRn short_dump) ;
1165 -- Dump bindings if -ddump-tc
1166 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1169 short_dump = pprTcGblEnv env
1170 full_dump = ppr (tcg_binds env)
1171 -- NB: foreign x-d's have undefined's in their types;
1172 -- hence can't show the tc_fords
1175 = do { dflags <- getDOpts ;
1176 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1177 (dumpTcRn (pprModGuts mod_guts)) ;
1179 -- Dump bindings if -ddump-tc
1180 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1182 full_dump = pprCoreBindings (mg_binds mod_guts)
1184 -- It's unpleasant having both pprModGuts and pprModDetails here
1185 pprTcGblEnv :: TcGblEnv -> SDoc
1186 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1187 tcg_insts = dfun_ids,
1189 tcg_imports = imports })
1190 = vcat [ ppr_types dfun_ids type_env
1191 , ppr_insts dfun_ids
1192 , vcat (map ppr rules)
1193 , ppr_gen_tycons (typeEnvTyCons type_env)
1194 , ppr (moduleEnvElts (imp_dep_mods imports))
1195 , ppr (imp_dep_pkgs imports)]
1197 pprModGuts :: ModGuts -> SDoc
1198 pprModGuts (ModGuts { mg_types = type_env,
1200 = vcat [ ppr_types [] type_env,
1204 ppr_types :: [Var] -> TypeEnv -> SDoc
1205 ppr_types dfun_ids type_env
1206 = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1208 ids = [id | id <- typeEnvIds type_env, want_sig id]
1209 want_sig id | opt_PprStyle_Debug = True
1210 | otherwise = isLocalId id &&
1211 isExternalName (idName id) &&
1212 not (id `elem` dfun_ids)
1213 -- isLocalId ignores data constructors, records selectors etc.
1214 -- The isExternalName ignores local dictionary and method bindings
1215 -- that the type checker has invented. Top-level user-defined things
1216 -- have External names.
1218 ppr_insts :: [Var] -> SDoc
1219 ppr_insts [] = empty
1220 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1222 ppr_sigs :: [Var] -> SDoc
1224 -- Print type signatures
1225 -- Convert to HsType so that we get source-language style printing
1226 -- And sort by RdrName
1227 = vcat $ map ppr_sig $ sortLt lt_sig $
1228 [ (getRdrName id, toHsType (idType id))
1231 lt_sig (n1,_) (n2,_) = n1 < n2
1232 ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t
1235 ppr_rules :: [IdCoreRule] -> SDoc
1236 ppr_rules [] = empty
1237 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1238 nest 4 (pprIdRules rs),
1241 ppr_gen_tycons [] = empty
1242 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
1243 vcat (map ppr_gen_tycon tcs),
1247 -- x&y are now Id's, not CoreExpr's
1249 | Just ep <- tyConGenInfo tycon
1250 = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
1252 | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
1255 = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
1256 ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
1257 ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to))
1260 (_,from_tau) = tcSplitForAllTys (idType from)