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 ( qTyConName )
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, mkUnqual, mkRdrUnqual,
39 lookupRdrEnv, elemRdrEnv )
41 import RnHsSyn ( RenamedStmt, RenamedTyClDecl,
42 ruleDeclFVs, instDeclFVs, tyClDeclFVs )
43 import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl,
44 zonkTopBinds, 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 ( RecTcGblEnv,
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 ( rnImports, exportsFromAvail, reportUnusedNames )
75 import RnIfaces ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate )
76 import RnHiFiles ( readIface, loadOldIface )
77 import RnEnv ( lookupSrcName, lookupOccRn, plusGlobalRdrEnv,
78 ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs )
79 import RnExpr ( rnStmts, rnExpr )
80 import RnNames ( importsFromLocalDecls )
81 import RnSource ( rnSrcDecls, checkModDeprec, rnStats )
83 import OccName ( varName )
84 import CoreUnfold ( unfoldingTemplate )
85 import CoreSyn ( IdCoreRule, Bind(..) )
86 import PprCore ( pprIdRules, pprCoreBindings )
87 import TysWiredIn ( mkListTy, unitTy )
88 import ErrUtils ( mkDumpDoc, showPass )
89 import Id ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported )
90 import IdInfo ( GlobalIdDetails(..) )
91 import Var ( Var, setGlobalIdDetails )
92 import Module ( Module, moduleName, moduleUserString, moduleEnvElts )
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 Maybe ( catMaybes )
122 import Panic ( showException )
123 import List ( partition )
124 import Util ( sortLt )
129 %************************************************************************
131 Typecheck and rename a module
133 %************************************************************************
137 tcRnModule :: HscEnv -> PersistentCompilerState
139 -> IO (PersistentCompilerState, Maybe TcGblEnv)
141 tcRnModule hsc_env pcs
142 (HsModule this_mod _ exports import_decls local_decls mod_deprec loc)
143 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
145 initTc hsc_env pcs this_mod $ addSrcLoc loc $
146 do { -- Deal with imports; sets tcg_rdr_env, tcg_imports
147 (rdr_env, imports) <- rnImports import_decls ;
148 updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
149 tcg_imports = tcg_imports gbl `plusImportAvails` imports })
151 traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
152 -- Fail if there are any errors so far
153 -- The error printing (if needed) takes advantage
154 -- of the tcg_env we have now set
157 traceRn (text "rn1a") ;
158 -- Rename and type check the declarations
159 (tcg_env, src_fvs) <- tcRnSrcDecls local_decls ;
160 setGblEnv tcg_env $ do {
161 traceRn (text "rn2") ;
164 (tcg_env, main_fvs) <- checkMain ;
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 exports ;
178 updGblEnv (\gbl -> gbl { tcg_exports = export_avails })
181 -- Get the supporting decls for the exports
182 -- This is important *only* to gether usage information
183 -- (see comments with MkIface.mkImportInfo for why)
184 -- For OneShot compilation we could just throw away the decls
185 -- but for Batch or Interactive we must put them in the type
186 -- envt because they've been removed from the holding pen
187 let { export_fvs = availsToNameSet export_avails } ;
188 tcg_env <- importSupportingDecls export_fvs ;
189 setGblEnv tcg_env $ do {
191 -- Report unused names
192 let { used_fvs = src_fvs `plusFV` main_fvs `plusFV` export_fvs } ;
193 reportUnusedNames tcg_env used_fvs ;
195 -- Dump output and return
202 %*********************************************************
204 \subsection{Closing up the interface decls}
206 %*********************************************************
208 Suppose we discover we don't need to recompile. Then we start from the
209 IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need.
213 -> PersistentCompilerState
214 -> ModIface -- Get the decls from here
215 -> IO (PersistentCompilerState, Maybe ModDetails)
216 -- Nothing <=> errors happened
217 tcRnIface hsc_env pcs
218 (ModIface {mi_module = mod, mi_decls = iface_decls})
219 = initTc hsc_env pcs mod $ do {
221 -- Get the supporting decls, and typecheck them all together
222 -- so that any mutually recursive types are done right
223 extra_decls <- slurpImpDecls needed ;
224 env <- typecheckIfaceDecls (group `addImpDecls` extra_decls) ;
226 returnM (ModDetails { md_types = tcg_type_env env,
227 md_insts = tcg_insts env,
228 md_rules = hsCoreRules (tcg_rules env)
229 -- All the rules from an interface are of the IfaceRuleOut form
232 rule_decls = dcl_rules iface_decls
233 inst_decls = dcl_insts iface_decls
234 tycl_decls = dcl_tycl iface_decls
235 group = emptyGroup { hs_ruleds = rule_decls,
236 hs_instds = inst_decls,
237 hs_tyclds = tycl_decls }
238 needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets`
239 unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets`
240 unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets`
242 -- Data type decls with record selectors,
243 -- which may appear in the decls, need unpackCString
244 -- and friends. It's easier to just grab them right now.
246 hsCoreRules :: [TypecheckedRuleDecl] -> [IdCoreRule]
247 -- All post-typechecking Iface rules have the form IfaceRuleOut
248 hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules]
252 %************************************************************************
254 The interactive interface
256 %************************************************************************
259 tcRnStmt :: HscEnv -> PersistentCompilerState
260 -> InteractiveContext
262 -> IO (PersistentCompilerState,
263 Maybe (InteractiveContext, [Name], TypecheckedHsExpr))
264 -- The returned [Id] is the same as the input except for
265 -- ExprStmt, in which case the returned [Name] is [itName]
267 tcRnStmt hsc_env pcs ictxt rdr_stmt
268 = initTc hsc_env pcs iNTERACTIVE $
269 setInteractiveContext ictxt $ do {
271 -- Rename; use CmdLineMode because tcRnStmt is only used interactively
272 ([rn_stmt], fvs) <- initRnInteractive ictxt
273 (rnStmts DoExpr [rdr_stmt]) ;
274 traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
277 -- Suck in the supporting declarations and typecheck them
278 tcg_env <- importSupportingDecls (fvs `plusFV` implicitStmtFVs fvs) ;
279 -- NB: an earlier version deleted (rdrEnvElts local_env) from
280 -- the fvs. But (a) that isn't necessary, because previously
281 -- bound things in the local_env will be in the TypeEnv, and
282 -- the renamer doesn't re-slurp such things, and
283 -- (b) it's WRONG to delete them. Consider in GHCi:
284 -- Mod> let x = e :: T
285 -- Mod> let y = x + 3
286 -- We need to pass 'x' among the fvs to slurpImpDecls, so that
287 -- the latter can see that T is a gate, and hence import the Num T
288 -- instance decl. (See the InTypEnv case in RnIfaces.slurpSourceRefs.)
289 setGblEnv tcg_env $ do {
291 -- The real work is done here
292 ((bound_ids, tc_expr), lie) <- getLIE (tcUserStmt rn_stmt) ;
294 traceTc (text "tcs 1") ;
295 let { -- Make all the bound ids "global" ids, now that
296 -- they're notionally top-level bindings. This is
297 -- important: otherwise when we come to compile an expression
298 -- using these ids later, the byte code generator will consider
299 -- the occurrences to be free rather than global.
300 global_ids = map globaliseId bound_ids ;
301 globaliseId id = setGlobalIdDetails id VanillaGlobal ;
303 -- Update the interactive context
304 rn_env = ic_rn_local_env ictxt ;
305 type_env = ic_type_env ictxt ;
307 bound_names = map idName global_ids ;
308 new_rn_env = extendLocalRdrEnv rn_env bound_names ;
310 -- Remove any shadowed bindings from the type_env;
311 -- they are inaccessible but might, I suppose, cause
312 -- a space leak if we leave them there
313 shadowed = [ n | name <- bound_names,
314 let rdr_name = mkRdrUnqual (nameOccName name),
315 Just n <- [lookupRdrEnv rn_env rdr_name] ] ;
317 filtered_type_env = delListFromNameEnv type_env shadowed ;
318 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
320 new_ic = ictxt { ic_rn_local_env = new_rn_env,
321 ic_type_env = new_type_env }
324 dumpOptTcRn Opt_D_dump_tc
325 (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
326 text "Typechecked expr" <+> ppr tc_expr]) ;
328 returnM (new_ic, bound_names, tc_expr)
333 Here is the grand plan, implemented in tcUserStmt
335 What you type The IO [HValue] that hscStmt returns
336 ------------- ------------------------------------
337 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
340 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
343 expr (of IO type) ==> expr >>= \ v -> return [coerce HVal v]
344 [NB: result not printed] bindings: [it]
346 expr (of non-IO type, ==> let v = expr in print v >> return [coerce HVal v]
347 result showable) bindings: [it]
349 expr (of non-IO type,
350 result not showable) ==> error
354 ---------------------------
355 tcUserStmt :: RenamedStmt -> TcM ([Id], TypecheckedHsExpr)
356 tcUserStmt (ExprStmt expr _ loc)
357 = newUnique `thenM` \ uniq ->
359 fresh_it = itName uniq
360 the_bind = FunMonoBind fresh_it False
361 [ mkSimpleMatch [] expr placeHolderType loc ] loc
363 tryTcLIE_ (do { -- Try this if the other fails
364 traceTc (text "tcs 1b") ;
366 LetStmt (MonoBind the_bind [] NonRecursive),
367 ExprStmt (HsApp (HsVar printName) (HsVar fresh_it))
368 placeHolderType loc] })
369 (do { -- Try this first
370 traceTc (text "tcs 1a") ;
371 tc_stmts [BindStmt (VarPat fresh_it) expr loc] })
373 tcUserStmt stmt = tc_stmts [stmt]
375 ---------------------------
377 = do { io_ids <- mappM tcLookupId
378 [returnIOName, failIOName, bindIOName, thenIOName] ;
379 ioTyCon <- tcLookupTyCon ioTyConName ;
380 res_ty <- newTyVarTy liftedTypeKind ;
382 names = collectStmtsBinders stmts ;
383 return_id = head io_ids ; -- Rather gruesome
385 io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty) ;
387 -- mk_return builds the expression
388 -- returnIO @ [()] [coerce () x, .., coerce () z]
389 mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy])
390 (ExplicitList unitTy (map mk_item ids)) ;
392 mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
395 -- OK, we're ready to typecheck the stmts
396 traceTc (text "tcs 2") ;
397 ((ids, tc_stmts), lie) <-
398 getLIE $ tcStmtsAndThen combine DoExpr io_ty stmts $
400 -- Look up the names right in the middle,
401 -- where they will all be in scope
402 ids <- mappM tcLookupId names ;
403 return (ids, [ResultStmt (mk_return ids) noSrcLoc])
406 -- Simplify the context right here, so that we fail
407 -- if there aren't enough instances. Notably, when we see
409 -- we use recoverTc_ to try it <- e
410 -- and then let it = e
411 -- It's the simplify step that rejects the first.
412 traceTc (text "tcs 3") ;
413 const_binds <- tcSimplifyTop lie ;
415 -- Build result expression and zonk it
416 let { expr = mkHsLet const_binds $
417 HsDo DoExpr tc_stmts io_ids
418 (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc } ;
419 zonked_expr <- zonkTopExpr expr ;
420 zonked_ids <- zonkTopBndrs ids ;
422 return (zonked_ids, zonked_expr)
425 combine stmt (ids, stmts) = (ids, stmt:stmts)
429 tcRnExpr just finds the type of an expression
432 tcRnExpr :: HscEnv -> PersistentCompilerState
433 -> InteractiveContext
435 -> IO (PersistentCompilerState, Maybe Type)
436 tcRnExpr hsc_env pcs ictxt rdr_expr
437 = initTc hsc_env pcs iNTERACTIVE $
438 setInteractiveContext ictxt $ do {
440 (rn_expr, fvs) <- initRnInteractive ictxt (rnExpr rdr_expr) ;
443 -- Suck in the supporting declarations and typecheck them
444 tcg_env <- importSupportingDecls (fvs `plusFV` ubiquitousNames) ;
445 setGblEnv tcg_env $ do {
447 -- Now typecheck the expression;
448 -- it might have a rank-2 type (e.g. :t runST)
449 -- Hence the hole type (c.f. TcExpr.tcExpr_id)
450 ((tc_expr, res_ty), lie) <- getLIE (tcExpr_id rn_expr) ;
451 ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
452 tcSimplifyTop lie_top ;
454 let { all_expr_ty = mkForAllTys qtvs $
455 mkFunTys (map idType dict_ids) $
457 zonkTcType all_expr_ty
460 smpl_doc = ptext SLIT("main expression")
465 tcRnThing :: HscEnv -> PersistentCompilerState
466 -> InteractiveContext
468 -> IO (PersistentCompilerState, Maybe [TyThing])
469 -- Look up a RdrName and return all the TyThings it might be
470 -- We treat a capitalised RdrName as both a data constructor
471 -- and as a type or class constructor; hence we return up to two results
472 tcRnThing hsc_env pcs ictxt rdr_name
473 = initTc hsc_env pcs iNTERACTIVE $
474 setInteractiveContext ictxt $ do {
476 -- If the identifier is a constructor (begins with an
477 -- upper-case letter), then we need to consider both
478 -- constructor and type class identifiers.
479 let { rdr_names = dataTcOccs rdr_name } ;
481 (msgs_s, mb_names) <- initRnInteractive ictxt
482 (mapAndUnzipM (tryTc . lookupOccRn) rdr_names) ;
483 let { names = catMaybes mb_names } ;
486 do { addMessages (head msgs_s) ; failM }
489 mapM_ addMessages msgs_s ; -- Add deprecation warnings
490 mapM tcLookupGlobal names -- and lookup up the entities
496 setInteractiveContext :: InteractiveContext -> TcRn m a -> TcRn m a
497 setInteractiveContext icxt thing_inside
498 = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_`
499 updGblEnv (\ env -> env { tcg_rdr_env = ic_rn_gbl_env icxt,
500 tcg_type_env = ic_type_env icxt })
503 initRnInteractive :: InteractiveContext -> RnM a -> TcM a
504 -- Set the local RdrEnv from the interactive context
505 initRnInteractive ictxt rn_thing
506 = initRn CmdLineMode $
507 setLocalRdrEnv (ic_rn_local_env ictxt) $
511 %************************************************************************
513 Type-checking external-core modules
515 %************************************************************************
518 tcRnExtCore :: HscEnv -> PersistentCompilerState
520 -> IO (PersistentCompilerState, Maybe ModGuts)
521 -- Nothing => some error occurred
523 tcRnExtCore hsc_env pcs
524 (HsModule this_mod _ _ _ local_decls _ loc)
525 -- Rename the (Core) module. It's a bit like an interface
526 -- file: all names are original names
527 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
529 initTc hsc_env pcs this_mod $ addSrcLoc loc $ do {
531 -- Rename the source, only in interface mode.
532 -- rnSrcDecls handles fixity decls etc too, which won't occur
533 -- but that doesn't matter
534 let { local_group = mkGroup local_decls } ;
535 (_, rn_local_decls, fvs) <- initRn (InterfaceMode this_mod)
536 (rnSrcDecls local_group) ;
539 -- Get the supporting decls, and typecheck them all together
540 -- so that any mutually recursive types are done right
541 extra_decls <- slurpImpDecls fvs ;
542 tcg_env <- typecheckIfaceDecls (rn_local_decls `addImpDecls` extra_decls) ;
543 setGblEnv tcg_env $ do {
545 -- Now the core bindings
546 core_prs <- tcCoreBinds (hs_coreds rn_local_decls) ;
547 tcExtendGlobalValEnv (map fst core_prs) $ do {
551 bndrs = map fst core_prs ;
552 my_exports = map (Avail . idName) bndrs ;
553 -- ToDo: export the data types also?
555 final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
557 mod_guts = ModGuts { mg_module = this_mod,
558 mg_usages = [], -- ToDo: compute usage
559 mg_dir_imps = [], -- ??
560 mg_deps = noDependencies, -- ??
561 mg_exports = my_exports,
562 mg_types = final_type_env,
563 mg_insts = tcg_insts tcg_env,
564 mg_rules = hsCoreRules (tcg_rules tcg_env),
565 mg_binds = [Rec core_prs],
568 mg_rdr_env = emptyGlobalRdrEnv,
569 mg_fix_env = emptyFixityEnv,
570 mg_deprecs = NoDeprecs,
574 tcCoreDump mod_guts ;
581 %************************************************************************
583 Type-checking the top level of a module
585 %************************************************************************
588 tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars)
589 -- Returns the variables free in the decls
590 -- Reason: solely to report unused imports and bindings
591 tcRnSrcDecls [] = do { tcg_env <- getGblEnv ; return (tcg_env, emptyFVs) }
593 = do { let { (first_group, group_tail) = findSplice ds } ;
595 -- Type check the decls up to, but not including, the first splice
596 (tcg_env, src_fvs1) <- tcRnGroup first_group ;
598 -- If there is no splice, we're done
600 Nothing -> return (tcg_env, src_fvs1)
601 Just (SpliceDecl splice_expr splice_loc, rest_ds) -> do {
603 setGblEnv tcg_env $ do {
606 failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
608 -- Rename the splice expression, and get its supporting decls
609 (rn_splice_expr, fvs) <- initRn SourceMode $
610 addSrcLoc splice_loc $
612 tcg_env <- importSupportingDecls (fvs `addOneFV` qTyConName) ;
613 setGblEnv tcg_env $ do {
615 -- Execute the splice
616 spliced_decls <- tcSpliceDecls rn_splice_expr ;
618 -- Glue them on the front of the remaining decls and loop
619 (tcg_env, src_fvs2) <- tcRnSrcDecls (spliced_decls ++ rest_ds) ;
621 return (tcg_env, src_fvs1 `plusFV` src_fvs2)
628 %************************************************************************
630 Type-checking the top level of a module
632 %************************************************************************
634 tcRnGroup takes a bunch of top-level source-code declarations, and
636 * gets supporting declarations from interface files
639 * and augments the TcGblEnv with the results
641 In Template Haskell it may be called repeatedly for each group of
642 declarations. It expects there to be an incoming TcGblEnv in the
643 monad; it augments it and returns the new TcGblEnv.
646 tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, FreeVars)
647 -- Returns the variables free in the decls
649 = do { -- Rename the declarations
650 (tcg_env, rn_decls, src_fvs) <- rnTopSrcDecls decls ;
651 setGblEnv tcg_env $ do {
653 -- Typecheck the declarations
654 tcg_env <- tcTopSrcDecls rn_decls ;
655 return (tcg_env, src_fvs)
658 ------------------------------------------------
659 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, FreeVars)
661 = do { -- Bring top level binders into scope
662 (rdr_env, imports) <- importsFromLocalDecls group ;
663 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv`
665 tcg_imports = imports `plusImportAvails`
669 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
671 -- Rename the source decls
672 (tcg_env, rn_src_decls, src_fvs) <- initRn SourceMode (rnSrcDecls group) ;
673 setGblEnv tcg_env $ do {
677 -- Import consquential imports
678 rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ;
679 let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ;
681 -- Dump trace of renaming part
682 rnDump (ppr rn_decls) ;
683 rnStats rn_imp_decls ;
685 return (tcg_env, rn_decls, src_fvs)
688 ------------------------------------------------
689 tcTopSrcDecls :: HsGroup Name -> TcM TcGblEnv
690 tcTopSrcDecls rn_decls
691 = fixM (\ unf_env -> do {
692 -- Loop back the final environment, including the fully zonked
693 -- versions of bindings from this module. In the presence of mutual
694 -- recursion, interface type signatures may mention variables defined
695 -- in this module, which is why the knot is so big
698 ((tcg_env, binds, rules, fords), lie) <- getLIE (
699 tc_src_decls unf_env rn_decls
702 -- tcSimplifyTop deals with constant or ambiguous InstIds.
703 -- How could there be ambiguous ones? They can only arise if a
704 -- top-level decl falls under the monomorphism
705 -- restriction, and no subsequent decl instantiates its
706 -- type. (Usually, ambiguous type variables are resolved
707 -- during the generalisation step.)
708 traceTc (text "Tc8") ;
709 inst_binds <- setGblEnv tcg_env (tcSimplifyTop lie) ;
710 -- The setGblEnv exposes the instances to tcSimplifyTop
712 -- Backsubstitution. This must be done last.
713 -- Even tcSimplifyTop may do some unification.
714 traceTc (text "Tc9") ;
715 (ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
718 let { tcg_env' = tcg_env { tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids,
719 tcg_binds = tcg_binds tcg_env `andMonoBinds` binds',
720 tcg_rules = tcg_rules tcg_env ++ rules',
721 tcg_fords = tcg_fords tcg_env ++ fords' } } ;
727 (HsGroup { hs_tyclds = tycl_decls,
728 hs_instds = inst_decls,
729 hs_fords = foreign_decls,
730 hs_defds = default_decls,
731 hs_ruleds = rule_decls,
732 hs_valds = val_binds })
733 = do { -- Type-check the type and class decls, and all imported decls
734 traceTc (text "Tc2") ;
735 tcg_env <- tcTyClDecls unf_env tycl_decls ;
736 setGblEnv tcg_env $ do {
738 -- Source-language instances, including derivings,
739 -- and import the supporting declarations
740 traceTc (text "Tc3") ;
741 (tcg_env, inst_infos, deriv_binds, fvs) <- tcInstDecls1 tycl_decls inst_decls ;
742 setGblEnv tcg_env $ do {
743 tcg_env <- importSupportingDecls fvs ;
744 setGblEnv tcg_env $ do {
746 -- Foreign import declarations next. No zonking necessary
747 -- here; we can tuck them straight into the global environment.
748 traceTc (text "Tc4") ;
749 (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
750 tcExtendGlobalValEnv fi_ids $
751 updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls })
754 -- Default declarations
755 traceTc (text "Tc4a") ;
756 default_tys <- tcDefaults default_decls ;
757 updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
759 -- Value declarations next
760 -- We also typecheck any extra binds that came out
761 -- of the "deriving" process
762 traceTc (text "Tc5") ;
763 (tc_val_binds, lcl_env) <- tcTopBinds (val_binds `ThenBinds` deriv_binds) ;
764 setLclTypeEnv lcl_env $ do {
766 -- Second pass over class and instance declarations,
767 -- plus rules and foreign exports, to generate bindings
768 traceTc (text "Tc6") ;
769 (cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ;
770 tcExtendGlobalValEnv dm_ids $ do {
771 inst_binds <- tcInstDecls2 inst_infos ;
772 showLIE "after instDecls2" ;
775 -- They need to be zonked, so we return them
776 traceTc (text "Tc7") ;
777 (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
780 -- Need to partition them because the source rules
781 -- must be zonked before adding them to tcg_rules
782 -- NB: built-in rules come in as IfaceRuleOut's, and
783 -- get added to tcg_rules right here by tcExtendRules
784 rules <- tcRules rule_decls ;
785 let { (src_rules, iface_rules) = partition isSrcRule rules } ;
786 tcExtendRules iface_rules $ do {
789 tcg_env <- getGblEnv ;
790 let { all_binds = tc_val_binds `AndMonoBinds`
791 inst_binds `AndMonoBinds`
792 cls_dm_binds `AndMonoBinds`
795 return (tcg_env, all_binds, src_rules, foe_decls)
800 tcTyClDecls :: RecTcGblEnv
804 -- tcTyClDecls deals with
805 -- type and class decls (some source, some imported)
806 -- interface signatures (checked lazily)
808 -- It returns the TcGblEnv for this module, and side-effects the
809 -- persistent compiler state to reflect the things imported from
812 tcTyClDecls unf_env tycl_decls
813 -- (unf_env :: RecTcGblEnv) is used for type-checking interface pragmas
814 -- which is done lazily [ie failure just drops the pragma
815 -- without having any global-failure effect].
818 -- tcTyAndClassDecls recovers internally, but if anything gave rise to
819 -- an error we'd better stop now, to avoid a cascade
821 traceTc (text "TyCl1") `thenM_`
822 tcTyAndClassDecls tycl_decls `thenM` \ tycl_things ->
823 tcExtendGlobalEnv tycl_things $
825 -- Interface type signatures
826 -- We tie a knot so that the Ids read out of interfaces are in scope
827 -- when we read their pragmas.
828 -- What we rely on is that pragmas are typechecked lazily; if
829 -- any type errors are found (ie there's an inconsistency)
830 -- we silently discard the pragma
831 traceTc (text "TyCl2") `thenM_`
832 tcInterfaceSigs unf_env tycl_decls `thenM` \ sig_ids ->
833 tcExtendGlobalValEnv sig_ids $
835 getGblEnv -- Return the TcLocals environment
840 %************************************************************************
842 Load the old interface file for this module (unless
843 we have it aleady), and check whether it is up to date
846 %************************************************************************
849 checkOldIface :: HscEnv
850 -> PersistentCompilerState
852 -> FilePath -- Where the interface file is
853 -> Bool -- Source unchanged
854 -> Maybe ModIface -- Old interface from compilation manager, if any
855 -> IO (PersistentCompilerState, Maybe (RecompileRequired, Maybe ModIface))
856 -- Nothing <=> errors happened
858 checkOldIface hsc_env pcs mod iface_path source_unchanged maybe_iface
859 = do { showPass (hsc_dflags hsc_env)
860 ("Checking old interface for " ++ moduleUserString mod) ;
862 initTc hsc_env pcs mod
863 (check_old_iface iface_path source_unchanged maybe_iface)
866 check_old_iface iface_path source_unchanged maybe_iface
867 = -- CHECK WHETHER THE SOURCE HAS CHANGED
868 ifM (not source_unchanged)
869 (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
872 -- If the source has changed and we're in interactive mode, avoid reading
873 -- an interface; just return the one we might have been supplied with.
874 getGhciMode `thenM` \ ghci_mode ->
875 if (ghci_mode == Interactive) && not source_unchanged then
876 returnM (outOfDate, maybe_iface)
880 Just old_iface -> -- Use the one we already have
881 checkVersions source_unchanged old_iface `thenM` \ recomp ->
882 returnM (recomp, Just old_iface)
884 Nothing -- Try and read it from a file
885 -> getModule `thenM` \ this_mod ->
886 readIface this_mod iface_path False `thenM` \ read_result ->
888 Left err -> -- Old interface file not found, or garbled; give up
890 text "Cannot read old interface file:"
891 $$ nest 4 (text (showException err))) `thenM_`
892 returnM (outOfDate, Nothing)
894 Right parsed_iface ->
895 initRn (InterfaceMode this_mod)
896 (loadOldIface parsed_iface) `thenM` \ m_iface ->
897 checkVersions source_unchanged m_iface `thenM` \ recomp ->
898 returnM (recomp, Just m_iface)
902 %************************************************************************
904 Type-check and rename supporting declarations
905 This is used to deal with the free vars of a splice,
906 or derived code: slurp in the necessary declarations,
907 typecheck them, and add them to the EPS
909 %************************************************************************
912 importSupportingDecls :: FreeVars -> TcM TcGblEnv
913 -- Completely deal with the supporting imports needed
914 -- by the specified free-var set
915 importSupportingDecls fvs
916 = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ;
917 decls <- slurpImpDecls fvs ;
918 traceRn (text "...namely:" <+> vcat (map ppr decls)) ;
919 typecheckIfaceDecls (mkGroup decls) }
921 typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv
922 -- The decls are all interface-file declarations
923 -- Usually they are all from other modules, but when we are reading
924 -- this module's interface from a file, it's possible that some of
925 -- them are for the module being compiled.
926 -- That is why the tcExtendX functions need to do partitioning.
928 -- If all the decls are from other modules, the returned TcGblEnv
929 -- will have an empty tc_genv, but its tc_inst_env and tc_ist
930 -- caches may have been augmented.
931 typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls,
932 hs_instds = inst_decls,
933 hs_ruleds = rule_decls })
934 = do { -- Typecheck the type, class, and interface-sig decls
935 tcg_env <- fixM (\ unf_env -> tcTyClDecls unf_env tycl_decls) ;
936 setGblEnv tcg_env $ do {
938 -- Typecheck the instance decls, and rules
939 -- Note that imported dictionary functions are already
940 -- in scope from the preceding tcTyClDecls
941 tcIfaceInstDecls inst_decls `thenM` \ dfuns ->
942 tcExtendInstEnv dfuns $
943 tcRules rule_decls `thenM` \ rules ->
944 tcExtendRules rules $
946 getGblEnv -- Return the environment
952 %*********************************************************
954 mkGlobalContext: make up an interactive context
956 Used for initialising the lexical environment
957 of the interactive read-eval-print loop
959 %*********************************************************
964 :: HscEnv -> PersistentCompilerState
965 -> [Module] -- Expose these modules' top-level scope
966 -> [Module] -- Expose these modules' exports only
967 -> IO (PersistentCompilerState, Maybe GlobalRdrEnv)
969 mkGlobalContext hsc_env pcs toplevs exports
970 = initTc hsc_env pcs iNTERACTIVE $ do {
972 toplev_envs <- mappM getTopLevScope toplevs ;
973 export_envs <- mappM getModuleExports exports ;
974 returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv
975 (toplev_envs ++ export_envs))
978 getTopLevScope :: Module -> TcRn m GlobalRdrEnv
980 = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
981 case mi_globals iface of
982 Nothing -> panic "getTopLevScope"
983 Just env -> returnM env }
985 getModuleExports :: Module -> TcRn m GlobalRdrEnv
987 = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
988 returnM (foldl add emptyGlobalRdrEnv (mi_exports iface)) }
990 prov_fn n = NonLocalDef ImplicitImport
992 = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs)
994 contextDoc = text "context for compiling statements"
1000 -> PersistentCompilerState -- IN: persistent compiler state
1001 -> Module -- module to inspect
1002 -> Bool -- grab just the exports, or the whole toplev
1003 -> IO (PersistentCompilerState, Maybe [TyThing])
1005 getModuleContents hsc_env pcs mod exports_only
1006 = initTc hsc_env pcs iNTERACTIVE $ do {
1008 -- Load the interface if necessary (a home module will certainly
1009 -- alraedy be loaded, but a package module might not be)
1010 iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1012 let { export_names = availsToNameSet export_avails ;
1013 export_avails = [ avail | (mn, avails) <- mi_exports iface,
1014 avail <- avails ] } ;
1016 all_names <- if exports_only then
1018 else case mi_globals iface of {
1020 return (get_locals rdr_env) ;
1022 Nothing -> do { addErr (noRdrEnvErr mod) ;
1023 return export_names } } ;
1024 -- Invariant; we only have (not exports_only)
1025 -- for a home module so it must already be in the HIT
1026 -- So the Nothing case is a bug
1028 env <- importSupportingDecls all_names ;
1029 setGblEnv env (mappM tcLookupGlobal (nameSetToList all_names))
1032 -- Grab all the things from the global env that are locally def'd
1033 get_locals rdr_env = mkNameSet [ gre_name gre
1034 | elts <- rdrEnvElts rdr_env,
1037 -- Make a set because a name is often in the envt in
1038 -- both qualified and unqualified forms
1040 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
1041 <+> quotes (ppr mod)
1045 %************************************************************************
1049 %************************************************************************
1053 = do { ghci_mode <- getGhciMode ;
1054 tcg_env <- getGblEnv ;
1055 check_main ghci_mode tcg_env
1058 check_main ghci_mode tcg_env
1059 -- If we are in module Main, check that 'main' is defined.
1060 -- It may be imported from another module, in which case
1061 -- we have to drag in its.
1063 -- Also form the definition
1064 -- $main = runIO main
1065 -- so we need to slurp in runIO too.
1067 -- ToDo: We have to return the main_name separately, because it's a
1068 -- bona fide 'use', and should be recorded as such, but the others
1071 -- Blimey: a whole page of code to do this...
1073 | mod_name /= mAIN_Name
1074 = return (tcg_env, emptyFVs)
1076 | not (main_RDR_Unqual `elemRdrEnv` rdr_env)
1077 = do { complain_no_main; return (tcg_env, emptyFVs) }
1080 = do { -- Check that 'main' is in scope
1081 -- It might be imported from another module!
1082 main_name <- lookupSrcName main_RDR_Unqual ;
1085 tcg_env <- importSupportingDecls (unitFV runIOName) ;
1086 setGblEnv tcg_env $ do {
1088 -- $main :: IO () = runIO main
1089 let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ;
1091 (main_bind, top_lie) <- getLIE (
1092 addSrcLoc (getSrcLoc main_name) $
1093 addErrCtxt mainCtxt $ do {
1094 (main_expr, ty) <- tcExpr_id rhs ;
1095 let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) } ;
1096 return (VarMonoBind dollar_main_id main_expr)
1099 inst_binds <- tcSimplifyTop top_lie ;
1101 (ids, binds') <- zonkTopBinds (main_bind `andMonoBinds` inst_binds) ;
1103 let { tcg_env' = tcg_env {
1104 tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids,
1105 tcg_binds = tcg_binds tcg_env `andMonoBinds` binds' } } ;
1107 return (tcg_env', unitFV main_name)
1110 mod_name = moduleName (tcg_mod tcg_env)
1111 rdr_env = tcg_rdr_env tcg_env
1113 main_RDR_Unqual :: RdrName
1114 main_RDR_Unqual = mkUnqual varName FSLIT("main")
1115 -- Don't get a RdrName from PrelNames.mainName, because
1116 -- nameRdrNamegets an Orig RdrName, and we want a Qual or Unqual one.
1117 -- An Unqual one will do just fine
1119 complain_no_main | ghci_mode == Interactive = return ()
1120 | otherwise = addErr noMainMsg
1121 -- In interactive mode, don't worry about the absence of 'main'
1123 mainCtxt = ptext SLIT("When checking the type of 'main'")
1124 noMainMsg = ptext SLIT("No 'main' defined in module Main")
1128 %************************************************************************
1132 %************************************************************************
1135 rnDump :: SDoc -> TcRn m ()
1136 -- Dump, with a banner, if -ddump-rn
1137 rnDump doc = dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc)
1139 tcDump :: TcGblEnv -> TcRn m ()
1141 = do { dflags <- getDOpts ;
1143 -- Dump short output if -ddump-types or -ddump-tc
1144 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1145 (dumpTcRn short_dump) ;
1147 -- Dump bindings if -ddump-tc
1148 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1151 short_dump = pprTcGblEnv env
1152 full_dump = ppr (tcg_binds env)
1153 -- NB: foreign x-d's have undefined's in their types;
1154 -- hence can't show the tc_fords
1157 = do { dflags <- getDOpts ;
1158 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1159 (dumpTcRn (pprModGuts mod_guts)) ;
1161 -- Dump bindings if -ddump-tc
1162 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1164 full_dump = pprCoreBindings (mg_binds mod_guts)
1166 -- It's unpleasant having both pprModGuts and pprModDetails here
1167 pprTcGblEnv :: TcGblEnv -> SDoc
1168 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1169 tcg_insts = dfun_ids,
1171 tcg_imports = imports })
1172 = vcat [ ppr_types dfun_ids type_env
1173 , ppr_insts dfun_ids
1174 , vcat (map ppr rules)
1175 , ppr_gen_tycons (typeEnvTyCons type_env)
1176 , ppr (moduleEnvElts (imp_dep_mods imports))
1177 , ppr (imp_dep_pkgs imports)]
1179 pprModGuts :: ModGuts -> SDoc
1180 pprModGuts (ModGuts { mg_types = type_env,
1182 = vcat [ ppr_types [] type_env,
1186 ppr_types :: [Var] -> TypeEnv -> SDoc
1187 ppr_types dfun_ids type_env
1188 = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1190 ids = [id | id <- typeEnvIds type_env, want_sig id]
1191 want_sig id | opt_PprStyle_Debug = True
1192 | otherwise = isLocalId id &&
1193 isExternalName (idName id) &&
1194 not (id `elem` dfun_ids)
1195 -- isLocalId ignores data constructors, records selectors etc.
1196 -- The isExternalName ignores local dictionary and method bindings
1197 -- that the type checker has invented. Top-level user-defined things
1198 -- have External names.
1200 ppr_insts :: [Var] -> SDoc
1201 ppr_insts [] = empty
1202 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1204 ppr_sigs :: [Var] -> SDoc
1206 -- Print type signatures
1207 -- Convert to HsType so that we get source-language style printing
1208 -- And sort by RdrName
1209 = vcat $ map ppr_sig $ sortLt lt_sig $
1210 [ (getRdrName id, toHsType (idType id))
1213 lt_sig (n1,_) (n2,_) = n1 < n2
1214 ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t
1217 ppr_rules :: [IdCoreRule] -> SDoc
1218 ppr_rules [] = empty
1219 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1220 nest 4 (pprIdRules rs),
1223 ppr_gen_tycons [] = empty
1224 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
1225 vcat (map ppr_gen_tycon tcs),
1229 -- x&y are now Id's, not CoreExpr's
1231 | Just ep <- tyConGenInfo tycon
1232 = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
1234 | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
1237 = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
1238 ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
1239 ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to))
1242 (_,from_tau) = tcSplitForAllTys (idType from)