2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcModule]{Typechecking a whole module}
9 mkExportEnv, getModuleContents, tcRnStmt,
10 tcRnGetInfo, GetInfoResult,
18 #include "HsVersions.h"
22 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
25 import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
26 import Packages ( moduleToPackageConfig, mkPackageId, package,
28 import DriverState ( v_MainModIs, v_MainFunIs )
29 import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..),
30 nlHsApp, nlHsVar, pprLHsBinds )
31 import RdrHsSyn ( findSplice )
33 import PrelNames ( runMainIOName, rootMainName, mAIN,
35 import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv,
37 import TcHsSyn ( zonkTopDecls )
38 import TcExpr ( tcInferRho )
40 import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith )
41 import Inst ( showLIE )
42 import InstEnv ( extendInstEnvList )
43 import TcBinds ( tcTopBinds, tcHsBootSigs )
44 import TcDefaults ( tcDefaults )
45 import TcEnv ( tcExtendGlobalValEnv )
46 import TcRules ( tcRules )
47 import TcForeign ( tcForeignImports, tcForeignExports )
48 import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
49 import TcIface ( tcExtCoreBindings )
50 import TcSimplify ( tcSimplifyTop )
51 import TcTyClsDecls ( tcTyAndClassDecls )
52 import LoadIface ( loadOrphanModules, loadHiBootInterface )
53 import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
54 reportUnusedNames, reportDeprecations )
55 import RnEnv ( lookupSrcOcc_maybe )
56 import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec )
57 import PprCore ( pprIdRules, pprCoreBindings )
58 import CoreSyn ( IdCoreRule, bindersOfBinds )
59 import DataCon ( dataConWrapId )
60 import ErrUtils ( Messages, mkDumpDoc, showPass )
61 import Id ( mkExportedLocalId, isLocalId, idName, idType )
63 import VarEnv ( varEnvElts )
64 import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv )
65 import OccName ( mkVarOcc )
66 import Name ( Name, isExternalName, getSrcLoc, getOccName, isWiredInName )
68 import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
69 import SrcLoc ( srcLocSpan, Located(..), noLoc )
70 import DriverPhases ( HscSource(..), isHsBoot )
71 import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..),
72 GhciMode(..), IsBootInterface, noDependencies,
73 Deprecs( NoDeprecs ), plusDeprecs,
74 ForeignStubs(NoStubs), TyThing(..),
75 TypeEnv, lookupTypeEnv, hptInstances, lookupType,
76 extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
82 import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
83 LStmt, LHsExpr, LHsType, mkMatchGroup,
84 collectStmtsBinders, mkSimpleMatch,
85 nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat )
86 import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
87 Provenance(..), ImportSpec(..),
88 lookupLocalRdrEnv, extendLocalRdrEnv )
89 import RnSource ( addTcgDUs )
90 import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs )
91 import TcHsType ( kcHsType )
92 import TcExpr ( tcCheckRho )
93 import TcIface ( loadImportedInsts )
94 import TcMType ( zonkTcType, zonkQuantifiedTyVar )
95 import TcUnify ( unifyTyConApp )
96 import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) )
97 import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer )
98 import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType,
99 isUnLiftedType, tyClsNamesOfDFunHead )
100 import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
101 import RnTypes ( rnLHsType )
102 import Inst ( tcStdSyntaxName, tcGetInstEnvs )
103 import InstEnv ( DFunId, classInstances, instEnvElts )
104 import RnExpr ( rnStmts, rnLExpr )
105 import RnNames ( exportsToAvails )
106 import LoadIface ( loadSrcInterface, ifaceInstGates )
107 import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
108 IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
109 tyThingToIfaceDecl, dfunToIfaceInst )
110 import IfaceType ( IfaceTyCon(..), IfaceType, toIfaceType,
111 interactiveExtNameFun, isLocalIfaceExtName )
112 import IfaceEnv ( lookupOrig )
113 import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
114 import Id ( Id, isImplicitId, setIdType, globalIdDetails )
115 import MkId ( unsafeCoerceId )
116 import DataCon ( dataConTyCon )
117 import TyCon ( tyConName )
118 import TysWiredIn ( mkListTy, unitTy )
119 import IdInfo ( GlobalIdDetails(..) )
120 import SrcLoc ( interactiveSrcLoc, unLoc )
122 import Var ( globaliseId )
123 import Name ( nameOccName )
124 import OccName ( occNameUserString )
125 import NameEnv ( delListFromNameEnv )
126 import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName )
127 import HscTypes ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnvClasses,
128 availNames, availName, ModIface(..), icPrintUnqual,
129 ModDetails(..), Dependencies(..) )
130 import BasicTypes ( RecFlag(..), Fixity )
131 import Bag ( unitBag )
132 import ListSetOps ( removeDups )
133 import Panic ( ghcError, GhcException(..) )
134 import SrcLoc ( SrcLoc )
137 import FastString ( mkFastString )
138 import Util ( sortLe )
139 import Bag ( unionBags, snocBag )
141 import Maybe ( isJust )
146 %************************************************************************
148 Typecheck and rename a module
150 %************************************************************************
156 -> Located (HsModule RdrName)
157 -> IO (Messages, Maybe TcGblEnv)
159 tcRnModule hsc_env hsc_src (L loc (HsModule maybe_mod export_ies
160 import_decls local_decls mod_deprec))
161 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
163 let { this_mod = case maybe_mod of
164 Nothing -> mAIN -- 'module M where' is omitted
165 Just (L _ mod) -> mod } ; -- The normal case
167 initTc hsc_env hsc_src this_mod $
170 checkForPackageModule (hsc_dflags hsc_env) this_mod;
172 -- Deal with imports; sets tcg_rdr_env, tcg_imports
173 (rdr_env, imports) <- rnImports import_decls ;
175 let { dep_mods :: ModuleEnv (Module, IsBootInterface)
176 ; dep_mods = imp_dep_mods imports
178 ; is_dep_mod :: Module -> Bool
179 ; is_dep_mod mod = case lookupModuleEnv dep_mods mod of
181 Just (_, is_boot) -> not is_boot
182 ; home_insts = hptInstances hsc_env is_dep_mod
185 -- Record boot-file info in the EPS, so that it's
186 -- visible to loadHiBootInterface in tcRnSrcDecls,
187 -- and any other incrementally-performed imports
188 updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
190 -- Update the gbl env
192 gbl { tcg_rdr_env = rdr_env,
193 tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
194 tcg_imports = tcg_imports gbl `plusImportAvails` imports })
197 traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
198 -- Fail if there are any errors so far
199 -- The error printing (if needed) takes advantage
200 -- of the tcg_env we have now set
203 -- Load any orphan-module interfaces, so that
204 -- their rules and instance decls will be found
205 loadOrphanModules (imp_orphs imports) ;
207 traceRn (text "rn1a") ;
208 -- Rename and type check the declarations
209 tcg_env <- if isHsBoot hsc_src then
210 tcRnHsBootDecls local_decls
212 tcRnSrcDecls local_decls ;
213 setGblEnv tcg_env $ do {
215 traceRn (text "rn3") ;
217 -- Report the use of any deprecated things
218 -- We do this before processsing the export list so
219 -- that we don't bleat about re-exporting a deprecated
220 -- thing (especially via 'module Foo' export item)
221 -- Only uses in the body of the module are complained about
222 reportDeprecations tcg_env ;
224 -- Process the export list
225 exports <- exportsFromAvail (isJust maybe_mod) export_ies ;
227 -- Check whether the entire module is deprecated
228 -- This happens only once per module
229 let { mod_deprecs = checkModDeprec mod_deprec } ;
231 -- Add exports and deprecations to envt
232 let { final_env = tcg_env { tcg_exports = exports,
233 tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
234 tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
236 -- A module deprecation over-rides the earlier ones
239 -- Report unused names
240 reportUnusedNames export_ies final_env ;
242 -- Dump output and return
247 -- This is really a sanity check that the user has given -package-name
248 -- if necessary. -package-name is only necessary when the package database
249 -- already contains the current package, because then we can't tell
250 -- whether a given module is in the current package or not, without knowing
251 -- the name of the current package.
252 checkForPackageModule dflags this_mod
253 | not (isHomeModule dflags this_mod),
254 Just (pkg,_) <- moduleToPackageConfig dflags this_mod =
256 ppr_pkg = ppr (mkPackageId (package pkg))
258 addErr (ptext SLIT("Module") <+> quotes (ppr this_mod) <+>
259 ptext SLIT("is a member of package") <+> ppr_pkg <> char '.' $$
260 ptext SLIT("To compile this module, please use -ignore-package") <+> ppr_pkg <> char '.')
261 | otherwise = return ()
265 %************************************************************************
267 Type-checking external-core modules
269 %************************************************************************
272 tcRnExtCore :: HscEnv
274 -> IO (Messages, Maybe ModGuts)
275 -- Nothing => some error occurred
277 tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
278 -- The decls are IfaceDecls; all names are original names
279 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
281 initTc hsc_env ExtCoreFile this_mod $ do {
283 let { ldecls = map noLoc decls } ;
285 -- Deal with the type declarations; first bring their stuff
286 -- into scope, then rname them, then type check them
287 (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ;
289 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
290 tcg_imports = imports `plusImportAvails` tcg_imports gbl })
293 rn_decls <- rnTyClDecls ldecls ;
296 -- Dump trace of renaming part
297 rnDump (ppr rn_decls) ;
299 -- Typecheck them all together so that
300 -- any mutually recursive types are done right
301 tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot names -}] rn_decls) ;
302 -- Make the new type env available to stuff slurped from interface files
304 setGblEnv tcg_env $ do {
306 -- Now the core bindings
307 core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
311 bndrs = bindersOfBinds core_binds ;
312 my_exports = mkNameSet (map idName bndrs) ;
313 -- ToDo: export the data types also?
315 final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
317 mod_guts = ModGuts { mg_module = this_mod,
319 mg_usages = [], -- ToDo: compute usage
320 mg_dir_imps = [], -- ??
321 mg_deps = noDependencies, -- ??
322 mg_exports = my_exports,
323 mg_types = final_type_env,
324 mg_insts = tcg_insts tcg_env,
326 mg_binds = core_binds,
329 mg_rdr_env = emptyGlobalRdrEnv,
330 mg_fix_env = emptyFixityEnv,
331 mg_deprecs = NoDeprecs,
335 tcCoreDump mod_guts ;
340 mkFakeGroup decls -- Rather clumsy; lots of unused fields
341 = HsGroup { hs_tyclds = decls, -- This is the one we want
342 hs_valds = [], hs_fords = [],
343 hs_instds = [], hs_fixds = [], hs_depds = [],
344 hs_ruleds = [], hs_defds = [] }
348 %************************************************************************
350 Type-checking the top level of a module
352 %************************************************************************
355 tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
356 -- Returns the variables free in the decls
357 -- Reason: solely to report unused imports and bindings
359 = do { -- Load the hi-boot interface for this module, if any
360 -- We do this now so that the boot_names can be passed
361 -- to tcTyAndClassDecls, because the boot_names are
362 -- automatically considered to be loop breakers
363 boot_names <- loadHiBootInterface ;
365 -- Do all the declarations
366 (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_names decls) ;
368 -- tcSimplifyTop deals with constant or ambiguous InstIds.
369 -- How could there be ambiguous ones? They can only arise if a
370 -- top-level decl falls under the monomorphism
371 -- restriction, and no subsequent decl instantiates its
372 -- type. (Usually, ambiguous type variables are resolved
373 -- during the generalisation step.)
374 traceTc (text "Tc8") ;
375 inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
376 -- Setting the global env exposes the instances to tcSimplifyTop
377 -- Setting the local env exposes the local Ids to tcSimplifyTop,
378 -- so that we get better error messages (monomorphism restriction)
380 -- Backsubstitution. This must be done last.
381 -- Even tcSimplifyTop may do some unification.
382 traceTc (text "Tc9") ;
383 let { (tcg_env, _) = tc_envs ;
384 TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
385 tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
387 (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
390 let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
392 -- Compre the hi-boot iface (if any) with the real thing
393 checkHiBootIface final_type_env boot_names ;
395 -- Make the new type env available to stuff slurped from interface files
396 writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
398 return (tcg_env { tcg_type_env = final_type_env,
399 tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' })
402 tc_rn_src_decls :: [Name] -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
403 -- Loops around dealing with each top level inter-splice group
404 -- in turn, until it's dealt with the entire module
405 tc_rn_src_decls boot_names ds
406 = do { let { (first_group, group_tail) = findSplice ds } ;
407 -- If ds is [] we get ([], Nothing)
409 -- Type check the decls up to, but not including, the first splice
410 tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_names first_group ;
412 -- Bale out if errors; for example, error recovery when checking
413 -- the RHS of 'main' can mean that 'main' is not in the envt for
414 -- the subsequent checkMain test
419 -- If there is no splice, we're nearly done
421 Nothing -> do { -- Last thing: check for `main'
422 tcg_env <- checkMain ;
423 return (tcg_env, tcl_env)
426 -- If there's a splice, we must carry on
427 Just (SpliceDecl splice_expr, rest_ds) -> do {
429 failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
432 -- Rename the splice expression, and get its supporting decls
433 (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
434 failIfErrsM ; -- Don't typecheck if renaming failed
436 -- Execute the splice
437 spliced_decls <- tcSpliceDecls rn_splice_expr ;
439 -- Glue them on the front of the remaining decls and loop
440 setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
441 tc_rn_src_decls boot_names (spliced_decls ++ rest_ds)
446 %************************************************************************
448 Compiling hs-boot source files, and
449 comparing the hi-boot interface with the real thing
451 %************************************************************************
454 tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
455 tcRnHsBootDecls decls
456 = do { let { (first_group, group_tail) = findSplice decls }
459 Just stuff -> spliceInHsBootErr stuff
462 -- Rename the declarations
463 ; (tcg_env, rn_group) <- rnTopSrcDecls first_group
464 ; setGblEnv tcg_env $ do {
466 -- Todo: check no foreign decls, no rules, no default decls
468 -- Typecheck type/class decls
469 ; traceTc (text "Tc2")
470 ; let tycl_decls = hs_tyclds rn_group
471 ; tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot_names -}] tycl_decls)
472 ; setGblEnv tcg_env $ do {
474 -- Typecheck instance decls
475 ; traceTc (text "Tc3")
476 ; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group)
477 ; setGblEnv tcg_env $ do {
479 -- Typecheck value declarations
480 ; traceTc (text "Tc5")
481 ; new_ids <- tcHsBootSigs (hs_valds rn_group)
484 -- No simplification or zonking to do
485 ; traceTc (text "Tc7a")
486 ; gbl_env <- getGblEnv
488 ; let { final_type_env = extendTypeEnvWithIds (tcg_type_env gbl_env) new_ids }
489 ; return (gbl_env { tcg_type_env = final_type_env })
492 spliceInHsBootErr (SpliceDecl (L loc _), _)
493 = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files"))
496 In both one-shot mode and GHCi mode, hi-boot interfaces are demand-loaded
497 into the External Package Table. Once we've typechecked the body of the
498 module, we want to compare what we've found (gathered in a TypeEnv) with
499 the hi-boot stuff in the EPT. We do so here, using the export list of
500 the hi-boot interface as our checklist.
503 checkHiBootIface :: TypeEnv -> [Name] -> TcM ()
504 -- Compare the hi-boot file for this module (if there is one)
505 -- with the type environment we've just come up with
506 -- In the common case where there is no hi-boot file, the list
507 -- of boot_names is empty.
508 checkHiBootIface env boot_names
509 = mapM_ (check_one env) boot_names
512 check_one local_env name
513 | isWiredInName name -- No checking for wired-in names. In particular, 'error'
514 = return () -- is handled by a rather gross hack (see comments in GHC.Err.hs-boot)
516 = do { (eps,hpt) <- getEpsAndHpt
518 -- Look up the hi-boot one;
519 -- it should jolly well be there (else GHC bug)
520 ; case lookupType hpt (eps_PTE eps) name of {
521 Nothing -> pprPanic "checkHiBootIface" (ppr name) ;
524 -- Look it up in the local type env
525 -- It should be there, but it's a programmer error if not
526 case lookupTypeEnv local_env name of
527 Nothing -> addErrTc (missingBootThing boot_thing)
528 Just real_thing -> check_thing boot_thing real_thing
532 check_thing (ATyCon boot_tc) (ATyCon real_tc)
533 | isSynTyCon boot_tc && isSynTyCon real_tc,
534 defn1 `tcEqType` substTyWith tvs2 (mkTyVarTys tvs1) defn2
537 | tyConKind boot_tc == tyConKind real_tc
540 (tvs1, defn1) = getSynTyConDefn boot_tc
541 (tvs2, defn2) = getSynTyConDefn boot_tc
543 check_thing (AnId boot_id) (AnId real_id)
544 | idType boot_id `tcEqType` idType real_id
547 check_thing (ADataCon dc1) (ADataCon dc2)
548 | idType (dataConWrapId dc1) `tcEqType` idType (dataConWrapId dc2)
551 -- Can't declare a class in a hi-boot file
553 check_thing boot_thing real_thing -- Default case; failure
554 = addErrAt (srcLocSpan (getSrcLoc real_thing))
555 (bootMisMatch real_thing)
558 missingBootThing thing
559 = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
561 = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")
565 %************************************************************************
567 Type-checking the top level of a module
569 %************************************************************************
571 tcRnGroup takes a bunch of top-level source-code declarations, and
573 * gets supporting declarations from interface files
576 * and augments the TcGblEnv with the results
578 In Template Haskell it may be called repeatedly for each group of
579 declarations. It expects there to be an incoming TcGblEnv in the
580 monad; it augments it and returns the new TcGblEnv.
583 tcRnGroup :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
584 -- Returns the variables free in the decls, for unused-binding reporting
585 tcRnGroup boot_names decls
586 = do { -- Rename the declarations
587 (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
588 setGblEnv tcg_env $ do {
590 -- Typecheck the declarations
591 tcTopSrcDecls boot_names rn_decls
594 ------------------------------------------------
595 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
597 = do { -- Bring top level binders into scope
598 (rdr_env, imports) <- importsFromLocalDecls group ;
599 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
600 tcg_imports = imports `plusImportAvails` tcg_imports gbl })
603 traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
604 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
606 -- Rename the source decls
607 (tcg_env, rn_decls) <- rnSrcDecls group ;
610 -- Dump trace of renaming part
611 rnDump (ppr rn_decls) ;
613 return (tcg_env, rn_decls)
616 ------------------------------------------------
617 tcTopSrcDecls :: [Name] -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
618 tcTopSrcDecls boot_names
619 (HsGroup { hs_tyclds = tycl_decls,
620 hs_instds = inst_decls,
621 hs_fords = foreign_decls,
622 hs_defds = default_decls,
623 hs_ruleds = rule_decls,
624 hs_valds = val_binds })
625 = do { -- Type-check the type and class decls, and all imported decls
626 -- The latter come in via tycl_decls
627 traceTc (text "Tc2") ;
629 tcg_env <- checkNoErrs (tcTyAndClassDecls boot_names tycl_decls) ;
630 -- tcTyAndClassDecls recovers internally, but if anything gave rise to
631 -- an error we'd better stop now, to avoid a cascade
633 -- Make these type and class decls available to stuff slurped from interface files
634 writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
637 setGblEnv tcg_env $ do {
638 -- Source-language instances, including derivings,
639 -- and import the supporting declarations
640 traceTc (text "Tc3") ;
641 (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
642 setGblEnv tcg_env $ do {
644 -- Foreign import declarations next. No zonking necessary
645 -- here; we can tuck them straight into the global environment.
646 traceTc (text "Tc4") ;
647 (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
648 tcExtendGlobalValEnv fi_ids $ do {
650 -- Default declarations
651 traceTc (text "Tc4a") ;
652 default_tys <- tcDefaults default_decls ;
653 updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
655 -- Value declarations next
656 -- We also typecheck any extra binds that came out
657 -- of the "deriving" process (deriv_binds)
658 traceTc (text "Tc5") ;
659 (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ;
660 setLclTypeEnv lcl_env $ do {
662 -- Second pass over class and instance declarations,
663 traceTc (text "Tc6") ;
664 (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
665 showLIE (text "after instDecls2") ;
668 -- They need to be zonked, so we return them
669 traceTc (text "Tc7") ;
670 (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
673 rules <- tcRules rule_decls ;
676 traceTc (text "Tc7a") ;
677 tcg_env <- getGblEnv ;
678 let { all_binds = tc_val_binds `unionBags`
679 inst_binds `unionBags`
682 -- Extend the GblEnv with the (as yet un-zonked)
683 -- bindings, rules, foreign decls
684 tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
685 tcg_rules = tcg_rules tcg_env ++ rules,
686 tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
687 return (tcg_env', lcl_env)
692 %************************************************************************
696 %************************************************************************
700 = do { ghci_mode <- getGhciMode ;
701 tcg_env <- getGblEnv ;
703 mb_main_mod <- readMutVar v_MainModIs ;
704 mb_main_fn <- readMutVar v_MainFunIs ;
705 let { main_mod = case mb_main_mod of {
706 Just mod -> mkModule mod ;
708 main_fn = case mb_main_fn of {
709 Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
710 Nothing -> main_RDR_Unqual } } ;
712 check_main ghci_mode tcg_env main_mod main_fn
716 check_main ghci_mode tcg_env main_mod main_fn
717 -- If we are in module Main, check that 'main' is defined.
718 -- It may be imported from another module!
721 -- Blimey: a whole page of code to do this...
726 = addErrCtxt mainCtxt $
727 do { mb_main <- lookupSrcOcc_maybe main_fn
728 -- Check that 'main' is in scope
729 -- It might be imported from another module!
731 Nothing -> do { complain_no_main
734 { let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) }
735 -- :Main.main :: IO () = runMainIO main
737 ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
740 ; let { root_main_id = mkExportedLocalId rootMainName ty ;
741 main_bind = noLoc (VarBind root_main_id main_expr) }
743 ; return (tcg_env { tcg_binds = tcg_binds tcg_env
745 tcg_dus = tcg_dus tcg_env
746 `plusDU` usesOnly (unitFV main_name)
747 -- Record the use of 'main', so that we don't
748 -- complain about it being defined but not used
752 mod = tcg_mod tcg_env
754 complain_no_main | ghci_mode == Interactive = return ()
755 | otherwise = failWithTc noMainMsg
756 -- In interactive mode, don't worry about the absence of 'main'
757 -- In other modes, fail altogether, so that we don't go on
758 -- and complain a second time when processing the export list.
760 mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
761 noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
762 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
766 %*********************************************************
770 %*********************************************************
774 setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
775 setInteractiveContext hsc_env icxt thing_inside
777 -- Initialise the tcg_inst_env with instances
778 -- from all home modules. This mimics the more selective
779 -- call to hptInstances in tcRnModule
780 dfuns = hptInstances hsc_env (\mod -> True)
782 updGblEnv (\env -> env {
783 tcg_rdr_env = ic_rn_gbl_env icxt,
784 tcg_type_env = ic_type_env icxt,
785 tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $
787 updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt }) $
789 do { traceTc (text "setIC" <+> ppr (ic_type_env icxt))
796 -> InteractiveContext
798 -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
799 -- The returned [Name] is the same as the input except for
800 -- ExprStmt, in which case the returned [Name] is [itName]
802 -- The returned TypecheckedHsExpr is of type IO [ () ],
803 -- a list of the bound values, coerced to ().
805 tcRnStmt hsc_env ictxt rdr_stmt
806 = initTcPrintErrors hsc_env iNTERACTIVE $
807 setInteractiveContext hsc_env ictxt $ do {
809 -- Rename; use CmdLineMode because tcRnStmt is only used interactively
810 ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ;
811 traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
814 -- The real work is done here
815 (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
817 traceTc (text "tcs 1") ;
818 let { -- (a) Make all the bound ids "global" ids, now that
819 -- they're notionally top-level bindings. This is
820 -- important: otherwise when we come to compile an expression
821 -- using these ids later, the byte code generator will consider
822 -- the occurrences to be free rather than global.
824 -- (b) Tidy their types; this is important, because :info may
825 -- ask to look at them, and :info expects the things it looks
826 -- up to have tidy types
827 global_ids = map globaliseAndTidy bound_ids ;
829 -- Update the interactive context
830 rn_env = ic_rn_local_env ictxt ;
831 type_env = ic_type_env ictxt ;
833 bound_names = map idName global_ids ;
834 new_rn_env = extendLocalRdrEnv rn_env bound_names ;
836 -- Remove any shadowed bindings from the type_env;
837 -- they are inaccessible but might, I suppose, cause
838 -- a space leak if we leave them there
839 shadowed = [ n | name <- bound_names,
840 let rdr_name = mkRdrUnqual (nameOccName name),
841 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
843 filtered_type_env = delListFromNameEnv type_env shadowed ;
844 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
846 new_ic = ictxt { ic_rn_local_env = new_rn_env,
847 ic_type_env = new_type_env }
850 dumpOptTcRn Opt_D_dump_tc
851 (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
852 text "Typechecked expr" <+> ppr tc_expr]) ;
854 returnM (new_ic, bound_names, tc_expr)
857 globaliseAndTidy :: Id -> Id
859 -- Give the Id a Global Name, and tidy its type
860 = setIdType (globaliseId VanillaGlobal id) tidy_type
862 tidy_type = tidyTopType (idType id)
865 Here is the grand plan, implemented in tcUserStmt
867 What you type The IO [HValue] that hscStmt returns
868 ------------- ------------------------------------
869 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
872 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
875 expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it]
876 [NB: result not printed] bindings: [it]
878 expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it]
879 result showable) bindings: [it]
881 expr (of non-IO type,
882 result not showable) ==> error
886 ---------------------------
887 tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
888 tcUserStmt (L _ (ExprStmt expr _))
889 = newUnique `thenM` \ uniq ->
891 fresh_it = itName uniq
892 the_bind = noLoc $ FunBind (noLoc fresh_it) False
893 (mkMatchGroup [mkSimpleMatch [] expr])
895 tryTcLIE_ (do { -- Try this if the other fails
896 traceTc (text "tcs 1b") ;
898 nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
899 nlExprStmt (nlHsApp (nlHsVar printName)
902 (do { -- Try this first
903 traceTc (text "tcs 1a") ;
904 tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] })
906 tcUserStmt stmt = tc_stmts [stmt]
908 ---------------------------
910 = do { ioTyCon <- tcLookupTyCon ioTyConName ;
912 ret_ty = mkListTy unitTy ;
913 io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
915 names = map unLoc (collectStmtsBinders stmts) ;
917 stmt_ctxt = SC { sc_what = DoExpr,
919 sc_body = check_body,
922 infer_rhs rhs = do { (rhs', rhs_ty) <- tcInferRho rhs
923 ; [pat_ty] <- unifyTyConApp ioTyCon rhs_ty
924 ; return (rhs', pat_ty) } ;
925 check_body body = tcCheckRho body io_ret_ty ;
927 -- mk_return builds the expression
928 -- returnIO @ [()] [coerce () x, .., coerce () z]
930 -- Despite the inconvenience of building the type applications etc,
931 -- this *has* to be done in type-annotated post-typecheck form
932 -- because we are going to return a list of *polymorphic* values
933 -- coerced to type (). If we built a *source* stmt
934 -- return [coerce x, ..., coerce z]
935 -- then the type checker would instantiate x..z, and we wouldn't
936 -- get their *polymorphic* values. (And we'd get ambiguity errs
937 -- if they were overloaded, since they aren't applied to anything.)
938 mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
939 (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
940 mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
943 io_ty = mkTyConApp ioTyCon []
946 -- OK, we're ready to typecheck the stmts
947 traceTc (text "tcs 2") ;
948 ((ids, tc_expr), lie) <- getLIE $ do {
949 (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts $
951 -- Look up the names right in the middle,
952 -- where they will all be in scope
953 ids <- mappM tcLookupId names ;
954 ret_id <- tcLookupId returnIOName ; -- return @ IO
955 return (ids, [nlResultStmt (mk_return ret_id ids)]) } ;
957 io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
958 return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty))
961 -- Simplify the context right here, so that we fail
962 -- if there aren't enough instances. Notably, when we see
964 -- we use recoverTc_ to try it <- e
965 -- and then let it = e
966 -- It's the simplify step that rejects the first.
967 traceTc (text "tcs 3") ;
968 const_binds <- tcSimplifyInteractive lie ;
970 -- Build result expression and zonk it
971 let { expr = mkHsLet const_binds tc_expr } ;
972 zonked_expr <- zonkTopLExpr expr ;
973 zonked_ids <- zonkTopBndrs ids ;
975 -- None of the Ids should be of unboxed type, because we
976 -- cast them all to HValues in the end!
977 mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
979 return (zonked_ids, zonked_expr)
982 combine stmt (ids, stmts) = (ids, stmt:stmts)
983 bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
984 nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
988 tcRnExpr just finds the type of an expression
992 -> InteractiveContext
995 tcRnExpr hsc_env ictxt rdr_expr
996 = initTcPrintErrors hsc_env iNTERACTIVE $
997 setInteractiveContext hsc_env ictxt $ do {
999 (rn_expr, fvs) <- rnLExpr rdr_expr ;
1002 -- Now typecheck the expression;
1003 -- it might have a rank-2 type (e.g. :t runST)
1004 ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
1005 ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
1006 tcSimplifyInteractive lie_top ;
1007 qtvs' <- mappM zonkQuantifiedTyVar qtvs ;
1009 let { all_expr_ty = mkForAllTys qtvs' $
1010 mkFunTys (map idType dict_ids) $
1012 zonkTcType all_expr_ty
1015 smpl_doc = ptext SLIT("main expression")
1018 tcRnType just finds the kind of a type
1022 -> InteractiveContext
1025 tcRnType hsc_env ictxt rdr_type
1026 = initTcPrintErrors hsc_env iNTERACTIVE $
1027 setInteractiveContext hsc_env ictxt $ do {
1029 rn_type <- rnLHsType doc rdr_type ;
1032 -- Now kind-check the type
1033 (ty', kind) <- kcHsType rn_type ;
1037 doc = ptext SLIT("In GHCi input")
1043 %************************************************************************
1045 More GHCi stuff, to do with browsing and getting info
1047 %************************************************************************
1051 mkExportEnv :: HscEnv -> [Module] -- Expose these modules' exports only
1053 mkExportEnv hsc_env exports
1054 = do { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $
1055 mappM getModuleExports exports
1057 Just envs -> return (foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs)
1058 Nothing -> return emptyGlobalRdrEnv
1059 -- Some error; initTc will have printed it
1062 getModuleExports :: Module -> TcM GlobalRdrEnv
1063 getModuleExports mod
1064 = do { iface <- load_iface mod
1065 ; loadOrphanModules (dep_orphs (mi_deps iface))
1066 -- Load any orphan-module interfaces,
1067 -- so their instances are visible
1068 ; names <- exportsToAvails (mi_exports iface)
1069 ; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod }
1070 | name <- nameSetToList names ] }
1071 ; returnM (mkGlobalRdrEnv gres) }
1073 vanillaProv :: Module -> Provenance
1074 -- We're building a GlobalRdrEnv as if the user imported
1075 -- all the specified modules into the global interactive module
1076 vanillaProv mod = Imported [ImportSpec mod mod False
1077 (srcLocSpan interactiveSrcLoc)] False
1083 -> InteractiveContext
1084 -> Module -- Module to inspect
1085 -> Bool -- Grab just the exports, or the whole toplev
1086 -> IO (Maybe [IfaceDecl])
1088 getModuleContents hsc_env ictxt mod exports_only
1089 = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only)
1091 get_mod_contents exports_only
1092 | not exports_only -- We want the whole top-level type env
1093 -- so it had better be a home module
1094 = do { hpt <- getHpt
1095 ; case lookupModuleEnv hpt mod of
1096 Just mod_info -> return (map (toIfaceDecl ext_nm) $
1099 md_types (hm_details mod_info))
1100 Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod)))
1101 -- This is a system error; the module should be in the HPT
1104 | otherwise -- Want the exports only
1105 = do { iface <- load_iface mod
1106 ; mappM get_decl [ (mod,avail) | (mod, avails) <- mi_exports iface
1110 get_decl (mod, avail)
1111 = do { main_name <- lookupOrig mod (availName avail)
1112 ; thing <- tcLookupGlobal main_name
1113 ; return (filter_decl (availNames avail) (toIfaceDecl ext_nm thing)) }
1115 ext_nm = interactiveExtNameFun (icPrintUnqual ictxt)
1117 ---------------------
1118 filter_decl occs decl@(IfaceClass {ifSigs = sigs})
1119 = decl { ifSigs = filter (keep_sig occs) sigs }
1120 filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon th cons})
1121 = decl { ifCons = IfDataTyCon th (filter (keep_con occs) cons) }
1122 filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
1123 | keep_con occs con = decl
1124 | otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm?
1125 filter_decl occs decl
1128 keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs
1129 keep_con occs con = ifConOcc con `elem` occs
1131 wantToSee (AnId id) = not (isImplicitId id)
1132 wantToSee (ADataCon _) = False -- They'll come via their TyCon
1135 ---------------------
1136 load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
1138 doc = ptext SLIT("context for compiling statements")
1140 ---------------------
1141 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
1142 <+> quotes (ppr mod)
1146 type GetInfoResult = (String, IfaceDecl, Fixity, SrcLoc,
1147 [(IfaceType,SrcLoc)] -- Instances
1150 tcRnGetInfo :: HscEnv
1151 -> InteractiveContext
1153 -> IO (Maybe [GetInfoResult])
1155 -- Used to implemnent :info in GHCi
1157 -- Look up a RdrName and return all the TyThings it might be
1158 -- A capitalised RdrName is given to us in the DataName namespace,
1159 -- but we want to treat it as *both* a data constructor
1160 -- *and* as a type or class constructor;
1161 -- hence the call to dataTcOccs, and we return up to two results
1162 tcRnGetInfo hsc_env ictxt rdr_name
1163 = initTcPrintErrors hsc_env iNTERACTIVE $
1164 setInteractiveContext hsc_env ictxt $ do {
1166 -- If the identifier is a constructor (begins with an
1167 -- upper-case letter), then we need to consider both
1168 -- constructor and type class identifiers.
1169 let { rdr_names = dataTcOccs rdr_name } ;
1171 -- results :: [(Messages, Maybe Name)]
1172 results <- mapM (tryTc . lookupOccRn) rdr_names ;
1174 traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
1175 -- The successful lookups will be (Just name)
1176 let { (warns_s, good_names) = unzip [ (msgs, name)
1177 | (msgs, Just name) <- results] ;
1178 errs_s = [msgs | (msgs, Nothing) <- results] } ;
1180 -- Fail if nothing good happened, else add warnings
1181 if null good_names then
1182 -- No lookup succeeded, so
1183 -- pick the first error message and report it
1184 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
1185 -- while the other is "X is not in scope",
1186 -- we definitely want the former; but we might pick the latter
1187 do { addMessages (head errs_s) ; failM }
1188 else -- Add deprecation warnings
1189 mapM_ addMessages warns_s ;
1191 -- And lookup up the entities, avoiding duplicates, which arise
1192 -- because constructors and record selectors are represented by
1193 -- their parent declaration
1194 let { do_one name = do { thing <- tcLookupGlobal name
1195 ; fixity <- lookupFixityRn name
1196 ; dfuns <- lookupInsts ext_nm thing
1197 ; return (str, toIfaceDecl ext_nm thing, fixity,
1199 [(toIfaceType ext_nm (idType dfun), getSrcLoc dfun) | dfun <- dfuns]
1202 -- str is the the naked occurrence name
1203 -- after stripping off qualification and parens (+)
1204 str = occNameUserString (nameOccName name)
1207 -- For the SrcLoc, the 'thing' has better info than
1208 -- the 'name' because getting the former forced the
1209 -- declaration to be loaded into the cache
1211 results <- mapM do_one good_names ;
1212 return (fst (removeDups cmp results))
1215 cmp (_,d1,_,_,_) (_,d2,_,_,_) = ifName d1 `compare` ifName d2
1216 ext_nm = interactiveExtNameFun (icPrintUnqual ictxt)
1219 lookupInsts :: (Name -> IfaceExtName) -> TyThing -> TcM [DFunId]
1220 -- Filter the instances by the ones whose tycons (or clases resp)
1221 -- are in scope unqualified. Otherwise we list a whole lot too many!
1222 lookupInsts ext_nm (AClass cls)
1223 = do { loadImportedInsts cls [] -- [] means load all instances for cls
1224 ; inst_envs <- tcGetInstEnvs
1226 | (_,_,dfun) <- classInstances inst_envs cls
1227 , let (_, tycons) = ifaceInstGates (ifInstHead (dfunToIfaceInst ext_nm dfun))
1228 -- Rather an indirect/inefficient test, but there we go
1229 , all print_tycon_unqual tycons ] }
1231 print_tycon_unqual (IfaceTc nm) = isLocalIfaceExtName nm
1232 print_tycon_unqual other = True -- Int etc
1235 lookupInsts ext_nm (ATyCon tc)
1236 = do { eps <- getEps -- Load all instances for all classes that are
1237 -- in the type environment (which are all the ones
1238 -- we've seen in any interface file so far)
1239 ; mapM_ (\c -> loadImportedInsts c [])
1240 (typeEnvClasses (eps_PTE eps))
1241 ; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all
1243 | (_, _, dfun) <- instEnvElts home_ie ++ instEnvElts pkg_ie
1245 , let (cls, _) = ifaceInstGates (ifInstHead (dfunToIfaceInst ext_nm dfun))
1246 , isLocalIfaceExtName cls ] }
1248 relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
1249 tc_name = tyConName tc
1251 lookupInsts ext_nm other = return []
1254 toIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl
1255 toIfaceDecl ext_nm thing
1256 = tyThingToIfaceDecl True -- Discard IdInfo
1257 emptyNameSet -- Show data cons
1258 ext_nm (munge thing)
1260 -- munge transforms a thing to its "parent" thing
1261 munge (ADataCon dc) = ATyCon (dataConTyCon dc)
1262 munge (AnId id) = case globalIdDetails id of
1263 RecordSelId tc lbl -> ATyCon tc
1264 ClassOpId cls -> AClass cls
1266 munge other_thing = other_thing
1270 %************************************************************************
1274 %************************************************************************
1277 rnDump :: SDoc -> TcRn ()
1278 -- Dump, with a banner, if -ddump-rn
1279 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1281 tcDump :: TcGblEnv -> TcRn ()
1283 = do { dflags <- getDOpts ;
1285 -- Dump short output if -ddump-types or -ddump-tc
1286 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1287 (dumpTcRn short_dump) ;
1289 -- Dump bindings if -ddump-tc
1290 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1293 short_dump = pprTcGblEnv env
1294 full_dump = pprLHsBinds (tcg_binds env)
1295 -- NB: foreign x-d's have undefined's in their types;
1296 -- hence can't show the tc_fords
1299 = do { dflags <- getDOpts ;
1300 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1301 (dumpTcRn (pprModGuts mod_guts)) ;
1303 -- Dump bindings if -ddump-tc
1304 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1306 full_dump = pprCoreBindings (mg_binds mod_guts)
1308 -- It's unpleasant having both pprModGuts and pprModDetails here
1309 pprTcGblEnv :: TcGblEnv -> SDoc
1310 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1311 tcg_insts = dfun_ids,
1313 tcg_imports = imports })
1314 = vcat [ ppr_types dfun_ids type_env
1315 , ppr_insts dfun_ids
1316 , vcat (map ppr rules)
1317 , ppr_gen_tycons (typeEnvTyCons type_env)
1318 , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports))
1319 , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1321 pprModGuts :: ModGuts -> SDoc
1322 pprModGuts (ModGuts { mg_types = type_env,
1324 = vcat [ ppr_types [] type_env,
1328 ppr_types :: [Var] -> TypeEnv -> SDoc
1329 ppr_types dfun_ids type_env
1330 = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1332 ids = [id | id <- typeEnvIds type_env, want_sig id]
1333 want_sig id | opt_PprStyle_Debug = True
1334 | otherwise = isLocalId id &&
1335 isExternalName (idName id) &&
1336 not (id `elem` dfun_ids)
1337 -- isLocalId ignores data constructors, records selectors etc.
1338 -- The isExternalName ignores local dictionary and method bindings
1339 -- that the type checker has invented. Top-level user-defined things
1340 -- have External names.
1342 ppr_insts :: [Var] -> SDoc
1343 ppr_insts [] = empty
1344 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1346 ppr_sigs :: [Var] -> SDoc
1348 -- Print type signatures; sort by OccName
1349 = vcat (map ppr_sig (sortLe le_sig ids))
1351 le_sig id1 id2 = getOccName id1 <= getOccName id2
1352 ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
1354 ppr_rules :: [IdCoreRule] -> SDoc
1355 ppr_rules [] = empty
1356 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1357 nest 4 (pprIdRules rs),
1360 ppr_gen_tycons [] = empty
1361 ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"),
1362 nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]