2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcModule]{Typechecking a whole module}
9 mkGlobalContext, getModuleContents,
11 tcRnModule, checkOldIface, importSupportingDecls,
12 tcRnIface, tcRnExtCore, tcRnStmt, tcRnExpr, tcRnThing
15 #include "HsVersions.h"
17 import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
18 import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsDecl(..), HsExpr(..),
19 Stmt(..), Pat(VarPat), HsMatchContext(..), HsDoContext(..), RuleDecl(..),
20 mkSimpleMatch, placeHolderType, toHsType, andMonoBinds,
23 import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr )
25 import PrelNames ( iNTERACTIVE, ioTyConName, printName,
26 returnIOName, bindIOName, failIOName, thenIOName, runIOName,
27 dollarMainName, itName, mAIN_Name
29 import MkId ( unsafeCoerceId )
30 import RdrName ( RdrName, getRdrName, mkUnqual, mkRdrUnqual,
31 lookupRdrEnv, elemRdrEnv )
33 import RnHsSyn ( RenamedHsDecl, RenamedStmt, RenamedTyClDecl,
34 ruleDeclFVs, instDeclFVs, tyClDeclFVs )
35 import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl,
36 zonkTopBinds, zonkTopDecls, mkHsLet,
37 zonkTopExpr, zonkIdBndr
40 import TcExpr ( tcExpr_id )
42 import TcMType ( newTyVarTy, zonkTcType )
43 import TcType ( Type, liftedTypeKind,
44 tyVarsOfType, tcFunResultTy,
45 mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
47 import TcMatches ( tcStmtsAndThen )
48 import Inst ( showLIE )
49 import TcBinds ( tcTopBinds )
50 import TcClassDcl ( tcClassDecls2 )
51 import TcDefaults ( tcDefaults )
52 import TcEnv ( RecTcGblEnv,
55 tcExtendInstEnv, tcExtendRules,
56 tcLookupTyCon, tcLookupGlobal,
59 import TcRules ( tcRules )
60 import TcForeign ( tcForeignImports, tcForeignExports )
61 import TcIfaceSig ( tcInterfaceSigs, tcCoreBinds )
62 import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls, tcInstDecls2 )
63 import TcSimplify ( tcSimplifyTop, tcSimplifyInfer )
64 import TcTyClsDecls ( tcTyAndClassDecls )
66 import RnNames ( rnImports, exportsFromAvail, reportUnusedNames )
67 import RnIfaces ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate )
68 import RnHiFiles ( readIface, loadOldIface )
69 import RnEnv ( lookupSrcName, lookupOccRn,
70 ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs )
71 import RnExpr ( rnStmts, rnExpr )
72 import RnSource ( rnSrcDecls, rnExtCoreDecls, checkModDeprec, rnStats )
74 import OccName ( varName )
75 import CoreUnfold ( unfoldingTemplate )
76 import CoreSyn ( IdCoreRule, Bind(..) )
77 import PprCore ( pprIdRules, pprCoreBindings )
78 import TysWiredIn ( mkListTy, unitTy )
79 import ErrUtils ( mkDumpDoc, showPass )
80 import Id ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported )
81 import IdInfo ( GlobalIdDetails(..) )
82 import Var ( Var, setGlobalIdDetails )
83 import Module ( Module, moduleName, moduleUserString )
84 import Name ( Name, isExternalName, getSrcLoc, nameOccName )
85 import NameEnv ( delListFromNameEnv )
87 import TyCon ( tyConGenInfo )
88 import BasicTypes ( EP(..), RecFlag(..) )
89 import SrcLoc ( noSrcLoc )
91 import HscTypes ( PersistentCompilerState(..), InteractiveContext(..),
92 ModIface, ModDetails(..), ModGuts(..),
94 ModIface(..), ModDetails(..), IfaceDecls(..),
96 Deprecations(..), plusDeprecs,
98 GenAvailInfo(Avail), availsToNameSet,
100 TypeEnv, TyThing, typeEnvTyCons,
101 extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
102 extendLocalRdrEnv, emptyFixityEnv
105 import RdrName ( rdrEnvElts )
106 import RnHiFiles ( loadInterface )
107 import RnEnv ( mkGlobalRdrEnv, plusGlobalRdrEnv )
108 import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(..),
112 import Maybe ( catMaybes )
113 import Panic ( showException )
114 import List ( partition )
115 import Util ( sortLt )
120 %************************************************************************
122 Typecheck and rename a module
124 %************************************************************************
128 tcRnModule :: HscEnv -> PersistentCompilerState
130 -> IO (PersistentCompilerState, Maybe TcGblEnv)
132 tcRnModule hsc_env pcs
133 (HsModule this_mod _ exports import_decls local_decls mod_deprec loc)
134 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
136 initTc hsc_env pcs this_mod $ addSrcLoc loc $
137 do { -- Deal with imports; sets tcg_rdr_env, tcg_imports
138 (rdr_env, imports) <- rnImports import_decls ;
139 updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
140 tcg_imports = imports })
142 traceRn (text "rn1") ;
143 -- Fail if there are any errors so far
144 -- The error printing (if needed) takes advantage
145 -- of the tcg_env we have now set
148 traceRn (text "rn1a") ;
149 -- Rename and type check the declarations
150 (tcg_env, src_fvs) <- tcRnSrcDecls local_decls ;
151 setGblEnv tcg_env $ do {
152 traceRn (text "rn2") ;
155 (tcg_env, main_fvs) <- checkMain ;
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 traceRn (text "rn4") ;
168 -- Process the export list
169 export_avails <- exportsFromAvail exports ;
170 updGblEnv (\gbl -> gbl { tcg_exports = export_avails })
173 -- Get the supporting decls for the exports
174 -- This is important *only* to gether usage information
175 -- (see comments with MkIface.mkImportInfo for why)
176 -- For OneShot compilation we could just throw away the decls
177 -- but for Batch or Interactive we must put them in the type
178 -- envt because they've been removed from the holding pen
179 let { export_fvs = availsToNameSet export_avails } ;
180 tcg_env <- importSupportingDecls export_fvs ;
181 setGblEnv tcg_env $ do {
183 -- Report unused names
184 let { used_fvs = src_fvs `plusFV` main_fvs `plusFV` export_fvs } ;
185 reportUnusedNames tcg_env used_fvs ;
187 -- Dump output and return
194 %*********************************************************
196 \subsection{Closing up the interface decls}
198 %*********************************************************
200 Suppose we discover we don't need to recompile. Then we start from the
201 IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need.
205 -> PersistentCompilerState
206 -> ModIface -- Get the decls from here
207 -> IO (PersistentCompilerState, Maybe ModDetails)
208 -- Nothing <=> errors happened
209 tcRnIface hsc_env pcs
210 (ModIface {mi_module = mod, mi_decls = iface_decls})
211 = initTc hsc_env pcs mod $ do {
213 -- Get the supporting decls, and typecheck them all together
214 -- so that any mutually recursive types are done right
215 extra_decls <- slurpImpDecls needed ;
216 env <- typecheckIfaceDecls (decls ++ extra_decls) ;
218 returnM (ModDetails { md_types = tcg_type_env env,
219 md_insts = tcg_insts env,
220 md_rules = hsCoreRules (tcg_rules env)
221 -- All the rules from an interface are of the IfaceRuleOut form
224 rule_decls = dcl_rules iface_decls
225 inst_decls = dcl_insts iface_decls
226 tycl_decls = dcl_tycl iface_decls
227 decls = map RuleD rule_decls ++
228 map InstD inst_decls ++
230 needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets`
231 unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets`
232 unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets`
234 -- Data type decls with record selectors,
235 -- which may appear in the decls, need unpackCString
236 -- and friends. It's easier to just grab them right now.
238 hsCoreRules :: [TypecheckedRuleDecl] -> [IdCoreRule]
239 -- All post-typechecking Iface rules have the form IfaceRuleOut
240 hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules]
244 %************************************************************************
246 The interactive interface
248 %************************************************************************
251 tcRnStmt :: HscEnv -> PersistentCompilerState
252 -> InteractiveContext
254 -> IO (PersistentCompilerState,
255 Maybe (InteractiveContext, [Name], TypecheckedHsExpr))
256 -- The returned [Id] is the same as the input except for
257 -- ExprStmt, in which case the returned [Name] is [itName]
259 tcRnStmt hsc_env pcs ictxt rdr_stmt
260 = initTc hsc_env pcs iNTERACTIVE $
261 setInteractiveContext ictxt $ do {
263 -- Rename; use CmdLineMode because tcRnStmt is only used interactively
264 ((bound_names, [rn_stmt]), fvs) <- initRnInteractive ictxt
265 (rnStmts [rdr_stmt]) ;
266 traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
269 -- Suck in the supporting declarations and typecheck them
270 tcg_env <- importSupportingDecls (fvs `plusFV` implicitStmtFVs fvs) ;
271 -- NB: an earlier version deleted (rdrEnvElts local_env) from
272 -- the fvs. But (a) that isn't necessary, because previously
273 -- bound things in the local_env will be in the TypeEnv, and
274 -- the renamer doesn't re-slurp such things, and
275 -- (b) it's WRONG to delete them. Consider in GHCi:
276 -- Mod> let x = e :: T
277 -- Mod> let y = x + 3
278 -- We need to pass 'x' among the fvs to slurpImpDecls, so that
279 -- the latter can see that T is a gate, and hence import the Num T
280 -- instance decl. (See the InTypEnv case in RnIfaces.slurpSourceRefs.)
281 setGblEnv tcg_env $ do {
283 -- The real work is done here
284 ((bound_ids, tc_expr), lie) <- getLIE (tcUserStmt bound_names rn_stmt) ;
286 traceTc (text "tcs 1") ;
287 let { -- Make all the bound ids "global" ids, now that
288 -- they're notionally top-level bindings. This is
289 -- important: otherwise when we come to compile an expression
290 -- using these ids later, the byte code generator will consider
291 -- the occurrences to be free rather than global.
292 global_ids = map globaliseId bound_ids ;
293 globaliseId id = setGlobalIdDetails id VanillaGlobal ;
295 -- Update the interactive context
296 rn_env = ic_rn_local_env ictxt ;
297 type_env = ic_type_env ictxt ;
299 bound_names = map idName global_ids ;
300 new_rn_env = extendLocalRdrEnv rn_env bound_names ;
302 -- Remove any shadowed bindings from the type_env;
303 -- they are inaccessible but might, I suppose, cause
304 -- a space leak if we leave them there
305 shadowed = [ n | name <- bound_names,
306 let rdr_name = mkRdrUnqual (nameOccName name),
307 Just n <- [lookupRdrEnv rn_env rdr_name] ] ;
309 filtered_type_env = delListFromNameEnv type_env shadowed ;
310 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
312 new_ic = ictxt { ic_rn_local_env = new_rn_env,
313 ic_type_env = new_type_env }
316 dumpOptTcRn Opt_D_dump_tc
317 (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
318 text "Typechecked expr" <+> ppr tc_expr]) ;
320 returnM (new_ic, bound_names, tc_expr)
325 Here is the grand plan, implemented in tcUserStmt
327 What you type The IO [HValue] that hscStmt returns
328 ------------- ------------------------------------
329 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
332 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
335 expr (of IO type) ==> expr >>= \ v -> return [coerce HVal v]
336 [NB: result not printed] bindings: [it]
338 expr (of non-IO type, ==> let v = expr in print v >> return [coerce HVal v]
339 result showable) bindings: [it]
341 expr (of non-IO type,
342 result not showable) ==> error
346 ---------------------------
347 tcUserStmt :: [Name] -> RenamedStmt -> TcM ([Id], TypecheckedHsExpr)
348 tcUserStmt names (ExprStmt expr _ loc)
349 = ASSERT( null names )
350 newUnique `thenM` \ uniq ->
352 fresh_it = itName uniq
353 the_bind = FunMonoBind fresh_it False
354 [ mkSimpleMatch [] expr placeHolderType loc ] loc
356 tryTc_ (do { -- Try this if the other fails
357 traceTc (text "tcs 1b") ;
358 tc_stmts [fresh_it] [
359 LetStmt (MonoBind the_bind [] NonRecursive),
360 ExprStmt (HsApp (HsVar printName) (HsVar fresh_it))
361 placeHolderType loc] })
362 (do { -- Try this first
363 traceTc (text "tcs 1a") ;
364 tc_stmts [fresh_it] [BindStmt (VarPat fresh_it) expr loc] })
366 tcUserStmt names stmt
367 = tc_stmts names [stmt]
369 ---------------------------
371 = do { io_ids <- mappM tcLookupId
372 [returnIOName, failIOName, bindIOName, thenIOName] ;
373 ioTyCon <- tcLookupTyCon ioTyConName ;
374 res_ty <- newTyVarTy liftedTypeKind ;
376 return_id = head io_ids ; -- Rather gruesome
378 io_ty = (\ ty -> mkTyConApp ioTyCon [ty], res_ty) ;
380 -- mk_return builds the expression
381 -- returnIO @ [()] [coerce () x, .., coerce () z]
382 mk_return ids = HsApp (TyApp (HsVar return_id) [mkListTy unitTy])
383 (ExplicitList unitTy (map mk_item ids)) ;
385 mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy])
388 -- OK, we're ready to typecheck the stmts
389 traceTc (text "tcs 2") ;
390 ((ids, tc_stmts), lie) <-
391 getLIE $ tcStmtsAndThen combine (DoCtxt DoExpr) io_ty stmts $
393 -- Look up the names right in the middle,
394 -- where they will all be in scope
395 ids <- mappM tcLookupId names ;
396 return (ids, [ResultStmt (mk_return ids) noSrcLoc])
399 -- Simplify the context right here, so that we fail
400 -- if there aren't enough instances. Notably, when we see
402 -- we use tryTc_ to try it <- e
403 -- and then let it = e
404 -- It's the simplify step that rejects the first.
405 traceTc (text "tcs 3") ;
406 const_binds <- tcSimplifyTop lie ;
408 -- Build result expression and zonk it
409 let { expr = mkHsLet const_binds $
410 HsDo DoExpr tc_stmts io_ids
411 (mkTyConApp ioTyCon [mkListTy unitTy]) noSrcLoc } ;
412 zonked_expr <- zonkTopExpr expr ;
413 zonked_ids <- mappM zonkIdBndr ids ;
415 return (zonked_ids, zonked_expr)
418 combine stmt (ids, stmts) = (ids, stmt:stmts)
422 tcRnExpr just finds the type of an expression
425 tcRnExpr :: HscEnv -> PersistentCompilerState
426 -> InteractiveContext
428 -> IO (PersistentCompilerState, Maybe Type)
429 tcRnExpr hsc_env pcs ictxt rdr_expr
430 = initTc hsc_env pcs iNTERACTIVE $
431 setInteractiveContext ictxt $ do {
433 (rn_expr, fvs) <- initRnInteractive ictxt (rnExpr rdr_expr) ;
436 -- Suck in the supporting declarations and typecheck them
437 tcg_env <- importSupportingDecls (fvs `plusFV` ubiquitousNames) ;
438 setGblEnv tcg_env $ do {
440 -- Now typecheck the expression;
441 -- it might have a rank-2 type (e.g. :t runST)
442 -- Hence the hole type (c.f. TcExpr.tcExpr_id)
443 ((tc_expr, res_ty), lie) <- getLIE (tcExpr_id rn_expr) ;
444 ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
445 tcSimplifyTop lie_top ;
447 let { all_expr_ty = mkForAllTys qtvs $
448 mkFunTys (map idType dict_ids) $
450 zonkTcType all_expr_ty
453 smpl_doc = ptext SLIT("main expression")
458 tcRnThing :: HscEnv -> PersistentCompilerState
459 -> InteractiveContext
461 -> IO (PersistentCompilerState, Maybe [TyThing])
462 -- Look up a RdrName and return all the TyThings it might be
463 -- We treat a capitalised RdrName as both a data constructor
464 -- and as a type or class constructor; hence we return up to two results
465 tcRnThing hsc_env pcs ictxt rdr_name
466 = initTc hsc_env pcs iNTERACTIVE $
467 setInteractiveContext ictxt $ do {
469 -- If the identifier is a constructor (begins with an
470 -- upper-case letter), then we need to consider both
471 -- constructor and type class identifiers.
472 let { rdr_names = dataTcOccs rdr_name } ;
474 (msgs_s, mb_names) <- initRnInteractive ictxt
475 (mapAndUnzipM (tryM . lookupOccRn) rdr_names) ;
476 let { names = catMaybes mb_names } ;
479 do { addMessages (head msgs_s) ; failM }
482 mapM_ addMessages msgs_s ; -- Add deprecation warnings
483 mapM tcLookupGlobal names -- and lookup up the entities
489 setInteractiveContext :: InteractiveContext -> TcRn m a -> TcRn m a
490 setInteractiveContext icxt thing_inside
491 = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_`
492 updGblEnv (\ env -> env { tcg_rdr_env = ic_rn_gbl_env icxt,
493 tcg_type_env = ic_type_env icxt })
496 initRnInteractive :: InteractiveContext -> RnM a -> TcM a
497 -- Set the local RdrEnv from the interactive context
498 initRnInteractive ictxt rn_thing
499 = initRn CmdLineMode $
500 setLocalRdrEnv (ic_rn_local_env ictxt) $
504 %************************************************************************
506 Type-checking external-core modules
508 %************************************************************************
511 tcRnExtCore :: HscEnv -> PersistentCompilerState
513 -> IO (PersistentCompilerState, Maybe ModGuts)
514 -- Nothing => some error occurred
516 tcRnExtCore hsc_env pcs
517 (HsModule this_mod _ _ _ local_decls _ loc)
518 -- Rename the (Core) module. It's a bit like an interface
519 -- file: all names are original names
520 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
522 initTc hsc_env pcs this_mod $ addSrcLoc loc $ do {
524 -- Rename the source, only in interface mode.
525 -- rnSrcDecls handles fixity decls etc too, which won't occur
526 -- but that doesn't matter
527 (rn_local_decls, fvs) <- initRn (InterfaceMode this_mod)
528 (rnExtCoreDecls local_decls) ;
531 -- Get the supporting decls, and typecheck them all together
532 -- so that any mutually recursive types are done right
533 extra_decls <- slurpImpDecls fvs ;
534 tcg_env <- typecheckIfaceDecls (rn_local_decls ++ extra_decls) ;
535 setGblEnv tcg_env $ do {
537 -- Now the core bindings
538 core_prs <- tcCoreBinds [d | CoreD d <- rn_local_decls] ;
539 tcExtendGlobalValEnv (map fst core_prs) $ do {
543 bndrs = map fst core_prs ;
544 my_exports = map (Avail . idName) bndrs ;
545 -- ToDo: export the data types also?
547 final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
549 mod_guts = ModGuts { mg_module = this_mod,
550 mg_usages = [], -- ToDo: compute usage
551 mg_dir_imps = [], -- ??
552 mg_exports = my_exports,
553 mg_types = final_type_env,
554 mg_insts = tcg_insts tcg_env,
555 mg_rules = hsCoreRules (tcg_rules tcg_env),
556 mg_binds = [Rec core_prs],
559 mg_rdr_env = emptyGlobalRdrEnv,
560 mg_fix_env = emptyFixityEnv,
561 mg_deprecs = NoDeprecs,
565 tcCoreDump mod_guts ;
572 %************************************************************************
574 Type-checking the top level of a module
576 %************************************************************************
578 tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars)
579 -- Returns the variables free in the decls
580 tcRnSrcDecls [] = getGblEnv
582 = do { let { (first_group, group_tail) = findSplice ds } ;
584 tcg_env <- tcRnGroup first_group ;
587 Nothing -> return gbl_env
588 Just (splice_expr, rest_ds) -> do {
590 setGblEnv tcg_env $ do {
592 -- Rename the splice expression, and get its supporting decls
593 (rn_splice_expr, fvs) <- initRn SourceMode (rnExpr splice_expr) ;
594 tcg_env <- importSupportingDecls fvs ;
595 setGblEnv tcg_env $ do {
597 -- Execute the splice
598 spliced_decls <- tcSpliceDecls rn_splice_expr ;
600 -- Glue them on the front of the remaining decls and loop
601 tcRnSrcDeclsDecls (splice_decls ++ rest_ds)
604 findSplice :: [HsDecl a] -> ([HsDecl a], Maybe (HsExpr a, [HsDecl a]))
605 findSplice [] = ([], Nothing)
606 findSplice (SpliceD e : ds) = ([], Just (e, ds))
607 findSplice (d : ds) = (d:gs, rest)
609 (gs, rest) = findSplice ds
612 %************************************************************************
614 Type-checking the top level of a module
616 %************************************************************************
618 tcRnSrcDecls takes a bunch of top-level source-code declarations, and
620 * gets supporting declarations from interface files
623 * and augments the TcGblEnv with the results
625 In Template Haskell it may be called repeatedly for each group of
626 declarations. It expects there to be an incoming TcGblEnv in the
627 monad; it augments it and returns the new TcGblEnv.
630 tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, FreeVars)
631 -- Returns the variables free in the decls
633 = do { -- Rename the declarations
634 (tcg_env, rn_decls, src_fvs) <- rnTopSrcDecls decls ;
635 setGblEnv tcg_env $ do {
637 -- Typecheck the declarations
638 tcg_env <- tcTopSrcDecls rn_decls ;
639 return (tcg_env, src_fvs)
642 ------------------------------------------------
643 rnTopSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, [RenamedHsDecl], FreeVars)
645 = do { (tcg_env, rn_src_decls, src_fvs) <- initRn SourceMode (rnSrcDecls decls) ;
646 setGblEnv tcg_env $ do {
650 -- Import consquential imports
651 rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ;
652 let { rn_decls = rn_src_decls ++ rn_imp_decls } ;
654 -- Dump trace of renaming part
655 rnDump (vcat (map ppr rn_decls)) ;
656 rnStats rn_imp_decls ;
658 return (tcg_env, rn_decls, src_fvs)
661 ------------------------------------------------
662 tcTopSrcDecls :: [RenamedHsDecl] -> TcM TcGblEnv
663 tcTopSrcDecls rn_decls
664 = fixM (\ unf_env -> do {
665 -- Loop back the final environment, including the fully zonked
666 -- versions of bindings from this module. In the presence of mutual
667 -- recursion, interface type signatures may mention variables defined
668 -- in this module, which is why the knot is so big
671 ((tcg_env, binds, rules, fords), lie) <- getLIE (
672 tc_src_decls unf_env rn_decls
675 -- tcSimplifyTop deals with constant or ambiguous InstIds.
676 -- How could there be ambiguous ones? They can only arise if a
677 -- top-level decl falls under the monomorphism
678 -- restriction, and no subsequent decl instantiates its
679 -- type. (Usually, ambiguous type variables are resolved
680 -- during the generalisation step.)
681 traceTc (text "Tc8") ;
682 inst_binds <- setGblEnv tcg_env (tcSimplifyTop lie) ;
683 -- The setGblEnv exposes the instances to tcSimplifyTop
685 -- Backsubstitution. This must be done last.
686 -- Even tcSimplifyTop may do some unification.
687 traceTc (text "Tc9") ;
688 (ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
691 let { tcg_env' = tcg_env { tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids,
692 tcg_binds = tcg_binds tcg_env `andMonoBinds` binds',
693 tcg_rules = tcg_rules tcg_env ++ rules',
694 tcg_fords = tcg_fords tcg_env ++ fords' } } ;
699 tc_src_decls unf_env decls
700 = do { -- Type-check the type and class decls, and all imported decls
701 traceTc (text "Tc2") ;
702 tcg_env <- tcTyClDecls unf_env tycl_decls ;
703 setGblEnv tcg_env $ do {
705 -- Source-language instances, including derivings,
706 -- and import the supporting declarations
707 traceTc (text "Tc3") ;
708 (tcg_env, inst_infos, deriv_binds, fvs) <- tcInstDecls1 tycl_decls inst_decls ;
709 setGblEnv tcg_env $ do {
710 tcg_env <- importSupportingDecls fvs ;
711 setGblEnv tcg_env $ do {
713 -- Foreign import declarations next. No zonking necessary
714 -- here; we can tuck them straight into the global environment.
715 traceTc (text "Tc4") ;
716 (fi_ids, fi_decls) <- tcForeignImports decls ;
717 tcExtendGlobalValEnv fi_ids $
718 updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls })
721 -- Default declarations
722 traceTc (text "Tc4a") ;
723 default_tys <- tcDefaults decls ;
724 updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
726 -- Value declarations next
727 -- We also typecheck any extra binds that came out
728 -- of the "deriving" process
729 traceTc (text "Tc5") ;
730 (tc_val_binds, lcl_env) <- tcTopBinds (val_binds `ThenBinds` deriv_binds) ;
731 setLclTypeEnv lcl_env $ do {
733 -- Second pass over class and instance declarations,
734 -- plus rules and foreign exports, to generate bindings
735 traceTc (text "Tc6") ;
736 (cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ;
737 tcExtendGlobalValEnv dm_ids $ do {
738 inst_binds <- tcInstDecls2 inst_infos ;
739 showLIE "after instDecls2" ;
742 -- They need to be zonked, so we return them
743 traceTc (text "Tc7") ;
744 (foe_binds, foe_decls) <- tcForeignExports decls ;
747 -- Need to partition them because the source rules
748 -- must be zonked before adding them to tcg_rules
749 -- NB: built-in rules come in as IfaceRuleOut's, and
750 -- get added to tcg_rules right here by tcExtendRules
751 rules <- tcRules rule_decls ;
752 let { (src_rules, iface_rules) = partition isSrcRule rules } ;
753 tcExtendRules iface_rules $ do {
756 tcg_env <- getGblEnv ;
757 let { all_binds = tc_val_binds `AndMonoBinds`
758 inst_binds `AndMonoBinds`
759 cls_dm_binds `AndMonoBinds`
762 return (tcg_env, all_binds, src_rules, foe_decls)
765 tycl_decls = [d | TyClD d <- decls]
766 rule_decls = [d | RuleD d <- decls]
767 inst_decls = [d | InstD d <- decls]
768 val_decls = [d | ValD d <- decls]
769 val_binds = foldr ThenBinds EmptyBinds val_decls
773 tcTyClDecls :: RecTcGblEnv
777 -- tcTyClDecls deals with
778 -- type and class decls (some source, some imported)
779 -- interface signatures (checked lazily)
781 -- It returns the TcGblEnv for this module, and side-effects the
782 -- persistent compiler state to reflect the things imported from
785 tcTyClDecls unf_env tycl_decls
786 -- (unf_env :: RecTcGblEnv) is used for type-checking interface pragmas
787 -- which is done lazily [ie failure just drops the pragma
788 -- without having any global-failure effect].
791 -- tcTyAndClassDecls recovers internally, but if anything gave rise to
792 -- an error we'd better stop now, to avoid a cascade
794 traceTc (text "TyCl1") `thenM_`
795 tcTyAndClassDecls tycl_decls `thenM` \ tycl_things ->
796 tcExtendGlobalEnv tycl_things $
798 -- Interface type signatures
799 -- We tie a knot so that the Ids read out of interfaces are in scope
800 -- when we read their pragmas.
801 -- What we rely on is that pragmas are typechecked lazily; if
802 -- any type errors are found (ie there's an inconsistency)
803 -- we silently discard the pragma
804 traceTc (text "TyCl2") `thenM_`
805 tcInterfaceSigs unf_env tycl_decls `thenM` \ sig_ids ->
806 tcExtendGlobalValEnv sig_ids $
808 getGblEnv -- Return the TcLocals environment
813 %************************************************************************
815 Load the old interface file for this module (unless
816 we have it aleady), and check whether it is up to date
819 %************************************************************************
822 checkOldIface :: HscEnv
823 -> PersistentCompilerState
825 -> FilePath -- Where the interface file is
826 -> Bool -- Source unchanged
827 -> Maybe ModIface -- Old interface from compilation manager, if any
828 -> IO (PersistentCompilerState, Maybe (RecompileRequired, Maybe ModIface))
829 -- Nothing <=> errors happened
831 checkOldIface hsc_env pcs mod iface_path source_unchanged maybe_iface
832 = do { showPass (hsc_dflags hsc_env)
833 ("Checking old interface for " ++ moduleUserString mod) ;
835 initTc hsc_env pcs mod
836 (check_old_iface iface_path source_unchanged maybe_iface)
839 check_old_iface iface_path source_unchanged maybe_iface
840 = -- CHECK WHETHER THE SOURCE HAS CHANGED
841 ifM (not source_unchanged)
842 (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
845 -- If the source has changed and we're in interactive mode, avoid reading
846 -- an interface; just return the one we might have been supplied with.
847 getGhciMode `thenM` \ ghci_mode ->
848 if (ghci_mode == Interactive) && not source_unchanged then
849 returnM (outOfDate, maybe_iface)
853 Just old_iface -> -- Use the one we already have
854 checkVersions source_unchanged old_iface `thenM` \ recomp ->
855 returnM (recomp, Just old_iface)
857 Nothing -- Try and read it from a file
858 -> getModule `thenM` \ this_mod ->
859 readIface this_mod iface_path False `thenM` \ read_result ->
861 Left err -> -- Old interface file not found, or garbled; give up
863 text "Cannot read old interface file:"
864 $$ nest 4 (text (showException err))) `thenM_`
865 returnM (outOfDate, Nothing)
867 Right parsed_iface ->
868 initRn (InterfaceMode this_mod)
869 (loadOldIface parsed_iface) `thenM` \ m_iface ->
870 checkVersions source_unchanged m_iface `thenM` \ recomp ->
871 returnM (recomp, Just m_iface)
875 %************************************************************************
877 Type-check and rename supporting declarations
878 This is used to deal with the free vars of a splice,
879 or derived code: slurp in the necessary declarations,
880 typecheck them, and add them to the EPS
882 %************************************************************************
885 importSupportingDecls :: FreeVars -> TcM TcGblEnv
886 -- Completely deal with the supporting imports needed
887 -- by the specified free-var set
888 importSupportingDecls fvs
889 = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ;
890 decls <- slurpImpDecls fvs ;
891 traceRn (text "...namely:" <+> vcat (map ppr decls)) ;
892 typecheckIfaceDecls decls }
894 typecheckIfaceDecls :: [RenamedHsDecl] -> TcM TcGblEnv
895 -- The decls are all interface-file declarations
896 -- Usually they are all from other modules, but when we are reading
897 -- this module's interface from a file, it's possible that some of
898 -- them are for the module being compiled.
899 -- That is why the tcExtendX functions need to do partitioning.
901 -- If all the decls are from other modules, the returned TcGblEnv
902 -- will have an empty tc_genv, but its tc_inst_env and tc_ist
903 -- caches may have been augmented.
904 typecheckIfaceDecls decls
905 = do { let { tycl_decls = [d | TyClD d <- decls] ;
906 inst_decls = [d | InstD d <- decls] ;
907 rule_decls = [d | RuleD d <- decls] } ;
909 -- Typecheck the type, class, and interface-sig decls
910 tcg_env <- fixM (\ unf_env -> tcTyClDecls unf_env tycl_decls) ;
911 setGblEnv tcg_env $ do {
913 -- Typecheck the instance decls, and rules
914 -- Note that imported dictionary functions are already
915 -- in scope from the preceding tcTyClDecls
916 tcIfaceInstDecls inst_decls `thenM` \ dfuns ->
917 tcExtendInstEnv dfuns $
918 tcRules rule_decls `thenM` \ rules ->
919 tcExtendRules rules $
921 getGblEnv -- Return the environment
927 %*********************************************************
929 mkGlobalContext: make up an interactive context
931 Used for initialising the lexical environment
932 of the interactive read-eval-print loop
934 %*********************************************************
939 :: HscEnv -> PersistentCompilerState
940 -> [Module] -- Expose these modules' top-level scope
941 -> [Module] -- Expose these modules' exports only
942 -> IO (PersistentCompilerState, Maybe GlobalRdrEnv)
944 mkGlobalContext hsc_env pcs toplevs exports
945 = initTc hsc_env pcs iNTERACTIVE $ do {
947 toplev_envs <- mappM getTopLevScope toplevs ;
948 export_envs <- mappM getModuleExports exports ;
949 returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv
950 (toplev_envs ++ export_envs))
953 getTopLevScope :: Module -> TcRn m GlobalRdrEnv
955 = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
956 case mi_globals iface of
957 Nothing -> panic "getTopLevScope"
958 Just env -> returnM env }
960 getModuleExports :: Module -> TcRn m GlobalRdrEnv
962 = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
963 returnM (foldl add emptyGlobalRdrEnv (mi_exports iface)) }
965 prov_fn n = NonLocalDef ImplicitImport
967 = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs)
969 contextDoc = text "context for compiling statements"
975 -> PersistentCompilerState -- IN: persistent compiler state
976 -> Module -- module to inspect
977 -> Bool -- grab just the exports, or the whole toplev
978 -> IO (PersistentCompilerState, Maybe [TyThing])
980 getModuleContents hsc_env pcs mod exports_only
981 = initTc hsc_env pcs iNTERACTIVE $ do {
983 -- Load the interface if necessary (a home module will certainly
984 -- alraedy be loaded, but a package module might not be)
985 iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
987 let { export_names = availsToNameSet export_avails ;
988 export_avails = [ avail | (mn, avails) <- mi_exports iface,
989 avail <- avails ] } ;
991 all_names <- if exports_only then
993 else case mi_globals iface of {
995 return (get_locals rdr_env) ;
997 Nothing -> do { addErr (noRdrEnvErr mod) ;
998 return export_names } } ;
999 -- Invariant; we only have (not exports_only)
1000 -- for a home module so it must already be in the HIT
1001 -- So the Nothing case is a bug
1003 env <- importSupportingDecls all_names ;
1004 setGblEnv env (mappM tcLookupGlobal (nameSetToList all_names))
1007 -- Grab all the things from the global env that are locally def'd
1008 get_locals rdr_env = mkNameSet [ gre_name gre
1009 | elts <- rdrEnvElts rdr_env,
1012 -- Make a set because a name is often in the envt in
1013 -- both qualified and unqualified forms
1015 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
1016 <+> quotes (ppr mod)
1020 %************************************************************************
1024 %************************************************************************
1028 = do { ghci_mode <- getGhciMode ;
1029 tcg_env <- getGblEnv ;
1030 check_main ghci_mode tcg_env
1033 check_main ghci_mode tcg_env
1034 -- If we are in module Main, check that 'main' is defined.
1035 -- It may be imported from another module, in which case
1036 -- we have to drag in its.
1038 -- Also form the definition
1039 -- $main = runIO main
1040 -- so we need to slurp in runIO too.
1042 -- ToDo: We have to return the main_name separately, because it's a
1043 -- bona fide 'use', and should be recorded as such, but the others
1046 -- Blimey: a whole page of code to do this...
1048 | mod_name /= mAIN_Name
1049 = return (tcg_env, emptyFVs)
1051 | not (main_RDR_Unqual `elemRdrEnv` rdr_env)
1052 = do { complain_no_main; return (tcg_env, emptyFVs) }
1055 = do { -- Check that 'main' is in scope
1056 -- It might be imported from another module!
1057 main_name <- lookupSrcName main_RDR_Unqual ;
1060 tcg_env <- importSupportingDecls (unitFV runIOName) ;
1061 setGblEnv tcg_env $ do {
1063 -- $main :: IO () = runIO main
1064 let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ;
1066 (main_bind, top_lie) <- getLIE (
1067 addSrcLoc (getSrcLoc main_name) $
1068 addErrCtxt mainCtxt $ do {
1069 (main_expr, ty) <- tcExpr_id rhs ;
1070 let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) } ;
1071 return (VarMonoBind dollar_main_id main_expr)
1074 inst_binds <- tcSimplifyTop top_lie ;
1076 (ids, binds') <- zonkTopBinds (main_bind `andMonoBinds` inst_binds) ;
1078 let { tcg_env' = tcg_env {
1079 tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids,
1080 tcg_binds = tcg_binds tcg_env `andMonoBinds` binds' } } ;
1082 return (tcg_env', unitFV main_name)
1085 mod_name = moduleName (tcg_mod tcg_env)
1086 rdr_env = tcg_rdr_env tcg_env
1088 main_RDR_Unqual :: RdrName
1089 main_RDR_Unqual = mkUnqual varName FSLIT("main")
1090 -- Don't get a RdrName from PrelNames.mainName, because
1091 -- nameRdrNamegets an Orig RdrName, and we want a Qual or Unqual one.
1092 -- An Unqual one will do just fine
1094 complain_no_main | ghci_mode == Interactive = return ()
1095 | otherwise = addErr noMainMsg
1096 -- In interactive mode, don't worry about the absence of 'main'
1098 mainCtxt = ptext SLIT("When checking the type of 'main'")
1099 noMainMsg = ptext SLIT("No 'main' defined in module Main")
1103 %************************************************************************
1107 %************************************************************************
1110 rnDump :: SDoc -> TcRn m ()
1111 -- Dump, with a banner, if -ddump-rn
1112 rnDump doc = dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc)
1114 tcDump :: TcGblEnv -> TcRn m ()
1116 = do { dflags <- getDOpts ;
1118 -- Dump short output if -ddump-types or -ddump-tc
1119 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1120 (dumpTcRn short_dump) ;
1122 -- Dump bindings if -ddump-tc
1123 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1126 short_dump = pprTcGblEnv env
1127 full_dump = ppr (tcg_binds env)
1128 -- NB: foreign x-d's have undefined's in their types;
1129 -- hence can't show the tc_fords
1132 = do { dflags <- getDOpts ;
1133 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1134 (dumpTcRn (pprModGuts mod_guts)) ;
1136 -- Dump bindings if -ddump-tc
1137 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1139 full_dump = pprCoreBindings (mg_binds mod_guts)
1141 -- It's unpleasant having both pprModGuts and pprModDetails here
1142 pprTcGblEnv :: TcGblEnv -> SDoc
1143 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1144 tcg_insts = dfun_ids,
1145 tcg_rules = rules })
1146 = vcat [ ppr_types dfun_ids type_env
1147 , ppr_insts dfun_ids
1148 , vcat (map ppr rules)
1149 , ppr_gen_tycons (typeEnvTyCons type_env)]
1151 pprModGuts :: ModGuts -> SDoc
1152 pprModGuts (ModGuts { mg_types = type_env,
1154 = vcat [ ppr_types [] type_env,
1158 ppr_types :: [Var] -> TypeEnv -> SDoc
1159 ppr_types dfun_ids type_env
1160 = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1162 ids = [id | id <- typeEnvIds type_env, want_sig id]
1163 want_sig id | opt_PprStyle_Debug = True
1164 | otherwise = isLocalId id &&
1165 isExternalName (idName id) &&
1166 not (id `elem` dfun_ids)
1167 -- isLocalId ignores data constructors, records selectors etc.
1168 -- The isExternalName ignores local dictionary and method bindings
1169 -- that the type checker has invented. Top-level user-defined things
1170 -- have External names.
1172 ppr_insts :: [Var] -> SDoc
1173 ppr_insts [] = empty
1174 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1176 ppr_sigs :: [Var] -> SDoc
1178 -- Print type signatures
1179 -- Convert to HsType so that we get source-language style printing
1180 -- And sort by RdrName
1181 = vcat $ map ppr_sig $ sortLt lt_sig $
1182 [ (getRdrName id, toHsType (idType id))
1185 lt_sig (n1,_) (n2,_) = n1 < n2
1186 ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t
1189 ppr_rules :: [IdCoreRule] -> SDoc
1190 ppr_rules [] = empty
1191 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1192 nest 4 (pprIdRules rs),
1195 ppr_gen_tycons [] = empty
1196 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
1197 vcat (map ppr_gen_tycon tcs),
1201 -- x&y are now Id's, not CoreExpr's
1203 | Just ep <- tyConGenInfo tycon
1204 = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
1206 | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
1209 = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
1210 ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
1211 ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to))
1214 (_,from_tau) = tcSplitForAllTys (idType from)