2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcModule]{Typechecking a whole module}
9 mkExportEnv, getModuleContents, tcRnStmt,
10 tcRnThing, tcRnExpr, tcRnType,
17 #include "HsVersions.h"
20 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
23 import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
24 import DriverState ( v_MainModIs, v_MainFunIs )
25 import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..),
26 nlHsApp, nlHsVar, pprLHsBinds )
27 import RdrHsSyn ( findSplice )
29 import PrelNames ( runIOName, rootMainName, mAIN_Name,
31 import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv,
33 import TcHsSyn ( zonkTopDecls )
34 import TcExpr ( tcInferRho )
36 import TcType ( tidyTopType, isUnLiftedType )
37 import Inst ( showLIE )
38 import TcBinds ( tcTopBinds )
39 import TcDefaults ( tcDefaults )
40 import TcEnv ( tcExtendGlobalValEnv )
41 import TcRules ( tcRules )
42 import TcForeign ( tcForeignImports, tcForeignExports )
43 import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
44 import TcIface ( tcExtCoreBindings )
45 import TcSimplify ( tcSimplifyTop )
46 import TcTyClsDecls ( tcTyAndClassDecls )
47 import LoadIface ( loadOrphanModules )
48 import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
49 reportUnusedNames, reportDeprecations )
50 import RnEnv ( lookupSrcOcc_maybe )
51 import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec )
52 import PprCore ( pprIdRules, pprCoreBindings )
53 import CoreSyn ( IdCoreRule, bindersOfBinds )
54 import ErrUtils ( Messages, mkDumpDoc, showPass )
55 import Id ( mkExportedLocalId, isLocalId, idName, idType )
57 import Module ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts )
58 import OccName ( mkVarOcc )
59 import Name ( Name, isExternalName, getSrcLoc, getOccName, nameSrcLoc )
61 import TyCon ( tyConHasGenerics )
62 import SrcLoc ( SrcLoc, srcLocSpan, Located(..), noLoc )
64 import HscTypes ( ModGuts(..), HscEnv(..),
65 GhciMode(..), Dependencies(..), noDependencies,
66 Deprecs( NoDeprecs ), plusDeprecs,
67 ForeignStubs(NoStubs), TypeEnv,
68 extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
72 import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
73 LStmt, LHsExpr, LHsType,
74 collectStmtsBinders, mkSimpleMatch, placeHolderType,
75 nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat )
76 import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
77 Provenance(..), ImportSpec(..),
78 lookupLocalRdrEnv, extendLocalRdrEnv )
79 import RnSource ( addTcgDUs )
80 import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs )
81 import TcHsType ( kcHsType )
82 import TcExpr ( tcCheckRho )
83 import TcMType ( zonkTcType )
84 import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) )
85 import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer )
86 import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType )
87 import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
88 import RnTypes ( rnLHsType )
89 import Inst ( tcStdSyntaxName )
90 import RnExpr ( rnStmts, rnLExpr )
91 import RnNames ( exportsToAvails )
92 import LoadIface ( loadSrcInterface )
93 import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
94 IfaceExtName(..), IfaceConDecls(..),
96 import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
97 import Id ( Id, isImplicitId, globalIdDetails )
98 import FieldLabel ( fieldLabelTyCon )
99 import MkId ( unsafeCoerceId )
100 import DataCon ( dataConTyCon )
101 import TysWiredIn ( mkListTy, unitTy )
102 import IdInfo ( GlobalIdDetails(..) )
103 import SrcLoc ( interactiveSrcLoc, unLoc )
105 import Var ( globaliseId )
106 import Name ( nameOccName, nameModuleName )
107 import NameEnv ( delListFromNameEnv )
108 import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName )
109 import Module ( ModuleName, lookupModuleEnvByName )
110 import HscTypes ( InteractiveContext(..),
111 HomeModInfo(..), typeEnvElts,
112 TyThing(..), availName, availNames, icPrintUnqual,
113 ModIface(..), ModDetails(..) )
114 import BasicTypes ( RecFlag(..), Fixity )
115 import Bag ( unitBag )
116 import ListSetOps ( removeDups )
117 import Panic ( ghcError, GhcException(..) )
120 import FastString ( mkFastString )
121 import Util ( sortLt )
122 import Bag ( unionBags, snocBag )
124 import Maybe ( isJust )
129 %************************************************************************
131 Typecheck and rename a module
133 %************************************************************************
138 -> Located (HsModule RdrName)
139 -> IO (Messages, Maybe TcGblEnv)
141 tcRnModule hsc_env (L loc (HsModule maybe_mod exports
142 import_decls local_decls mod_deprec))
143 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
145 let { this_mod = case maybe_mod of
146 Nothing -> mkHomeModule mAIN_Name
147 -- 'module M where' is omitted
148 Just (L _ mod) -> mod } ;
151 initTc hsc_env this_mod $
153 do { -- Deal with imports; sets tcg_rdr_env, tcg_imports
154 (rdr_env, imports) <- rnImports import_decls ;
155 updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
156 tcg_imports = tcg_imports gbl `plusImportAvails` imports })
158 traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
159 -- Fail if there are any errors so far
160 -- The error printing (if needed) takes advantage
161 -- of the tcg_env we have now set
164 -- Load any orphan-module interfaces, so that
165 -- their rules and instance decls will be found
166 loadOrphanModules (imp_orphs imports) ;
168 traceRn (text "rn1a") ;
169 -- Rename and type check the declarations
170 tcg_env <- tcRnSrcDecls local_decls ;
171 setGblEnv tcg_env $ do {
173 traceRn (text "rn3") ;
175 -- Report the use of any deprecated things
176 -- We do this before processsing the export list so
177 -- that we don't bleat about re-exporting a deprecated
178 -- thing (especially via 'module Foo' export item)
179 -- Only uses in the body of the module are complained about
180 reportDeprecations tcg_env ;
182 -- Process the export list
183 exports <- exportsFromAvail (isJust maybe_mod) exports ;
185 {- Jan 04: I don't think this is necessary any more; usage info is derived from tcg_dus
186 -- Get any supporting decls for the exports that have not already
187 -- been sucked in for the declarations in the body of the module.
188 -- (This can happen if something is imported only to be re-exported.)
190 -- Importing these supporting declarations is required
191 -- *only* to gether usage information
192 -- (see comments with MkIface.mkImportInfo for why)
193 -- We don't need the results, but sucking them in may side-effect
194 -- the ExternalPackageState, apart from recording usage
195 mappM (tcLookupGlobal . availName) export_avails ;
198 -- Check whether the entire module is deprecated
199 -- This happens only once per module
200 let { mod_deprecs = checkModDeprec mod_deprec } ;
202 -- Add exports and deprecations to envt
203 let { final_env = tcg_env { tcg_exports = exports,
204 tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
205 tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
207 -- A module deprecation over-rides the earlier ones
210 -- Report unused names
211 reportUnusedNames final_env ;
213 -- Dump output and return
220 %************************************************************************
222 The interactive interface
224 %************************************************************************
229 -> InteractiveContext
231 -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
232 -- The returned [Name] is the same as the input except for
233 -- ExprStmt, in which case the returned [Name] is [itName]
235 -- The returned TypecheckedHsExpr is of type IO [ () ],
236 -- a list of the bound values, coerced to ().
238 tcRnStmt hsc_env ictxt rdr_stmt
239 = initTcPrintErrors hsc_env iNTERACTIVE $
240 setInteractiveContext ictxt $ do {
242 -- Rename; use CmdLineMode because tcRnStmt is only used interactively
243 ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ;
244 traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
247 -- The real work is done here
248 (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
250 traceTc (text "tcs 1") ;
251 let { -- Make all the bound ids "global" ids, now that
252 -- they're notionally top-level bindings. This is
253 -- important: otherwise when we come to compile an expression
254 -- using these ids later, the byte code generator will consider
255 -- the occurrences to be free rather than global.
256 global_ids = map (globaliseId VanillaGlobal) bound_ids ;
258 -- Update the interactive context
259 rn_env = ic_rn_local_env ictxt ;
260 type_env = ic_type_env ictxt ;
262 bound_names = map idName global_ids ;
263 new_rn_env = extendLocalRdrEnv rn_env bound_names ;
265 -- Remove any shadowed bindings from the type_env;
266 -- they are inaccessible but might, I suppose, cause
267 -- a space leak if we leave them there
268 shadowed = [ n | name <- bound_names,
269 let rdr_name = mkRdrUnqual (nameOccName name),
270 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
272 filtered_type_env = delListFromNameEnv type_env shadowed ;
273 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
275 new_ic = ictxt { ic_rn_local_env = new_rn_env,
276 ic_type_env = new_type_env }
279 dumpOptTcRn Opt_D_dump_tc
280 (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
281 text "Typechecked expr" <+> ppr tc_expr]) ;
283 returnM (new_ic, bound_names, tc_expr)
288 Here is the grand plan, implemented in tcUserStmt
290 What you type The IO [HValue] that hscStmt returns
291 ------------- ------------------------------------
292 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
295 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
298 expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it]
299 [NB: result not printed] bindings: [it]
301 expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it]
302 result showable) bindings: [it]
304 expr (of non-IO type,
305 result not showable) ==> error
309 ---------------------------
310 tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
311 tcUserStmt (L _ (ExprStmt expr _))
312 = newUnique `thenM` \ uniq ->
314 fresh_it = itName uniq
315 the_bind = noLoc $ FunBind (noLoc fresh_it) False
316 [ mkSimpleMatch [] expr placeHolderType ]
318 tryTcLIE_ (do { -- Try this if the other fails
319 traceTc (text "tcs 1b") ;
321 nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
322 nlExprStmt (nlHsApp (nlHsVar printName)
325 (do { -- Try this first
326 traceTc (text "tcs 1a") ;
327 tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] })
329 tcUserStmt stmt = tc_stmts [stmt]
331 ---------------------------
333 = do { ioTyCon <- tcLookupTyCon ioTyConName ;
335 ret_ty = mkListTy unitTy ;
336 io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
338 names = map unLoc (collectStmtsBinders stmts) ;
340 stmt_ctxt = SC { sc_what = DoExpr,
342 sc_body = check_body,
345 check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ;
346 check_body body = tcCheckRho body io_ret_ty ;
348 -- mk_return builds the expression
349 -- returnIO @ [()] [coerce () x, .., coerce () z]
351 -- Despite the inconvenience of building the type applications etc,
352 -- this *has* to be done in type-annotated post-typecheck form
353 -- because we are going to return a list of *polymorphic* values
354 -- coerced to type (). If we built a *source* stmt
355 -- return [coerce x, ..., coerce z]
356 -- then the type checker would instantiate x..z, and we wouldn't
357 -- get their *polymorphic* values. (And we'd get ambiguity errs
358 -- if they were overloaded, since they aren't applied to anything.)
359 mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
360 (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
361 mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
364 io_ty = mkTyConApp ioTyCon []
367 -- OK, we're ready to typecheck the stmts
368 traceTc (text "tcs 2") ;
369 ((ids, tc_expr), lie) <- getLIE $ do {
370 (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts $
372 -- Look up the names right in the middle,
373 -- where they will all be in scope
374 ids <- mappM tcLookupId names ;
375 ret_id <- tcLookupId returnIOName ; -- return @ IO
376 return (ids, [nlResultStmt (mk_return ret_id ids)]) } ;
378 io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
379 return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty))
382 -- Simplify the context right here, so that we fail
383 -- if there aren't enough instances. Notably, when we see
385 -- we use recoverTc_ to try it <- e
386 -- and then let it = e
387 -- It's the simplify step that rejects the first.
388 traceTc (text "tcs 3") ;
389 const_binds <- tcSimplifyInteractive lie ;
391 -- Build result expression and zonk it
392 let { expr = mkHsLet const_binds tc_expr } ;
393 zonked_expr <- zonkTopLExpr expr ;
394 zonked_ids <- zonkTopBndrs ids ;
396 -- None of the Ids should be of unboxed type, because we
397 -- cast them all to HValues in the end!
398 mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
400 return (zonked_ids, zonked_expr)
403 combine stmt (ids, stmts) = (ids, stmt:stmts)
404 bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
405 nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
409 tcRnExpr just finds the type of an expression
413 -> InteractiveContext
416 tcRnExpr hsc_env ictxt rdr_expr
417 = initTcPrintErrors hsc_env iNTERACTIVE $
418 setInteractiveContext ictxt $ do {
420 (rn_expr, fvs) <- rnLExpr rdr_expr ;
423 -- Now typecheck the expression;
424 -- it might have a rank-2 type (e.g. :t runST)
425 ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
426 ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
427 tcSimplifyInteractive lie_top ;
429 let { all_expr_ty = mkForAllTys qtvs $
430 mkFunTys (map idType dict_ids) $
432 zonkTcType all_expr_ty
435 smpl_doc = ptext SLIT("main expression")
438 tcRnExpr just finds the kind of a type
442 -> InteractiveContext
445 tcRnType hsc_env ictxt rdr_type
446 = initTcPrintErrors hsc_env iNTERACTIVE $
447 setInteractiveContext ictxt $ do {
449 rn_type <- rnLHsType doc rdr_type ;
452 -- Now kind-check the type
453 (ty', kind) <- kcHsType rn_type ;
457 doc = ptext SLIT("In GHCi input")
462 -> InteractiveContext
464 -> IO (Maybe [(IfaceDecl, Fixity, SrcLoc)])
465 -- Look up a RdrName and return all the TyThings it might be
466 -- A capitalised RdrName is given to us in the DataName namespace,
467 -- but we want to treat it as *both* a data constructor
468 -- *and* as a type or class constructor;
469 -- hence the call to dataTcOccs, and we return up to two results
470 tcRnThing hsc_env ictxt rdr_name
471 = initTcPrintErrors hsc_env 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 <- mapM (tryTc . lookupOccRn) rdr_names ;
482 -- The successful lookups will be (Just name)
483 let { (warns_s, good_names) = unzip [ (msgs, name)
484 | (msgs, Just name) <- results] ;
485 errs_s = [msgs | (msgs, Nothing) <- results] } ;
487 -- Fail if nothing good happened, else add warnings
488 if null good_names then
489 -- No lookup succeeded, so
490 -- pick the first error message and report it
491 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
492 -- while the other is "X is not in scope",
493 -- we definitely want the former; but we might pick the latter
494 do { addMessages (head errs_s) ; failM }
495 else -- Add deprecation warnings
496 mapM_ addMessages warns_s ;
498 -- And lookup up the entities, avoiding duplicates, which arise
499 -- because constructors and record selectors are represented by
500 -- their parent declaration
501 let { do_one name = do { thing <- tcLookupGlobal name
502 ; let decl = toIfaceDecl ictxt thing
503 ; fixity <- lookupFixityRn name
504 ; return (decl, fixity, getSrcLoc thing) } ;
505 -- For the SrcLoc, the 'thing' has better info than
506 -- the 'name' because getting the former forced the
507 -- declaration to be loaded into the cache
508 cmp (d1,_,_) (d2,_,_) = ifName d1 `compare` ifName d2 } ;
509 results <- mapM do_one good_names ;
510 return (fst (removeDups cmp results))
513 toIfaceDecl :: InteractiveContext -> TyThing -> IfaceDecl
514 toIfaceDecl ictxt thing
515 = tyThingToIfaceDecl True -- Discard IdInfo
516 emptyNameSet -- Show data cons
519 unqual = icPrintUnqual ictxt
520 ext_nm n | unqual n = LocalTop (nameOccName n) -- What a hack
521 | otherwise = ExtPkg (nameModuleName n) (nameOccName n)
523 -- munge transforms a thing to it's "parent" thing
524 munge (ADataCon dc) = ATyCon (dataConTyCon dc)
525 munge (AnId id) = case globalIdDetails id of
526 RecordSelId lbl -> ATyCon (fieldLabelTyCon lbl)
527 ClassOpId cls -> AClass cls
529 munge other_thing = other_thing
534 setInteractiveContext :: InteractiveContext -> TcRn a -> TcRn a
535 setInteractiveContext icxt thing_inside
536 = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_`
537 (updGblEnv (\env -> env {tcg_rdr_env = ic_rn_gbl_env icxt,
538 tcg_type_env = ic_type_env icxt}) $
539 updLclEnv (\env -> env {tcl_rdr = ic_rn_local_env icxt}) $
544 %************************************************************************
546 Type-checking external-core modules
548 %************************************************************************
551 tcRnExtCore :: HscEnv
553 -> IO (Messages, Maybe ModGuts)
554 -- Nothing => some error occurred
556 tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
557 -- The decls are IfaceDecls; all names are original names
558 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
560 initTc hsc_env this_mod $ do {
562 let { ldecls = map noLoc decls } ;
564 -- Deal with the type declarations; first bring their stuff
565 -- into scope, then rname them, then type check them
566 (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ;
568 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
569 tcg_imports = imports `plusImportAvails` tcg_imports gbl })
572 rn_decls <- rnTyClDecls ldecls ;
575 -- Dump trace of renaming part
576 rnDump (ppr rn_decls) ;
578 -- Typecheck them all together so that
579 -- any mutually recursive types are done right
580 tcg_env <- checkNoErrs (tcTyAndClassDecls rn_decls) ;
581 -- Make the new type env available to stuff slurped from interface files
583 setGblEnv tcg_env $ do {
585 -- Now the core bindings
586 core_binds <- initIfaceExtCore (tcExtCoreBindings this_mod src_binds) ;
590 bndrs = bindersOfBinds core_binds ;
591 my_exports = mkNameSet (map idName bndrs) ;
592 -- ToDo: export the data types also?
594 final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
596 mod_guts = ModGuts { mg_module = this_mod,
597 mg_usages = [], -- ToDo: compute usage
598 mg_dir_imps = [], -- ??
599 mg_deps = noDependencies, -- ??
600 mg_exports = my_exports,
601 mg_types = final_type_env,
602 mg_insts = tcg_insts tcg_env,
604 mg_binds = core_binds,
607 mg_rdr_env = emptyGlobalRdrEnv,
608 mg_fix_env = emptyFixityEnv,
609 mg_deprecs = NoDeprecs,
613 tcCoreDump mod_guts ;
618 mkFakeGroup decls -- Rather clumsy; lots of unused fields
619 = HsGroup { hs_tyclds = decls, -- This is the one we want
620 hs_valds = [], hs_fords = [],
621 hs_instds = [], hs_fixds = [], hs_depds = [],
622 hs_ruleds = [], hs_defds = [] }
626 %************************************************************************
628 Type-checking the top level of a module
630 %************************************************************************
633 tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
634 -- Returns the variables free in the decls
635 -- Reason: solely to report unused imports and bindings
637 = do { -- Do all the declarations
638 (tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ;
640 -- tcSimplifyTop deals with constant or ambiguous InstIds.
641 -- How could there be ambiguous ones? They can only arise if a
642 -- top-level decl falls under the monomorphism
643 -- restriction, and no subsequent decl instantiates its
644 -- type. (Usually, ambiguous type variables are resolved
645 -- during the generalisation step.)
646 traceTc (text "Tc8") ;
647 inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
648 -- Setting the global env exposes the instances to tcSimplifyTop
649 -- Setting the local env exposes the local Ids to tcSimplifyTop,
650 -- so that we get better error messages (monomorphism restriction)
652 -- Backsubstitution. This must be done last.
653 -- Even tcSimplifyTop may do some unification.
654 traceTc (text "Tc9") ;
655 let { (tcg_env, _) = tc_envs ;
656 TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
657 tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
659 (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
662 let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
664 -- Make the new type env available to stuff slurped from interface files
665 writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
667 return (tcg_env { tcg_type_env = final_type_env,
668 tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' })
671 tc_rn_src_decls :: [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
672 -- Loops around dealing with each top level inter-splice group
673 -- in turn, until it's dealt with the entire module
675 = do { let { (first_group, group_tail) = findSplice ds } ;
676 -- If ds is [] we get ([], Nothing)
678 -- Type check the decls up to, but not including, the first splice
679 tc_envs@(tcg_env,tcl_env) <- tcRnGroup first_group ;
681 -- Bale out if errors; for example, error recovery when checking
682 -- the RHS of 'main' can mean that 'main' is not in the envt for
683 -- the subsequent checkMain test
688 -- If there is no splice, we're nearly done
690 Nothing -> do { -- Last thing: check for `main'
691 tcg_env <- checkMain ;
692 return (tcg_env, tcl_env)
695 -- If there's a splice, we must carry on
696 Just (SpliceDecl splice_expr, rest_ds) -> do {
698 failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
701 -- Rename the splice expression, and get its supporting decls
702 (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
703 failIfErrsM ; -- Don't typecheck if renaming failed
705 -- Execute the splice
706 spliced_decls <- tcSpliceDecls rn_splice_expr ;
708 -- Glue them on the front of the remaining decls and loop
709 setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
710 tc_rn_src_decls (spliced_decls ++ rest_ds)
716 %************************************************************************
718 Type-checking the top level of a module
720 %************************************************************************
722 tcRnGroup takes a bunch of top-level source-code declarations, and
724 * gets supporting declarations from interface files
727 * and augments the TcGblEnv with the results
729 In Template Haskell it may be called repeatedly for each group of
730 declarations. It expects there to be an incoming TcGblEnv in the
731 monad; it augments it and returns the new TcGblEnv.
734 tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
735 -- Returns the variables free in the decls, for unused-binding reporting
737 = do { -- Rename the declarations
738 (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
739 setGblEnv tcg_env $ do {
741 -- Typecheck the declarations
742 tcTopSrcDecls rn_decls
745 ------------------------------------------------
746 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
748 = do { -- Bring top level binders into scope
749 (rdr_env, imports) <- importsFromLocalDecls group ;
750 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
751 tcg_imports = imports `plusImportAvails` tcg_imports gbl })
754 traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
755 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
757 -- Rename the source decls
758 (tcg_env, rn_decls) <- rnSrcDecls group ;
761 -- Dump trace of renaming part
762 rnDump (ppr rn_decls) ;
764 return (tcg_env, rn_decls)
767 ------------------------------------------------
768 tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
770 (HsGroup { hs_tyclds = tycl_decls,
771 hs_instds = inst_decls,
772 hs_fords = foreign_decls,
773 hs_defds = default_decls,
774 hs_ruleds = rule_decls,
775 hs_valds = val_binds })
776 = do { -- Type-check the type and class decls, and all imported decls
777 -- The latter come in via tycl_decls
778 traceTc (text "Tc2") ;
780 tcg_env <- checkNoErrs (tcTyAndClassDecls tycl_decls) ;
781 -- tcTyAndClassDecls recovers internally, but if anything gave rise to
782 -- an error we'd better stop now, to avoid a cascade
784 -- Make these type and class decls available to stuff slurped from interface files
785 writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
788 setGblEnv tcg_env $ do {
789 -- Source-language instances, including derivings,
790 -- and import the supporting declarations
791 traceTc (text "Tc3") ;
792 (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
793 setGblEnv tcg_env $ do {
795 -- Foreign import declarations next. No zonking necessary
796 -- here; we can tuck them straight into the global environment.
797 traceTc (text "Tc4") ;
798 (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
799 tcExtendGlobalValEnv fi_ids $ do {
801 -- Default declarations
802 traceTc (text "Tc4a") ;
803 default_tys <- tcDefaults default_decls ;
804 updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
806 -- Value declarations next
807 -- We also typecheck any extra binds that came out
808 -- of the "deriving" process (deriv_binds)
809 traceTc (text "Tc5") ;
810 (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ;
811 setLclTypeEnv lcl_env $ do {
813 -- Second pass over class and instance declarations,
814 traceTc (text "Tc6") ;
815 (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
816 showLIE (text "after instDecls2") ;
819 -- They need to be zonked, so we return them
820 traceTc (text "Tc7") ;
821 (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
824 rules <- tcRules rule_decls ;
827 traceTc (text "Tc7a") ;
828 tcg_env <- getGblEnv ;
829 let { all_binds = tc_val_binds `unionBags`
830 inst_binds `unionBags`
833 -- Extend the GblEnv with the (as yet un-zonked)
834 -- bindings, rules, foreign decls
835 tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
836 tcg_rules = tcg_rules tcg_env ++ rules,
837 tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
838 return (tcg_env', lcl_env)
843 %*********************************************************
845 mkGlobalContext: make up an interactive context
847 Used for initialising the lexical environment
848 of the interactive read-eval-print loop
850 %*********************************************************
854 mkExportEnv :: HscEnv -> [ModuleName] -- Expose these modules' exports only
857 mkExportEnv hsc_env exports
858 = do { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $
859 mappM getModuleExports exports
861 Just envs -> return (foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs)
862 Nothing -> return emptyGlobalRdrEnv
863 -- Some error; initTc will have printed it
866 getModuleExports :: ModuleName -> TcM GlobalRdrEnv
868 = do { iface <- load_iface mod
869 ; loadOrphanModules (dep_orphs (mi_deps iface))
870 -- Load any orphan-module interfaces,
871 -- so their instances are visible
872 ; avails <- exportsToAvails (mi_exports iface)
873 ; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod }
874 | avail <- avails, name <- availNames avail ] }
875 ; returnM (mkGlobalRdrEnv gres) }
877 vanillaProv :: ModuleName -> Provenance
878 -- We're building a GlobalRdrEnv as if the user imported
879 -- all the specified modules into the global interactive module
880 vanillaProv mod = Imported [ImportSpec mod mod False
881 (srcLocSpan interactiveSrcLoc)] False
887 -> InteractiveContext
888 -> ModuleName -- Module to inspect
889 -> Bool -- Grab just the exports, or the whole toplev
890 -> IO (Maybe [IfaceDecl])
892 getModuleContents hsc_env ictxt mod exports_only
893 = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only)
895 get_mod_contents exports_only
896 | not exports_only -- We want the whole top-level type env
897 -- so it had better be a home module
899 ; case lookupModuleEnvByName hpt mod of
900 Just mod_info -> return (map (toIfaceDecl ictxt) $
903 md_types (hm_details mod_info))
904 Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod)))
905 -- This is a system error; the module should be in the HPT
908 | otherwise -- Want the exports only
909 = do { iface <- load_iface mod
910 ; avails <- exportsToAvails (mi_exports iface)
911 ; mappM get_decl avails
915 = do { thing <- tcLookupGlobal (availName avail)
916 ; return (filter_decl (availOccs avail) (toIfaceDecl ictxt thing)) }
918 ---------------------
919 filter_decl occs decl@(IfaceClass {ifSigs = sigs})
920 = decl { ifSigs = filter (keep_sig occs) sigs }
921 filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon cons})
922 = decl { ifCons = IfDataTyCon (filter (keep_con occs) cons) }
923 filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
924 | keep_con occs con = decl
925 | otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm?
926 filter_decl occs decl
929 keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs
930 keep_con occs (IfaceConDecl occ _ _ _ _ _ _) = occ `elem` occs
932 availOccs avail = map nameOccName (availNames avail)
934 wantToSee (AnId id) = not (isImplicitId id)
935 wantToSee (ADataCon _) = False -- They'll come via their TyCon
938 ---------------------
939 load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
941 doc = ptext SLIT("context for compiling statements")
943 ---------------------
944 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
949 %************************************************************************
953 %************************************************************************
957 = do { ghci_mode <- getGhciMode ;
958 tcg_env <- getGblEnv ;
960 mb_main_mod <- readMutVar v_MainModIs ;
961 mb_main_fn <- readMutVar v_MainFunIs ;
962 let { main_mod = case mb_main_mod of {
963 Just mod -> mkModuleName mod ;
964 Nothing -> mAIN_Name } ;
965 main_fn = case mb_main_fn of {
966 Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
967 Nothing -> main_RDR_Unqual } } ;
969 check_main ghci_mode tcg_env main_mod main_fn
973 check_main ghci_mode tcg_env main_mod main_fn
974 -- If we are in module Main, check that 'main' is defined.
975 -- It may be imported from another module!
977 -- ToDo: We have to return the main_name separately, because it's a
978 -- bona fide 'use', and should be recorded as such, but the others
981 -- Blimey: a whole page of code to do this...
982 | mod_name /= main_mod
986 = addErrCtxt mainCtxt $
987 do { mb_main <- lookupSrcOcc_maybe main_fn
988 -- Check that 'main' is in scope
989 -- It might be imported from another module!
991 Nothing -> do { complain_no_main
994 { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) }
995 -- :Main.main :: IO () = runIO main
997 ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $
1000 ; let { root_main_id = mkExportedLocalId rootMainName ty ;
1001 main_bind = noLoc (VarBind root_main_id main_expr) }
1003 ; return (tcg_env { tcg_binds = tcg_binds tcg_env
1004 `snocBag` main_bind,
1005 tcg_dus = tcg_dus tcg_env
1006 `plusDU` usesOnly (unitFV main_name)
1010 mod_name = moduleName (tcg_mod tcg_env)
1012 complain_no_main | ghci_mode == Interactive = return ()
1013 | otherwise = failWithTc noMainMsg
1014 -- In interactive mode, don't worry about the absence of 'main'
1015 -- In other modes, fail altogether, so that we don't go on
1016 -- and complain a second time when processing the export list.
1018 mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
1019 noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
1020 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
1024 %************************************************************************
1028 %************************************************************************
1031 rnDump :: SDoc -> TcRn ()
1032 -- Dump, with a banner, if -ddump-rn
1033 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1035 tcDump :: TcGblEnv -> TcRn ()
1037 = do { dflags <- getDOpts ;
1039 -- Dump short output if -ddump-types or -ddump-tc
1040 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1041 (dumpTcRn short_dump) ;
1043 -- Dump bindings if -ddump-tc
1044 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1047 short_dump = pprTcGblEnv env
1048 full_dump = pprLHsBinds (tcg_binds env)
1049 -- NB: foreign x-d's have undefined's in their types;
1050 -- hence can't show the tc_fords
1053 = do { dflags <- getDOpts ;
1054 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1055 (dumpTcRn (pprModGuts mod_guts)) ;
1057 -- Dump bindings if -ddump-tc
1058 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1060 full_dump = pprCoreBindings (mg_binds mod_guts)
1062 -- It's unpleasant having both pprModGuts and pprModDetails here
1063 pprTcGblEnv :: TcGblEnv -> SDoc
1064 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1065 tcg_insts = dfun_ids,
1067 tcg_imports = imports })
1068 = vcat [ ppr_types dfun_ids type_env
1069 , ppr_insts dfun_ids
1070 , vcat (map ppr rules)
1071 , ppr_gen_tycons (typeEnvTyCons type_env)
1072 , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports))
1073 , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1075 pprModGuts :: ModGuts -> SDoc
1076 pprModGuts (ModGuts { mg_types = type_env,
1078 = vcat [ ppr_types [] type_env,
1082 ppr_types :: [Var] -> TypeEnv -> SDoc
1083 ppr_types dfun_ids type_env
1084 = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1086 ids = [id | id <- typeEnvIds type_env, want_sig id]
1087 want_sig id | opt_PprStyle_Debug = True
1088 | otherwise = isLocalId id &&
1089 isExternalName (idName id) &&
1090 not (id `elem` dfun_ids)
1091 -- isLocalId ignores data constructors, records selectors etc.
1092 -- The isExternalName ignores local dictionary and method bindings
1093 -- that the type checker has invented. Top-level user-defined things
1094 -- have External names.
1096 ppr_insts :: [Var] -> SDoc
1097 ppr_insts [] = empty
1098 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1100 ppr_sigs :: [Var] -> SDoc
1102 -- Print type signatures; sort by OccName
1103 = vcat (map ppr_sig (sortLt lt_sig ids))
1105 lt_sig id1 id2 = getOccName id1 < getOccName id2
1106 ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
1108 ppr_rules :: [IdCoreRule] -> SDoc
1109 ppr_rules [] = empty
1110 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1111 nest 4 (pprIdRules rs),
1114 ppr_gen_tycons [] = empty
1115 ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"),
1116 nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]