2 % (c) The University of Glasgow 2006
3 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
5 \section[TcModule]{Typechecking a whole module}
10 tcRnStmt, tcRnExpr, tcRnType,
21 #include "HsVersions.h"
25 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
84 import {- Kind parts of -} Type
93 import Control.Monad ( unless )
94 import Data.Maybe ( isJust )
99 %************************************************************************
101 Typecheck and rename a module
103 %************************************************************************
109 -> Bool -- True <=> save renamed syntax
110 -> Located (HsModule RdrName)
111 -> IO (Messages, Maybe TcGblEnv)
113 tcRnModule hsc_env hsc_src save_rn_syntax
114 (L loc (HsModule maybe_mod export_ies
115 import_decls local_decls mod_deprec _ module_info maybe_doc))
116 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
118 let { this_pkg = thisPackage (hsc_dflags hsc_env) ;
119 this_mod = case maybe_mod of
120 Nothing -> mAIN -- 'module M where' is omitted
121 Just (L _ mod) -> mkModule this_pkg mod } ;
124 initTc hsc_env hsc_src this_mod $
127 -- Deal with imports;
128 (rn_imports, rdr_env, imports) <- rnImports import_decls ;
130 let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface)
131 ; dep_mods = imp_dep_mods imports
133 -- We want instance declarations from all home-package
134 -- modules below this one, including boot modules, except
135 -- ourselves. The 'except ourselves' is so that we don't
136 -- get the instances from this module's hs-boot file
137 ; want_instances :: ModuleName -> Bool
138 ; want_instances mod = mod `elemUFM` dep_mods
139 && mod /= moduleName this_mod
140 ; home_insts = hptInstances hsc_env want_instances
143 -- Record boot-file info in the EPS, so that it's
144 -- visible to loadHiBootInterface in tcRnSrcDecls,
145 -- and any other incrementally-performed imports
146 updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
148 -- Update the gbl env
150 gbl { tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env,
151 tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
152 tcg_imports = tcg_imports gbl `plusImportAvails` imports,
153 tcg_rn_imports = if save_rn_syntax then
157 tcg_rn_decls = if save_rn_syntax then
163 traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
164 -- Fail if there are any errors so far
165 -- The error printing (if needed) takes advantage
166 -- of the tcg_env we have now set
167 traceIf (text "rdr_env: " <+> ppr rdr_env) ;
170 -- Load any orphan-module and family instance-module
171 -- interfaces, so that their rules and instance decls will be
173 loadOrphanModules (imp_orphs imports) False ;
174 loadOrphanModules (imp_finsts imports) True ;
176 let { directlyImpMods = map (\(mod, _, _) -> mod)
180 checkFamInstConsistency (imp_finsts imports) directlyImpMods ;
182 traceRn (text "rn1a") ;
183 -- Rename and type check the declarations
184 tcg_env <- if isHsBoot hsc_src then
185 tcRnHsBootDecls local_decls
187 tcRnSrcDecls local_decls ;
188 setGblEnv tcg_env $ do {
190 failIfErrsM ; -- reportDeprecations crashes sometimes
191 -- as a result of typechecker repairs (e.g. unboundNames)
192 traceRn (text "rn3") ;
194 -- Report the use of any deprecated things
195 -- We do this before processsing the export list so
196 -- that we don't bleat about re-exporting a deprecated
197 -- thing (especially via 'module Foo' export item)
198 -- Only uses in the body of the module are complained about
199 reportDeprecations (hsc_dflags hsc_env) tcg_env ;
201 -- Process the export list
202 (rn_exports, exports) <- rnExports (isJust maybe_mod) export_ies ;
204 traceRn (text "rn4") ;
206 -- Rename the Haddock documentation header
207 rn_module_doc <- rnMbHsDoc maybe_doc ;
209 -- Rename the Haddock module info
210 rn_description <- rnMbHsDoc (hmi_description module_info) ;
211 let { rn_module_info = module_info { hmi_description = rn_description } } ;
213 -- Check whether the entire module is deprecated
214 -- This happens only once per module
215 let { mod_deprecs = checkModDeprec mod_deprec } ;
217 -- Add exports and deprecations to envt
218 let { final_env = tcg_env { tcg_exports = exports,
219 tcg_rn_exports = if save_rn_syntax then
222 tcg_dus = tcg_dus tcg_env `plusDU` usesOnly (availsToNameSet exports),
223 tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
225 tcg_doc = rn_module_doc,
226 tcg_hmi = rn_module_info
228 -- A module deprecation over-rides the earlier ones
231 -- Report unused names
232 reportUnusedNames export_ies final_env ;
234 -- Dump output and return
241 %************************************************************************
243 Type-checking external-core modules
245 %************************************************************************
248 tcRnExtCore :: HscEnv
250 -> IO (Messages, Maybe ModGuts)
251 -- Nothing => some error occurred
253 tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
254 -- The decls are IfaceDecls; all names are original names
255 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
257 initTc hsc_env ExtCoreFile this_mod $ do {
259 let { ldecls = map noLoc decls } ;
261 -- Deal with the type declarations; first bring their stuff
262 -- into scope, then rname them, then type check them
263 tcg_env <- importsFromLocalDecls (mkFakeGroup ldecls) ;
265 setGblEnv tcg_env $ do {
267 rn_decls <- rnTyClDecls ldecls ;
270 -- Dump trace of renaming part
271 rnDump (ppr rn_decls) ;
273 -- Typecheck them all together so that
274 -- any mutually recursive types are done right
275 tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails rn_decls) ;
276 -- Make the new type env available to stuff slurped from interface files
278 setGblEnv tcg_env $ do {
280 -- Now the core bindings
281 core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
285 bndrs = bindersOfBinds core_binds ;
286 my_exports = map (Avail . idName) bndrs ;
287 -- ToDo: export the data types also?
289 final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
291 mod_guts = ModGuts { mg_module = this_mod,
293 mg_usages = [], -- ToDo: compute usage
294 mg_dir_imps = [], -- ??
295 mg_deps = noDependencies, -- ??
296 mg_exports = my_exports,
297 mg_types = final_type_env,
298 mg_insts = tcg_insts tcg_env,
299 mg_fam_insts = tcg_fam_insts tcg_env,
301 mg_binds = core_binds,
304 mg_rdr_env = emptyGlobalRdrEnv,
305 mg_fix_env = emptyFixityEnv,
306 mg_deprecs = NoDeprecs,
307 mg_foreign = NoStubs,
308 mg_hpc_info = noHpcInfo
311 tcCoreDump mod_guts ;
316 mkFakeGroup decls -- Rather clumsy; lots of unused fields
317 = emptyRdrGroup { hs_tyclds = decls }
321 %************************************************************************
323 Type-checking the top level of a module
325 %************************************************************************
328 tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
329 -- Returns the variables free in the decls
330 -- Reason: solely to report unused imports and bindings
332 = do { -- Load the hi-boot interface for this module, if any
333 -- We do this now so that the boot_names can be passed
334 -- to tcTyAndClassDecls, because the boot_names are
335 -- automatically considered to be loop breakers
337 boot_iface <- tcHiBootIface mod ;
339 -- Do all the declarations
340 tcg_env <- tc_rn_src_decls boot_iface decls ;
342 -- Backsubstitution. This must be done last.
343 -- Even tcSimplifyTop may do some unification.
344 traceTc (text "Tc9") ;
345 let { TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
346 tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
348 (bind_ids, binds', fords', rules') <- zonkTopDecls binds rules fords ;
350 let { final_type_env = extendTypeEnvWithIds type_env bind_ids
351 ; tcg_env' = tcg_env { tcg_type_env = final_type_env,
354 tcg_fords = fords' } } ;
356 -- Make the new type env available to stuff slurped from interface files
357 writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
359 -- Compare the hi-boot iface (if any) with the real thing
360 dfun_binds <- checkHiBootIface tcg_env' boot_iface ;
362 return (tcg_env' { tcg_binds = tcg_binds tcg_env' `unionBags` dfun_binds })
365 tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv
366 -- Loops around dealing with each top level inter-splice group
367 -- in turn, until it's dealt with the entire module
368 tc_rn_src_decls boot_details ds
369 = do { let { (first_group, group_tail) = findSplice ds } ;
370 -- If ds is [] we get ([], Nothing)
372 -- Deal with decls up to, but not including, the first splice
373 (tcg_env, rn_decls) <- rnTopSrcDecls first_group ;
374 ((tcg_env, tcl_env), lie) <- getLIE $ setGblEnv tcg_env $
375 tcTopSrcDecls boot_details rn_decls ;
377 -- tcSimplifyTop deals with constant or ambiguous InstIds.
378 -- How could there be ambiguous ones? They can only arise if a
379 -- top-level decl falls under the monomorphism restriction
380 -- and no subsequent decl instantiates its type.
381 traceTc (text "Tc8") ;
382 inst_binds <- setEnvs (tcg_env, tcl_env) (tcSimplifyTop lie) ;
383 -- Setting the global env exposes the instances to tcSimplifyTop
384 -- Setting the local env exposes the local Ids to tcSimplifyTop,
385 -- so that we get better error messages (monomorphism restriction)
387 let { tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` inst_binds } } ;
389 setEnvs (tcg_env', tcl_env) $
391 -- If there is no splice, we're nearly done
393 Nothing -> -- Last thing: check for `main'
396 -- If there's a splice, we must carry on
397 Just (SpliceDecl splice_expr, rest_ds) ->
400 failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
403 -- Rename the splice expression, and get its supporting decls
404 (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
405 failIfErrsM ; -- Don't typecheck if renaming failed
406 rnDump (ppr rn_splice_expr) ;
408 -- Execute the splice
409 spliced_decls <- tcSpliceDecls rn_splice_expr ;
411 -- Glue them on the front of the remaining decls and loop
412 setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
413 tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
418 %************************************************************************
420 Compiling hs-boot source files, and
421 comparing the hi-boot interface with the real thing
423 %************************************************************************
426 tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
427 tcRnHsBootDecls decls
428 = do { let { (first_group, group_tail) = findSplice decls }
431 Just stuff -> spliceInHsBootErr stuff
434 -- Rename the declarations
435 ; (tcg_env, rn_group) <- rnTopSrcDecls first_group
436 ; setGblEnv tcg_env $ do {
438 -- Todo: check no foreign decls, no rules, no default decls
440 -- Typecheck type/class decls
441 ; traceTc (text "Tc2")
442 ; let tycl_decls = hs_tyclds rn_group
443 ; tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails tycl_decls)
444 ; setGblEnv tcg_env $ do {
446 -- Typecheck instance decls
447 ; traceTc (text "Tc3")
448 ; (tcg_env, inst_infos, _binds)
449 <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group)
450 ; setGblEnv tcg_env $ do {
452 -- Typecheck value declarations
453 ; traceTc (text "Tc5")
454 ; val_ids <- tcHsBootSigs (hs_valds rn_group)
457 -- No simplification or zonking to do
458 ; traceTc (text "Tc7a")
459 ; gbl_env <- getGblEnv
461 -- Make the final type-env
462 -- Include the dfun_ids so that their type sigs
463 -- are written into the interface file
464 ; let { type_env0 = tcg_type_env gbl_env
465 ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
466 ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
467 ; dfun_ids = map iDFunId inst_infos }
468 ; return (gbl_env { tcg_type_env = type_env2 })
471 spliceInHsBootErr (SpliceDecl (L loc _), _)
472 = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files"))
475 Once we've typechecked the body of the module, we want to compare what
476 we've found (gathered in a TypeEnv) with the hi-boot details (if any).
479 checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id)
480 -- Compare the hi-boot file for this module (if there is one)
481 -- with the type environment we've just come up with
482 -- In the common case where there is no hi-boot file, the list
483 -- of boot_names is empty.
485 -- The bindings we return give bindings for the dfuns defined in the
486 -- hs-boot file, such as $fbEqT = $fEqT
489 (TcGblEnv { tcg_insts = local_insts, tcg_fam_insts = local_fam_insts,
490 tcg_type_env = local_type_env })
491 (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts,
492 md_types = boot_type_env })
493 = do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts)) ;
494 ; mapM_ check_one (typeEnvElts boot_type_env)
495 ; dfun_binds <- mapM check_inst boot_insts
496 ; unless (null boot_fam_insts) $
497 panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++
498 "instances in boot files yet...")
499 -- FIXME: Why? The actual comparison is not hard, but what would
500 -- be the equivalent to the dfun bindings returned for class
501 -- instances? We can't easily equate tycons...
502 ; return (unionManyBags dfun_binds) }
505 | isImplicitTyThing boot_thing = return ()
506 | name `elem` dfun_names = return ()
507 | isWiredInName name = return () -- No checking for wired-in names. In particular,
508 -- 'error' is handled by a rather gross hack
509 -- (see comments in GHC.Err.hs-boot)
510 | Just real_thing <- lookupTypeEnv local_type_env name
511 = do { let boot_decl = tyThingToIfaceDecl boot_thing
512 real_decl = tyThingToIfaceDecl real_thing
513 ; checkTc (checkBootDecl boot_decl real_decl)
514 (bootMisMatch boot_thing boot_decl real_decl) }
515 -- The easiest way to check compatibility is to convert to
516 -- iface syntax, where we already have good comparison functions
518 = addErrTc (missingBootThing boot_thing)
520 name = getName boot_thing
522 dfun_names = map getName boot_insts
525 = case [dfun | inst <- local_insts,
526 let dfun = instanceDFunId inst,
527 idType dfun `tcEqType` boot_inst_ty ] of
528 [] -> do { addErrTc (instMisMatch boot_inst); return emptyBag }
529 (dfun:_) -> return (unitBag $ noLoc $ VarBind local_boot_dfun (nlHsVar dfun))
531 boot_dfun = instanceDFunId boot_inst
532 boot_inst_ty = idType boot_dfun
533 local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty
536 missingBootThing thing
537 = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
538 bootMisMatch thing boot_decl real_decl
539 = vcat [ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file"),
540 ptext SLIT("Decl") <+> ppr real_decl,
541 ptext SLIT("Boot file:") <+> ppr boot_decl]
544 2 (ptext SLIT("is defined in the hs-boot file, but not in the module"))
548 %************************************************************************
550 Type-checking the top level of a module
552 %************************************************************************
554 tcRnGroup takes a bunch of top-level source-code declarations, and
556 * gets supporting declarations from interface files
559 * and augments the TcGblEnv with the results
561 In Template Haskell it may be called repeatedly for each group of
562 declarations. It expects there to be an incoming TcGblEnv in the
563 monad; it augments it and returns the new TcGblEnv.
566 ------------------------------------------------
567 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
569 = do { -- Bring top level binders into scope
570 tcg_env <- importsFromLocalDecls group ;
571 setGblEnv tcg_env $ do {
573 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
575 -- Rename the source decls
576 (tcg_env, rn_decls) <- rnSrcDecls group ;
579 -- save the renamed syntax, if we want it
581 | Just grp <- tcg_rn_decls tcg_env
582 = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
586 -- Dump trace of renaming part
587 rnDump (ppr rn_decls) ;
589 return (tcg_env', rn_decls)
592 ------------------------------------------------
593 tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
594 tcTopSrcDecls boot_details
595 (HsGroup { hs_tyclds = tycl_decls,
596 hs_instds = inst_decls,
597 hs_derivds = deriv_decls,
598 hs_fords = foreign_decls,
599 hs_defds = default_decls,
600 hs_ruleds = rule_decls,
601 hs_valds = val_binds })
602 = do { -- Type-check the type and class decls, and all imported decls
603 -- The latter come in via tycl_decls
604 traceTc (text "Tc2") ;
606 tcg_env <- checkNoErrs (tcTyAndClassDecls boot_details tycl_decls) ;
607 -- tcTyAndClassDecls recovers internally, but if anything gave rise to
608 -- an error we'd better stop now, to avoid a cascade
610 -- Make these type and class decls available to stuff slurped from interface files
611 writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
614 setGblEnv tcg_env $ do {
615 -- Source-language instances, including derivings,
616 -- and import the supporting declarations
617 traceTc (text "Tc3") ;
618 (tcg_env, inst_infos, deriv_binds)
619 <- tcInstDecls1 tycl_decls inst_decls deriv_decls;
620 setGblEnv tcg_env $ do {
622 -- Foreign import declarations next. No zonking necessary
623 -- here; we can tuck them straight into the global environment.
624 traceTc (text "Tc4") ;
625 (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
626 tcExtendGlobalValEnv fi_ids $ do {
628 -- Default declarations
629 traceTc (text "Tc4a") ;
630 default_tys <- tcDefaults default_decls ;
631 updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
633 -- Value declarations next
634 -- We also typecheck any extra binds that came out
635 -- of the "deriving" process (deriv_binds)
636 traceTc (text "Tc5") ;
637 (tc_val_binds, tcl_env) <- tcTopBinds (val_binds `plusHsValBinds` deriv_binds) ;
638 setLclTypeEnv tcl_env $ do {
640 -- Second pass over class and instance declarations,
641 traceTc (text "Tc6") ;
642 (inst_binds, tcl_env) <- tcInstDecls2 tycl_decls inst_infos ;
643 showLIE (text "after instDecls2") ;
646 -- They need to be zonked, so we return them
647 traceTc (text "Tc7") ;
648 (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
651 rules <- tcRules rule_decls ;
654 traceTc (text "Tc7a") ;
655 tcg_env <- getGblEnv ;
656 let { all_binds = tc_val_binds `unionBags`
657 inst_binds `unionBags`
660 -- Extend the GblEnv with the (as yet un-zonked)
661 -- bindings, rules, foreign decls
662 tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
663 tcg_rules = tcg_rules tcg_env ++ rules,
664 tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
665 return (tcg_env', tcl_env)
670 %************************************************************************
674 %************************************************************************
677 checkMain :: TcM TcGblEnv
678 -- If we are in module Main, check that 'main' is defined.
680 = do { ghc_mode <- getGhcMode ;
681 tcg_env <- getGblEnv ;
683 let { main_mod = mainModIs dflags ;
684 main_fn = case mainFunIs dflags of {
685 Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ;
686 Nothing -> main_RDR_Unqual } } ;
688 check_main ghc_mode tcg_env main_mod main_fn
692 check_main ghc_mode tcg_env main_mod main_fn
694 = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >>
698 = addErrCtxt mainCtxt $
699 do { mb_main <- lookupSrcOcc_maybe main_fn
700 -- Check that 'main' is in scope
701 -- It might be imported from another module!
703 Nothing -> do { traceTc (text "checkMain fail" <+> ppr main_mod <+> ppr main_fn)
707 { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn)
708 ; let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) }
709 -- :Main.main :: IO () = runMainIO main
711 ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
714 -- The function that the RTS invokes is always :Main.main,
715 -- which we call root_main_id.
716 -- (Because GHC allows the user to have a module not called
717 -- Main as the main module, we can't rely on the main function
718 -- being called "Main.main". That's why root_main_id has a fixed
720 -- We also make root_main_id an implicit Id, by making main_name
721 -- its parent (hence (Just main_name)). That has the effect
722 -- of preventing its type and unfolding from getting out into
723 -- the interface file. Otherwise we can end up with two defns
724 -- for 'main' in the interface file!
726 ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN
727 (mkVarOccFS FSLIT("main"))
728 (getSrcLoc main_name)
729 ; root_main_id = Id.mkExportedLocalId root_main_name ty
730 ; main_bind = noLoc (VarBind root_main_id main_expr) }
732 ; return (tcg_env { tcg_binds = tcg_binds tcg_env
734 tcg_dus = tcg_dus tcg_env
735 `plusDU` usesOnly (unitFV main_name)
736 -- Record the use of 'main', so that we don't
737 -- complain about it being defined but not used
741 mod = tcg_mod tcg_env
743 complain_no_main | ghc_mode == Interactive = return ()
744 | otherwise = failWithTc noMainMsg
745 -- In interactive mode, don't worry about the absence of 'main'
746 -- In other modes, fail altogether, so that we don't go on
747 -- and complain a second time when processing the export list.
749 mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
750 noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
751 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
754 %*********************************************************
758 %*********************************************************
762 setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
763 setInteractiveContext hsc_env icxt thing_inside
765 -- Initialise the tcg_inst_env with instances
766 -- from all home modules. This mimics the more selective
767 -- call to hptInstances in tcRnModule
768 dfuns = hptInstances hsc_env (\mod -> True)
770 updGblEnv (\env -> env {
771 tcg_rdr_env = ic_rn_gbl_env icxt,
772 tcg_type_env = ic_type_env icxt,
773 tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $
775 updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt }) $
777 do { traceTc (text "setIC" <+> ppr (ic_type_env icxt))
784 -> InteractiveContext
786 -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
787 -- The returned [Name] is the same as the input except for
788 -- ExprStmt, in which case the returned [Name] is [itName]
790 -- The returned TypecheckedHsExpr is of type IO [ () ],
791 -- a list of the bound values, coerced to ().
793 tcRnStmt hsc_env ictxt rdr_stmt
794 = initTcPrintErrors hsc_env iNTERACTIVE $
795 setInteractiveContext hsc_env ictxt $ do {
797 -- Rename; use CmdLineMode because tcRnStmt is only used interactively
798 (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ;
799 traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
802 -- The real work is done here
803 (bound_ids, tc_expr) <- mkPlan rn_stmt ;
804 zonked_expr <- zonkTopLExpr tc_expr ;
805 zonked_ids <- zonkTopBndrs bound_ids ;
807 -- None of the Ids should be of unboxed type, because we
808 -- cast them all to HValues in the end!
809 mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
811 traceTc (text "tcs 1") ;
812 let { -- (a) Make all the bound ids "global" ids, now that
813 -- they're notionally top-level bindings. This is
814 -- important: otherwise when we come to compile an expression
815 -- using these ids later, the byte code generator will consider
816 -- the occurrences to be free rather than global.
818 -- (b) Tidy their types; this is important, because :info may
819 -- ask to look at them, and :info expects the things it looks
820 -- up to have tidy types
821 global_ids = map globaliseAndTidy zonked_ids ;
823 -- Update the interactive context
824 rn_env = ic_rn_local_env ictxt ;
825 type_env = ic_type_env ictxt ;
827 bound_names = map idName global_ids ;
828 new_rn_env = extendLocalRdrEnv rn_env bound_names ;
830 {- ---------------------------------------------
831 At one stage I removed any shadowed bindings from the type_env;
832 they are inaccessible but might, I suppose, cause a space leak if we leave them there.
833 However, with Template Haskell they aren't necessarily inaccessible. Consider this
835 Prelude> let f n = n * 2 :: Int
836 Prelude> fName <- runQ [| f |]
837 Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
839 Prelude> let f n = n * 3 :: Int
840 Prelude> $(return $ AppE fName (LitE (IntegerL 7)))
841 In the last line we use 'fName', which resolves to the *first* 'f'
842 in scope. If we delete it from the type env, GHCi crashes because
843 it doesn't expect that.
845 Hence this code is commented out
847 shadowed = [ n | name <- bound_names,
848 let rdr_name = mkRdrUnqual (nameOccName name),
849 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
850 filtered_type_env = delListFromNameEnv type_env shadowed ;
851 -------------------------------------------------- -}
853 new_type_env = extendTypeEnvWithIds type_env global_ids ;
854 new_ic = ictxt { ic_rn_local_env = new_rn_env,
855 ic_type_env = new_type_env }
858 dumpOptTcRn Opt_D_dump_tc
859 (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
860 text "Typechecked expr" <+> ppr zonked_expr]) ;
862 returnM (new_ic, bound_names, zonked_expr)
865 bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
866 nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
868 globaliseAndTidy :: Id -> Id
870 -- Give the Id a Global Name, and tidy its type
871 = Id.setIdType (globaliseId VanillaGlobal id) tidy_type
873 tidy_type = tidyTopType (idType id)
876 Here is the grand plan, implemented in tcUserStmt
878 What you type The IO [HValue] that hscStmt returns
879 ------------- ------------------------------------
880 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
883 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
886 expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it]
887 [NB: result not printed] bindings: [it]
889 expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it]
890 result showable) bindings: [it]
892 expr (of non-IO type,
893 result not showable) ==> error
897 ---------------------------
898 type PlanResult = ([Id], LHsExpr Id)
899 type Plan = TcM PlanResult
901 runPlans :: [Plan] -> TcM PlanResult
902 -- Try the plans in order. If one fails (by raising an exn), try the next.
903 -- If one succeeds, take it.
904 runPlans [] = panic "runPlans"
906 runPlans (p:ps) = tryTcLIE_ (runPlans ps) p
909 mkPlan :: LStmt Name -> TcM PlanResult
910 mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt
911 = do { uniq <- newUnique -- is treated very specially
912 ; let fresh_it = itName uniq
913 the_bind = L loc $ mkFunBind (L loc fresh_it) matches
914 matches = [mkMatch [] expr emptyLocalBinds]
915 let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(NonRecursive,unitBag the_bind)] []))
916 bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr
917 (HsVar bindIOName) noSyntaxExpr
918 print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
919 (HsVar thenIOName) placeHolderType
922 -- [it <- e; print it] but not if it::()
924 -- [let it = e; print it]
925 ; runPlans [ -- Plan A
926 do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it]
927 ; it_ty <- zonkTcType (idType it_id)
928 ; ifM (isUnitTy it_ty) failM
931 -- Plan B; a naked bind statment
932 tcGhciStmts [bind_stmt],
934 -- Plan C; check that the let-binding is typeable all by itself.
935 -- If not, fail; if so, try to print it.
936 -- The two-step process avoids getting two errors: one from
937 -- the expression itself, and one from the 'print it' part
938 -- This two-step story is very clunky, alas
939 do { checkNoErrs (tcGhciStmts [let_stmt])
940 --- checkNoErrs defeats the error recovery of let-bindings
941 ; tcGhciStmts [let_stmt, print_it] }
944 mkPlan stmt@(L loc (BindStmt {}))
945 | [L _ v] <- collectLStmtBinders stmt -- One binder, for a bind stmt
946 = do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v))
947 (HsVar thenIOName) placeHolderType
949 ; print_bind_result <- doptM Opt_PrintBindResult
950 ; let print_plan = do
951 { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v]
952 ; v_ty <- zonkTcType (idType v_id)
953 ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM
957 -- [stmt; print v] but not if v::()
959 ; runPlans ((if print_bind_result then [print_plan] else []) ++
960 [tcGhciStmts [stmt]])
966 ---------------------------
967 tcGhciStmts :: [LStmt Name] -> TcM PlanResult
969 = do { ioTyCon <- tcLookupTyCon ioTyConName ;
970 ret_id <- tcLookupId returnIOName ; -- return @ IO
972 io_ty = mkTyConApp ioTyCon [] ;
973 ret_ty = mkListTy unitTy ;
974 io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
975 tc_io_stmts stmts = tcStmts DoExpr (tcDoStmt io_ty) stmts
976 (emptyRefinement, io_ret_ty) ;
978 names = map unLoc (collectLStmtsBinders stmts) ;
980 -- mk_return builds the expression
981 -- returnIO @ [()] [coerce () x, .., coerce () z]
983 -- Despite the inconvenience of building the type applications etc,
984 -- this *has* to be done in type-annotated post-typecheck form
985 -- because we are going to return a list of *polymorphic* values
986 -- coerced to type (). If we built a *source* stmt
987 -- return [coerce x, ..., coerce z]
988 -- then the type checker would instantiate x..z, and we wouldn't
989 -- get their *polymorphic* values. (And we'd get ambiguity errs
990 -- if they were overloaded, since they aren't applied to anything.)
991 mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty])
992 (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
993 mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy])
997 -- OK, we're ready to typecheck the stmts
998 traceTc (text "tcs 2") ;
999 ((tc_stmts, ids), lie) <- getLIE $ tc_io_stmts stmts $ \ _ ->
1000 mappM tcLookupId names ;
1001 -- Look up the names right in the middle,
1002 -- where they will all be in scope
1004 -- Simplify the context
1005 const_binds <- checkNoErrs (tcSimplifyInteractive lie) ;
1006 -- checkNoErrs ensures that the plan fails if context redn fails
1008 return (ids, mkHsDictLet const_binds $
1009 noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty))
1014 tcRnExpr just finds the type of an expression
1018 -> InteractiveContext
1021 tcRnExpr hsc_env ictxt rdr_expr
1022 = initTcPrintErrors hsc_env iNTERACTIVE $
1023 setInteractiveContext hsc_env ictxt $ do {
1025 (rn_expr, fvs) <- rnLExpr rdr_expr ;
1028 -- Now typecheck the expression;
1029 -- it might have a rank-2 type (e.g. :t runST)
1030 ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
1031 ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
1032 tcSimplifyInteractive lie_top ;
1033 qtvs' <- mappM zonkQuantifiedTyVar qtvs ;
1035 let { all_expr_ty = mkForAllTys qtvs' $
1036 mkFunTys (map idType dict_ids) $
1038 zonkTcType all_expr_ty
1041 smpl_doc = ptext SLIT("main expression")
1044 tcRnType just finds the kind of a type
1048 -> InteractiveContext
1051 tcRnType hsc_env ictxt rdr_type
1052 = initTcPrintErrors hsc_env iNTERACTIVE $
1053 setInteractiveContext hsc_env ictxt $ do {
1055 rn_type <- rnLHsType doc rdr_type ;
1058 -- Now kind-check the type
1059 (ty', kind) <- kcHsType rn_type ;
1063 doc = ptext SLIT("In GHCi input")
1069 %************************************************************************
1071 More GHCi stuff, to do with browsing and getting info
1073 %************************************************************************
1077 -- ASSUMES that the module is either in the HomePackageTable or is
1078 -- a package module with an interface on disk. If neither of these is
1079 -- true, then the result will be an error indicating the interface
1080 -- could not be found.
1081 getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo])
1082 getModuleExports hsc_env mod
1083 = initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod)
1085 tcGetModuleExports :: Module -> TcM [AvailInfo]
1086 tcGetModuleExports mod = do
1087 let doc = ptext SLIT("context for compiling statements")
1088 iface <- initIfaceTcRn $ loadSysInterface doc mod
1089 loadOrphanModules (dep_orphs (mi_deps iface)) False
1090 -- Load any orphan-module interfaces,
1091 -- so their instances are visible
1092 loadOrphanModules (dep_finsts (mi_deps iface)) True
1093 -- Load any family instance-module interfaces,
1094 -- so all family instances are visible
1095 ifaceExportNames (mi_exports iface)
1097 tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
1098 tcRnLookupRdrName hsc_env rdr_name
1099 = initTcPrintErrors hsc_env iNTERACTIVE $
1100 setInteractiveContext hsc_env (hsc_IC hsc_env) $
1101 lookup_rdr_name rdr_name
1103 lookup_rdr_name rdr_name = do {
1104 -- If the identifier is a constructor (begins with an
1105 -- upper-case letter), then we need to consider both
1106 -- constructor and type class identifiers.
1107 let { rdr_names = dataTcOccs rdr_name } ;
1109 -- results :: [Either Messages Name]
1110 results <- mapM (tryTcErrs . lookupOccRn) rdr_names ;
1112 traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
1113 -- The successful lookups will be (Just name)
1114 let { (warns_s, good_names) = unzip [ (msgs, name)
1115 | (msgs, Just name) <- results] ;
1116 errs_s = [msgs | (msgs, Nothing) <- results] } ;
1118 -- Fail if nothing good happened, else add warnings
1119 if null good_names then
1120 -- No lookup succeeded, so
1121 -- pick the first error message and report it
1122 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
1123 -- while the other is "X is not in scope",
1124 -- we definitely want the former; but we might pick the latter
1125 do { addMessages (head errs_s) ; failM }
1126 else -- Add deprecation warnings
1127 mapM_ addMessages warns_s ;
1133 tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
1134 tcRnLookupName hsc_env name
1135 = initTcPrintErrors hsc_env iNTERACTIVE $
1136 setInteractiveContext hsc_env (hsc_IC hsc_env) $
1140 tcRnGetInfo :: HscEnv
1142 -> IO (Maybe (TyThing, Fixity, [Instance]))
1144 -- Used to implemnent :info in GHCi
1146 -- Look up a RdrName and return all the TyThings it might be
1147 -- A capitalised RdrName is given to us in the DataName namespace,
1148 -- but we want to treat it as *both* a data constructor
1149 -- *and* as a type or class constructor;
1150 -- hence the call to dataTcOccs, and we return up to two results
1151 tcRnGetInfo hsc_env name
1152 = initTcPrintErrors hsc_env iNTERACTIVE $
1153 let ictxt = hsc_IC hsc_env in
1154 setInteractiveContext hsc_env ictxt $ do
1156 -- Load the interface for all unqualified types and classes
1157 -- That way we will find all the instance declarations
1158 -- (Packages have not orphan modules, and we assume that
1159 -- in the home package all relevant modules are loaded.)
1160 loadUnqualIfaces ictxt
1162 thing <- tcLookupGlobal name
1163 fixity <- lookupFixityRn name
1164 ispecs <- lookupInsts (icPrintUnqual ictxt) thing
1165 return (thing, fixity, ispecs)
1168 lookupInsts :: PrintUnqualified -> TyThing -> TcM [Instance]
1169 -- Filter the instances by the ones whose tycons (or clases resp)
1170 -- are in scope unqualified. Otherwise we list a whole lot too many!
1171 lookupInsts print_unqual (AClass cls)
1172 = do { inst_envs <- tcGetInstEnvs
1174 | ispec <- classInstances inst_envs cls
1175 , plausibleDFun print_unqual (instanceDFunId ispec) ] }
1177 lookupInsts print_unqual (ATyCon tc)
1178 = do { eps <- getEps -- Load all instances for all classes that are
1179 -- in the type environment (which are all the ones
1180 -- we've seen in any interface file so far)
1181 ; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all
1183 | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie
1184 , let dfun = instanceDFunId ispec
1186 , plausibleDFun print_unqual dfun ] }
1188 relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
1189 tc_name = tyConName tc
1191 lookupInsts print_unqual other = return []
1193 plausibleDFun print_unqual dfun -- Dfun involving only names that print unqualified
1194 = all ok (nameSetToList (tyClsNamesOfType (idType dfun)))
1196 ok name | isBuiltInSyntax name = True
1197 | isExternalName name =
1198 isNothing $ fst print_unqual (nameModule name)
1202 loadUnqualIfaces :: InteractiveContext -> TcM ()
1203 -- Load the home module for everything that is in scope unqualified
1204 -- This is so that we can accurately report the instances for
1206 loadUnqualIfaces ictxt
1208 mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods))
1210 unqual_mods = [ nameModule name
1211 | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt),
1212 let name = gre_name gre,
1213 not (isInternalName name),
1214 isTcOcc (nameOccName name), -- Types and classes only
1215 unQualOK gre ] -- In scope unqualified
1216 doc = ptext SLIT("Need interface for module whose export(s) are in scope unqualified")
1220 %************************************************************************
1224 %************************************************************************
1227 rnDump :: SDoc -> TcRn ()
1228 -- Dump, with a banner, if -ddump-rn
1229 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1231 tcDump :: TcGblEnv -> TcRn ()
1233 = do { dflags <- getDOpts ;
1235 -- Dump short output if -ddump-types or -ddump-tc
1236 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1237 (dumpTcRn short_dump) ;
1239 -- Dump bindings if -ddump-tc
1240 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1243 short_dump = pprTcGblEnv env
1244 full_dump = pprLHsBinds (tcg_binds env)
1245 -- NB: foreign x-d's have undefined's in their types;
1246 -- hence can't show the tc_fords
1249 = do { dflags <- getDOpts ;
1250 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1251 (dumpTcRn (pprModGuts mod_guts)) ;
1253 -- Dump bindings if -ddump-tc
1254 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1256 full_dump = pprCoreBindings (mg_binds mod_guts)
1258 -- It's unpleasant having both pprModGuts and pprModDetails here
1259 pprTcGblEnv :: TcGblEnv -> SDoc
1260 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1262 tcg_fam_insts = fam_insts,
1264 tcg_imports = imports })
1265 = vcat [ ppr_types insts type_env
1266 , ppr_tycons fam_insts type_env
1268 , ppr_fam_insts fam_insts
1269 , vcat (map ppr rules)
1270 , ppr_gen_tycons (typeEnvTyCons type_env)
1271 , ptext SLIT("Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports))
1272 , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1274 pprModGuts :: ModGuts -> SDoc
1275 pprModGuts (ModGuts { mg_types = type_env,
1277 = vcat [ ppr_types [] type_env,
1280 ppr_types :: [Instance] -> TypeEnv -> SDoc
1281 ppr_types insts type_env
1282 = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1284 dfun_ids = map instanceDFunId insts
1285 ids = [id | id <- typeEnvIds type_env, want_sig id]
1286 want_sig id | opt_PprStyle_Debug = True
1287 | otherwise = isLocalId id &&
1288 isExternalName (idName id) &&
1289 not (id `elem` dfun_ids)
1290 -- isLocalId ignores data constructors, records selectors etc.
1291 -- The isExternalName ignores local dictionary and method bindings
1292 -- that the type checker has invented. Top-level user-defined things
1293 -- have External names.
1295 ppr_tycons :: [FamInst] -> TypeEnv -> SDoc
1296 ppr_tycons fam_insts type_env
1297 = text "TYPE CONSTRUCTORS" $$ nest 4 (ppr_tydecls tycons)
1299 fi_tycons = map famInstTyCon fam_insts
1300 tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon]
1301 want_tycon tycon | opt_PprStyle_Debug = True
1302 | otherwise = not (isImplicitTyCon tycon) &&
1303 isExternalName (tyConName tycon) &&
1304 not (tycon `elem` fi_tycons)
1306 ppr_insts :: [Instance] -> SDoc
1307 ppr_insts [] = empty
1308 ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
1310 ppr_fam_insts :: [FamInst] -> SDoc
1311 ppr_fam_insts [] = empty
1312 ppr_fam_insts fam_insts =
1313 text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts)
1315 ppr_sigs :: [Var] -> SDoc
1317 -- Print type signatures; sort by OccName
1318 = vcat (map ppr_sig (sortLe le_sig ids))
1320 le_sig id1 id2 = getOccName id1 <= getOccName id2
1321 ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
1323 ppr_tydecls :: [TyCon] -> SDoc
1325 -- Print type constructor info; sort by OccName
1326 = vcat (map ppr_tycon (sortLe le_sig tycons))
1328 le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2
1330 | isCoercionTyCon tycon = ptext SLIT("coercion") <+> ppr tycon
1331 | otherwise = ppr (tyThingToIfaceDecl (ATyCon tycon))
1333 ppr_rules :: [CoreRule] -> SDoc
1334 ppr_rules [] = empty
1335 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1336 nest 4 (pprRules rs),
1339 ppr_gen_tycons [] = empty
1340 ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"),
1341 nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]