2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcModule]{Typechecking a whole module}
9 mkExportEnv, getModuleContents, tcRnStmt,
10 tcRnGetInfo, tcRnExpr, tcRnType,
17 #include "HsVersions.h"
20 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
23 import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt )
24 import Packages ( moduleToPackageConfig, mkPackageId, package,
26 import DriverState ( v_MainModIs, v_MainFunIs )
27 import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..),
28 nlHsApp, nlHsVar, pprLHsBinds )
29 import RdrHsSyn ( findSplice )
31 import PrelNames ( runMainIOName, rootMainName, mAIN,
33 import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv,
35 import TcHsSyn ( zonkTopDecls )
36 import TcExpr ( tcInferRho )
38 import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith )
39 import Inst ( showLIE )
40 import InstEnv ( extendInstEnvList )
41 import TcBinds ( tcTopBinds, tcHsBootSigs )
42 import TcDefaults ( tcDefaults )
43 import TcEnv ( tcExtendGlobalValEnv )
44 import TcRules ( tcRules )
45 import TcForeign ( tcForeignImports, tcForeignExports )
46 import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
47 import TcIface ( tcExtCoreBindings )
48 import TcSimplify ( tcSimplifyTop )
49 import TcTyClsDecls ( tcTyAndClassDecls )
50 import LoadIface ( loadOrphanModules, loadHiBootInterface )
51 import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
52 reportUnusedNames, reportDeprecations )
53 import RnEnv ( lookupSrcOcc_maybe )
54 import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec )
55 import PprCore ( pprIdRules, pprCoreBindings )
56 import CoreSyn ( IdCoreRule, bindersOfBinds )
57 import DataCon ( dataConWrapId )
58 import ErrUtils ( Messages, mkDumpDoc, showPass )
59 import Id ( mkExportedLocalId, isLocalId, idName, idType )
61 import VarEnv ( varEnvElts )
62 import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv )
63 import OccName ( mkVarOcc )
64 import Name ( Name, isExternalName, getSrcLoc, getOccName, isWiredInName )
66 import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
67 import SrcLoc ( srcLocSpan, Located(..), noLoc )
68 import DriverPhases ( HscSource(..), isHsBoot )
69 import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..),
70 GhciMode(..), IsBootInterface, noDependencies,
71 Deprecs( NoDeprecs ), plusDeprecs,
72 ForeignStubs(NoStubs), TyThing(..),
73 TypeEnv, lookupTypeEnv, hptInstances, lookupType,
74 extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
80 import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
81 LStmt, LHsExpr, LHsType, mkMatchGroup,
82 collectStmtsBinders, mkSimpleMatch,
83 nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat )
84 import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
85 Provenance(..), ImportSpec(..),
86 lookupLocalRdrEnv, extendLocalRdrEnv )
87 import RnSource ( addTcgDUs )
88 import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs )
89 import TcHsType ( kcHsType )
90 import TcExpr ( tcCheckRho )
91 import TcIface ( loadImportedInsts )
92 import TcMType ( zonkTcType, zonkQuantifiedTyVar )
93 import TcUnify ( unifyTyConApp )
94 import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) )
95 import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer )
96 import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType,
97 isUnLiftedType, tyClsNamesOfDFunHead )
98 import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
99 import RnTypes ( rnLHsType )
100 import Inst ( tcStdSyntaxName, tcGetInstEnvs )
101 import InstEnv ( classInstances, instEnvElts )
102 import RnExpr ( rnStmts, rnLExpr )
103 import RnNames ( exportsToAvails )
104 import LoadIface ( loadSrcInterface, ifaceInstGates )
105 import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
106 IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
107 tyThingToIfaceDecl, dfunToIfaceInst )
108 import IfaceType ( IfaceTyCon(..), ifPrintUnqual )
109 import IfaceEnv ( lookupOrig )
110 import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
111 import Id ( Id, isImplicitId, setIdType, globalIdDetails )
112 import MkId ( unsafeCoerceId )
113 import DataCon ( dataConTyCon )
114 import TyCon ( tyConName )
115 import TysWiredIn ( mkListTy, unitTy )
116 import IdInfo ( GlobalIdDetails(..) )
117 import SrcLoc ( interactiveSrcLoc, unLoc )
119 import Var ( globaliseId )
120 import Name ( nameOccName, nameModule )
121 import NameEnv ( delListFromNameEnv )
122 import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName )
123 import HscTypes ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnvClasses,
124 availNames, availName, ModIface(..), icPrintUnqual,
125 ModDetails(..), Dependencies(..) )
126 import BasicTypes ( RecFlag(..), Fixity )
127 import Bag ( unitBag )
128 import ListSetOps ( removeDups )
129 import Panic ( ghcError, GhcException(..) )
130 import SrcLoc ( SrcLoc )
133 import FastString ( mkFastString )
134 import Util ( sortLe )
135 import Bag ( unionBags, snocBag )
137 import Maybe ( isJust )
142 %************************************************************************
144 Typecheck and rename a module
146 %************************************************************************
152 -> Located (HsModule RdrName)
153 -> IO (Messages, Maybe TcGblEnv)
155 tcRnModule hsc_env hsc_src (L loc (HsModule maybe_mod export_ies
156 import_decls local_decls mod_deprec))
157 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
159 let { this_mod = case maybe_mod of
160 Nothing -> mAIN -- 'module M where' is omitted
161 Just (L _ mod) -> mod } ; -- The normal case
163 initTc hsc_env hsc_src this_mod $
166 checkForPackageModule (hsc_dflags hsc_env) this_mod;
168 -- Deal with imports; sets tcg_rdr_env, tcg_imports
169 (rdr_env, imports) <- rnImports import_decls ;
171 let { dep_mods :: ModuleEnv (Module, IsBootInterface)
172 ; dep_mods = imp_dep_mods imports
174 ; is_dep_mod :: Module -> Bool
175 ; is_dep_mod mod = case lookupModuleEnv dep_mods mod of
177 Just (_, is_boot) -> not is_boot
178 ; home_insts = hptInstances hsc_env is_dep_mod
181 -- Record boot-file info in the EPS, so that it's
182 -- visible to loadHiBootInterface in tcRnSrcDecls,
183 -- and any other incrementally-performed imports
184 updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
186 -- Update the gbl env
188 gbl { tcg_rdr_env = rdr_env,
189 tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
190 tcg_imports = tcg_imports gbl `plusImportAvails` imports })
193 traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
194 -- Fail if there are any errors so far
195 -- The error printing (if needed) takes advantage
196 -- of the tcg_env we have now set
199 -- Load any orphan-module interfaces, so that
200 -- their rules and instance decls will be found
201 loadOrphanModules (imp_orphs imports) ;
203 traceRn (text "rn1a") ;
204 -- Rename and type check the declarations
205 tcg_env <- if isHsBoot hsc_src then
206 tcRnHsBootDecls local_decls
208 tcRnSrcDecls local_decls ;
209 setGblEnv tcg_env $ do {
211 traceRn (text "rn3") ;
213 -- Report the use of any deprecated things
214 -- We do this before processsing the export list so
215 -- that we don't bleat about re-exporting a deprecated
216 -- thing (especially via 'module Foo' export item)
217 -- Only uses in the body of the module are complained about
218 reportDeprecations tcg_env ;
220 -- Process the export list
221 exports <- exportsFromAvail (isJust maybe_mod) export_ies ;
223 -- Check whether the entire module is deprecated
224 -- This happens only once per module
225 let { mod_deprecs = checkModDeprec mod_deprec } ;
227 -- Add exports and deprecations to envt
228 let { final_env = tcg_env { tcg_exports = exports,
229 tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
230 tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
232 -- A module deprecation over-rides the earlier ones
235 -- Report unused names
236 reportUnusedNames final_env ;
238 -- Dump output and return
243 -- This is really a sanity check that the user has given -package-name
244 -- if necessary. -package-name is only necessary when the package database
245 -- already contains the current package, because then we can't tell
246 -- whether a given module is in the current package or not, without knowing
247 -- the name of the current package.
248 checkForPackageModule dflags this_mod
249 | not (isHomeModule dflags this_mod),
250 Just (pkg,_) <- moduleToPackageConfig dflags this_mod =
252 ppr_pkg = ppr (mkPackageId (package pkg))
254 addErr (ptext SLIT("Module") <+> quotes (ppr this_mod) <+>
255 ptext SLIT("is a member of package") <+> ppr_pkg <> char '.' $$
256 ptext SLIT("To compile this module, please use -ignore-package") <+> ppr_pkg <> char '.')
257 | otherwise = return ()
261 %************************************************************************
263 Type-checking external-core modules
265 %************************************************************************
268 tcRnExtCore :: HscEnv
270 -> IO (Messages, Maybe ModGuts)
271 -- Nothing => some error occurred
273 tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
274 -- The decls are IfaceDecls; all names are original names
275 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
277 initTc hsc_env ExtCoreFile this_mod $ do {
279 let { ldecls = map noLoc decls } ;
281 -- Deal with the type declarations; first bring their stuff
282 -- into scope, then rname them, then type check them
283 (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ;
285 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
286 tcg_imports = imports `plusImportAvails` tcg_imports gbl })
289 rn_decls <- rnTyClDecls ldecls ;
292 -- Dump trace of renaming part
293 rnDump (ppr rn_decls) ;
295 -- Typecheck them all together so that
296 -- any mutually recursive types are done right
297 tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot names -}] rn_decls) ;
298 -- Make the new type env available to stuff slurped from interface files
300 setGblEnv tcg_env $ do {
302 -- Now the core bindings
303 core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
307 bndrs = bindersOfBinds core_binds ;
308 my_exports = mkNameSet (map idName bndrs) ;
309 -- ToDo: export the data types also?
311 final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
313 mod_guts = ModGuts { mg_module = this_mod,
315 mg_usages = [], -- ToDo: compute usage
316 mg_dir_imps = [], -- ??
317 mg_deps = noDependencies, -- ??
318 mg_exports = my_exports,
319 mg_types = final_type_env,
320 mg_insts = tcg_insts tcg_env,
322 mg_binds = core_binds,
325 mg_rdr_env = emptyGlobalRdrEnv,
326 mg_fix_env = emptyFixityEnv,
327 mg_deprecs = NoDeprecs,
331 tcCoreDump mod_guts ;
336 mkFakeGroup decls -- Rather clumsy; lots of unused fields
337 = HsGroup { hs_tyclds = decls, -- This is the one we want
338 hs_valds = [], hs_fords = [],
339 hs_instds = [], hs_fixds = [], hs_depds = [],
340 hs_ruleds = [], hs_defds = [] }
344 %************************************************************************
346 Type-checking the top level of a module
348 %************************************************************************
351 tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
352 -- Returns the variables free in the decls
353 -- Reason: solely to report unused imports and bindings
355 = do { -- Load the hi-boot interface for this module, if any
356 -- We do this now so that the boot_names can be passed
357 -- to tcTyAndClassDecls, because the boot_names are
358 -- automatically considered to be loop breakers
359 boot_names <- loadHiBootInterface ;
361 -- Do all the declarations
362 (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_names decls) ;
364 -- tcSimplifyTop deals with constant or ambiguous InstIds.
365 -- How could there be ambiguous ones? They can only arise if a
366 -- top-level decl falls under the monomorphism
367 -- restriction, and no subsequent decl instantiates its
368 -- type. (Usually, ambiguous type variables are resolved
369 -- during the generalisation step.)
370 traceTc (text "Tc8") ;
371 inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
372 -- Setting the global env exposes the instances to tcSimplifyTop
373 -- Setting the local env exposes the local Ids to tcSimplifyTop,
374 -- so that we get better error messages (monomorphism restriction)
376 -- Backsubstitution. This must be done last.
377 -- Even tcSimplifyTop may do some unification.
378 traceTc (text "Tc9") ;
379 let { (tcg_env, _) = tc_envs ;
380 TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
381 tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
383 (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
386 let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
388 -- Compre the hi-boot iface (if any) with the real thing
389 checkHiBootIface final_type_env boot_names ;
391 -- Make the new type env available to stuff slurped from interface files
392 writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
394 return (tcg_env { tcg_type_env = final_type_env,
395 tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' })
398 tc_rn_src_decls :: [Name] -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
399 -- Loops around dealing with each top level inter-splice group
400 -- in turn, until it's dealt with the entire module
401 tc_rn_src_decls boot_names ds
402 = do { let { (first_group, group_tail) = findSplice ds } ;
403 -- If ds is [] we get ([], Nothing)
405 -- Type check the decls up to, but not including, the first splice
406 tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_names first_group ;
408 -- Bale out if errors; for example, error recovery when checking
409 -- the RHS of 'main' can mean that 'main' is not in the envt for
410 -- the subsequent checkMain test
415 -- If there is no splice, we're nearly done
417 Nothing -> do { -- Last thing: check for `main'
418 tcg_env <- checkMain ;
419 return (tcg_env, tcl_env)
422 -- If there's a splice, we must carry on
423 Just (SpliceDecl splice_expr, rest_ds) -> do {
425 failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
428 -- Rename the splice expression, and get its supporting decls
429 (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
430 failIfErrsM ; -- Don't typecheck if renaming failed
432 -- Execute the splice
433 spliced_decls <- tcSpliceDecls rn_splice_expr ;
435 -- Glue them on the front of the remaining decls and loop
436 setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
437 tc_rn_src_decls boot_names (spliced_decls ++ rest_ds)
442 %************************************************************************
444 Compiling hs-boot source files, and
445 comparing the hi-boot interface with the real thing
447 %************************************************************************
450 tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
451 tcRnHsBootDecls decls
452 = do { let { (first_group, group_tail) = findSplice decls }
455 Just stuff -> spliceInHsBootErr stuff
458 -- Rename the declarations
459 ; (tcg_env, rn_group) <- rnTopSrcDecls first_group
460 ; setGblEnv tcg_env $ do {
462 -- Todo: check no foreign decls, no rules, no default decls
464 -- Typecheck type/class decls
465 ; traceTc (text "Tc2")
466 ; let tycl_decls = hs_tyclds rn_group
467 ; tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot_names -}] tycl_decls)
468 ; setGblEnv tcg_env $ do {
470 -- Typecheck instance decls
471 ; traceTc (text "Tc3")
472 ; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group)
473 ; setGblEnv tcg_env $ do {
475 -- Typecheck value declarations
476 ; traceTc (text "Tc5")
477 ; (tc_val_binds, lcl_env) <- tcHsBootSigs (hs_valds rn_group)
480 -- No simplification or zonking to do
481 ; traceTc (text "Tc7a")
482 ; gbl_env <- getGblEnv
484 ; let { new_ids = [ id | ATcId id _ _ <- varEnvElts (tcl_env lcl_env) ]
485 ; final_type_env = extendTypeEnvWithIds (tcg_type_env gbl_env) new_ids }
487 ; return (gbl_env { tcg_type_env = final_type_env })
490 spliceInHsBootErr (SpliceDecl (L loc _), _)
491 = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files"))
494 In both one-shot mode and GHCi mode, hi-boot interfaces are demand-loaded
495 into the External Package Table. Once we've typechecked the body of the
496 module, we want to compare what we've found (gathered in a TypeEnv) with
497 the hi-boot stuff in the EPT. We do so here, using the export list of
498 the hi-boot interface as our checklist.
501 checkHiBootIface :: TypeEnv -> [Name] -> TcM ()
502 -- Compare the hi-boot file for this module (if there is one)
503 -- with the type environment we've just come up with
504 -- In the common case where there is no hi-boot file, the list
505 -- of boot_names is empty.
506 checkHiBootIface env boot_names
507 = mapM_ (check_one env) boot_names
510 check_one local_env name
511 | isWiredInName name -- No checking for wired-in names. In particular, 'error'
512 = return () -- is handled by a rather gross hack (see comments in GHC.Err.hs-boot)
514 = do { (eps,hpt) <- getEpsAndHpt
516 -- Look up the hi-boot one;
517 -- it should jolly well be there (else GHC bug)
518 ; case lookupType hpt (eps_PTE eps) name of {
519 Nothing -> pprPanic "checkHiBootIface" (ppr name) ;
522 -- Look it up in the local type env
523 -- It should be there, but it's a programmer error if not
524 case lookupTypeEnv local_env name of
525 Nothing -> addErrTc (missingBootThing boot_thing)
526 Just real_thing -> check_thing boot_thing real_thing
530 check_thing (ATyCon boot_tc) (ATyCon real_tc)
531 | isSynTyCon boot_tc && isSynTyCon real_tc,
532 defn1 `tcEqType` substTyWith tvs2 (mkTyVarTys tvs1) defn2
535 | tyConKind boot_tc == tyConKind real_tc
538 (tvs1, defn1) = getSynTyConDefn boot_tc
539 (tvs2, defn2) = getSynTyConDefn boot_tc
541 check_thing (AnId boot_id) (AnId real_id)
542 | idType boot_id `tcEqType` idType real_id
545 check_thing (ADataCon dc1) (ADataCon dc2)
546 | idType (dataConWrapId dc1) `tcEqType` idType (dataConWrapId dc2)
549 -- Can't declare a class in a hi-boot file
551 check_thing boot_thing real_thing -- Default case; failure
552 = addErrAt (srcLocSpan (getSrcLoc real_thing))
553 (bootMisMatch real_thing)
556 missingBootThing thing
557 = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
559 = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")
563 %************************************************************************
565 Type-checking the top level of a module
567 %************************************************************************
569 tcRnGroup takes a bunch of top-level source-code declarations, and
571 * gets supporting declarations from interface files
574 * and augments the TcGblEnv with the results
576 In Template Haskell it may be called repeatedly for each group of
577 declarations. It expects there to be an incoming TcGblEnv in the
578 monad; it augments it and returns the new TcGblEnv.
581 tcRnGroup :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
582 -- Returns the variables free in the decls, for unused-binding reporting
583 tcRnGroup boot_names decls
584 = do { -- Rename the declarations
585 (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
586 setGblEnv tcg_env $ do {
588 -- Typecheck the declarations
589 tcTopSrcDecls boot_names rn_decls
592 ------------------------------------------------
593 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
595 = do { -- Bring top level binders into scope
596 (rdr_env, imports) <- importsFromLocalDecls group ;
597 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
598 tcg_imports = imports `plusImportAvails` tcg_imports gbl })
601 traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
602 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
604 -- Rename the source decls
605 (tcg_env, rn_decls) <- rnSrcDecls group ;
608 -- Dump trace of renaming part
609 rnDump (ppr rn_decls) ;
611 return (tcg_env, rn_decls)
614 ------------------------------------------------
615 tcTopSrcDecls :: [Name] -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
616 tcTopSrcDecls boot_names
617 (HsGroup { hs_tyclds = tycl_decls,
618 hs_instds = inst_decls,
619 hs_fords = foreign_decls,
620 hs_defds = default_decls,
621 hs_ruleds = rule_decls,
622 hs_valds = val_binds })
623 = do { -- Type-check the type and class decls, and all imported decls
624 -- The latter come in via tycl_decls
625 traceTc (text "Tc2") ;
627 tcg_env <- checkNoErrs (tcTyAndClassDecls boot_names tycl_decls) ;
628 -- tcTyAndClassDecls recovers internally, but if anything gave rise to
629 -- an error we'd better stop now, to avoid a cascade
631 -- Make these type and class decls available to stuff slurped from interface files
632 writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
635 setGblEnv tcg_env $ do {
636 -- Source-language instances, including derivings,
637 -- and import the supporting declarations
638 traceTc (text "Tc3") ;
639 (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
640 setGblEnv tcg_env $ do {
642 -- Foreign import declarations next. No zonking necessary
643 -- here; we can tuck them straight into the global environment.
644 traceTc (text "Tc4") ;
645 (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
646 tcExtendGlobalValEnv fi_ids $ do {
648 -- Default declarations
649 traceTc (text "Tc4a") ;
650 default_tys <- tcDefaults default_decls ;
651 updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
653 -- Value declarations next
654 -- We also typecheck any extra binds that came out
655 -- of the "deriving" process (deriv_binds)
656 traceTc (text "Tc5") ;
657 (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ;
658 setLclTypeEnv lcl_env $ do {
660 -- Second pass over class and instance declarations,
661 traceTc (text "Tc6") ;
662 (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
663 showLIE (text "after instDecls2") ;
666 -- They need to be zonked, so we return them
667 traceTc (text "Tc7") ;
668 (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
671 rules <- tcRules rule_decls ;
674 traceTc (text "Tc7a") ;
675 tcg_env <- getGblEnv ;
676 let { all_binds = tc_val_binds `unionBags`
677 inst_binds `unionBags`
680 -- Extend the GblEnv with the (as yet un-zonked)
681 -- bindings, rules, foreign decls
682 tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
683 tcg_rules = tcg_rules tcg_env ++ rules,
684 tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
685 return (tcg_env', lcl_env)
690 %************************************************************************
694 %************************************************************************
698 = do { ghci_mode <- getGhciMode ;
699 tcg_env <- getGblEnv ;
701 mb_main_mod <- readMutVar v_MainModIs ;
702 mb_main_fn <- readMutVar v_MainFunIs ;
703 let { main_mod = case mb_main_mod of {
704 Just mod -> mkModule mod ;
706 main_fn = case mb_main_fn of {
707 Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
708 Nothing -> main_RDR_Unqual } } ;
710 check_main ghci_mode tcg_env main_mod main_fn
714 check_main ghci_mode tcg_env main_mod main_fn
715 -- If we are in module Main, check that 'main' is defined.
716 -- It may be imported from another module!
719 -- Blimey: a whole page of code to do this...
724 = addErrCtxt mainCtxt $
725 do { mb_main <- lookupSrcOcc_maybe main_fn
726 -- Check that 'main' is in scope
727 -- It might be imported from another module!
729 Nothing -> do { complain_no_main
732 { let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) }
733 -- :Main.main :: IO () = runMainIO main
735 ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
738 ; let { root_main_id = mkExportedLocalId rootMainName ty ;
739 main_bind = noLoc (VarBind root_main_id main_expr) }
741 ; return (tcg_env { tcg_binds = tcg_binds tcg_env
743 tcg_dus = tcg_dus tcg_env
744 `plusDU` usesOnly (unitFV main_name)
745 -- Record the use of 'main', so that we don't
746 -- complain about it being defined but not used
750 mod = tcg_mod tcg_env
752 complain_no_main | ghci_mode == Interactive = return ()
753 | otherwise = failWithTc noMainMsg
754 -- In interactive mode, don't worry about the absence of 'main'
755 -- In other modes, fail altogether, so that we don't go on
756 -- and complain a second time when processing the export list.
758 mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
759 noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
760 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
764 %*********************************************************
768 %*********************************************************
772 setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
773 setInteractiveContext hsc_env icxt thing_inside
775 -- Initialise the tcg_inst_env with instances
776 -- from all home modules. This mimics the more selective
777 -- call to hptInstances in tcRnModule
778 dfuns = hptInstances hsc_env (\mod -> True)
780 updGblEnv (\env -> env {
781 tcg_rdr_env = ic_rn_gbl_env icxt,
782 tcg_type_env = ic_type_env icxt,
783 tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $
785 updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt }) $
787 do { traceTc (text "setIC" <+> ppr (ic_type_env icxt))
794 -> InteractiveContext
796 -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
797 -- The returned [Name] is the same as the input except for
798 -- ExprStmt, in which case the returned [Name] is [itName]
800 -- The returned TypecheckedHsExpr is of type IO [ () ],
801 -- a list of the bound values, coerced to ().
803 tcRnStmt hsc_env ictxt rdr_stmt
804 = initTcPrintErrors hsc_env iNTERACTIVE $
805 setInteractiveContext hsc_env ictxt $ do {
807 -- Rename; use CmdLineMode because tcRnStmt is only used interactively
808 ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ;
809 traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
812 -- The real work is done here
813 (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
815 traceTc (text "tcs 1") ;
816 let { -- (a) Make all the bound ids "global" ids, now that
817 -- they're notionally top-level bindings. This is
818 -- important: otherwise when we come to compile an expression
819 -- using these ids later, the byte code generator will consider
820 -- the occurrences to be free rather than global.
822 -- (b) Tidy their types; this is important, because :info may
823 -- ask to look at them, and :info expects the things it looks
824 -- up to have tidy types
825 global_ids = map globaliseAndTidy bound_ids ;
827 -- Update the interactive context
828 rn_env = ic_rn_local_env ictxt ;
829 type_env = ic_type_env ictxt ;
831 bound_names = map idName global_ids ;
832 new_rn_env = extendLocalRdrEnv rn_env bound_names ;
834 -- Remove any shadowed bindings from the type_env;
835 -- they are inaccessible but might, I suppose, cause
836 -- a space leak if we leave them there
837 shadowed = [ n | name <- bound_names,
838 let rdr_name = mkRdrUnqual (nameOccName name),
839 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
841 filtered_type_env = delListFromNameEnv type_env shadowed ;
842 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
844 new_ic = ictxt { ic_rn_local_env = new_rn_env,
845 ic_type_env = new_type_env }
848 dumpOptTcRn Opt_D_dump_tc
849 (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
850 text "Typechecked expr" <+> ppr tc_expr]) ;
852 returnM (new_ic, bound_names, tc_expr)
855 globaliseAndTidy :: Id -> Id
857 -- Give the Id a Global Name, and tidy its type
858 = setIdType (globaliseId VanillaGlobal id) tidy_type
860 tidy_type = tidyTopType (idType id)
863 Here is the grand plan, implemented in tcUserStmt
865 What you type The IO [HValue] that hscStmt returns
866 ------------- ------------------------------------
867 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
870 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
873 expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it]
874 [NB: result not printed] bindings: [it]
876 expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it]
877 result showable) bindings: [it]
879 expr (of non-IO type,
880 result not showable) ==> error
884 ---------------------------
885 tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
886 tcUserStmt (L _ (ExprStmt expr _))
887 = newUnique `thenM` \ uniq ->
889 fresh_it = itName uniq
890 the_bind = noLoc $ FunBind (noLoc fresh_it) False
891 (mkMatchGroup [mkSimpleMatch [] expr])
893 tryTcLIE_ (do { -- Try this if the other fails
894 traceTc (text "tcs 1b") ;
896 nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
897 nlExprStmt (nlHsApp (nlHsVar printName)
900 (do { -- Try this first
901 traceTc (text "tcs 1a") ;
902 tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] })
904 tcUserStmt stmt = tc_stmts [stmt]
906 ---------------------------
908 = do { ioTyCon <- tcLookupTyCon ioTyConName ;
910 ret_ty = mkListTy unitTy ;
911 io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
913 names = map unLoc (collectStmtsBinders stmts) ;
915 stmt_ctxt = SC { sc_what = DoExpr,
917 sc_body = check_body,
920 infer_rhs rhs = do { (rhs', rhs_ty) <- tcInferRho rhs
921 ; [pat_ty] <- unifyTyConApp ioTyCon rhs_ty
922 ; return (rhs', pat_ty) } ;
923 check_body body = tcCheckRho body io_ret_ty ;
925 -- mk_return builds the expression
926 -- returnIO @ [()] [coerce () x, .., coerce () z]
928 -- Despite the inconvenience of building the type applications etc,
929 -- this *has* to be done in type-annotated post-typecheck form
930 -- because we are going to return a list of *polymorphic* values
931 -- coerced to type (). If we built a *source* stmt
932 -- return [coerce x, ..., coerce z]
933 -- then the type checker would instantiate x..z, and we wouldn't
934 -- get their *polymorphic* values. (And we'd get ambiguity errs
935 -- if they were overloaded, since they aren't applied to anything.)
936 mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
937 (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
938 mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
941 io_ty = mkTyConApp ioTyCon []
944 -- OK, we're ready to typecheck the stmts
945 traceTc (text "tcs 2") ;
946 ((ids, tc_expr), lie) <- getLIE $ do {
947 (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts $
949 -- Look up the names right in the middle,
950 -- where they will all be in scope
951 ids <- mappM tcLookupId names ;
952 ret_id <- tcLookupId returnIOName ; -- return @ IO
953 return (ids, [nlResultStmt (mk_return ret_id ids)]) } ;
955 io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
956 return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty))
959 -- Simplify the context right here, so that we fail
960 -- if there aren't enough instances. Notably, when we see
962 -- we use recoverTc_ to try it <- e
963 -- and then let it = e
964 -- It's the simplify step that rejects the first.
965 traceTc (text "tcs 3") ;
966 const_binds <- tcSimplifyInteractive lie ;
968 -- Build result expression and zonk it
969 let { expr = mkHsLet const_binds tc_expr } ;
970 zonked_expr <- zonkTopLExpr expr ;
971 zonked_ids <- zonkTopBndrs ids ;
973 -- None of the Ids should be of unboxed type, because we
974 -- cast them all to HValues in the end!
975 mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
977 return (zonked_ids, zonked_expr)
980 combine stmt (ids, stmts) = (ids, stmt:stmts)
981 bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
982 nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
986 tcRnExpr just finds the type of an expression
990 -> InteractiveContext
993 tcRnExpr hsc_env ictxt rdr_expr
994 = initTcPrintErrors hsc_env iNTERACTIVE $
995 setInteractiveContext hsc_env ictxt $ do {
997 (rn_expr, fvs) <- rnLExpr rdr_expr ;
1000 -- Now typecheck the expression;
1001 -- it might have a rank-2 type (e.g. :t runST)
1002 ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
1003 ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
1004 tcSimplifyInteractive lie_top ;
1005 qtvs' <- mappM zonkQuantifiedTyVar qtvs ;
1007 let { all_expr_ty = mkForAllTys qtvs' $
1008 mkFunTys (map idType dict_ids) $
1010 zonkTcType all_expr_ty
1013 smpl_doc = ptext SLIT("main expression")
1016 tcRnType just finds the kind of a type
1020 -> InteractiveContext
1023 tcRnType hsc_env ictxt rdr_type
1024 = initTcPrintErrors hsc_env iNTERACTIVE $
1025 setInteractiveContext hsc_env ictxt $ do {
1027 rn_type <- rnLHsType doc rdr_type ;
1030 -- Now kind-check the type
1031 (ty', kind) <- kcHsType rn_type ;
1035 doc = ptext SLIT("In GHCi input")
1041 %************************************************************************
1043 More GHCi stuff, to do with browsing and getting info
1045 %************************************************************************
1049 mkExportEnv :: HscEnv -> [Module] -- Expose these modules' exports only
1051 mkExportEnv hsc_env exports
1052 = do { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $
1053 mappM getModuleExports exports
1055 Just envs -> return (foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs)
1056 Nothing -> return emptyGlobalRdrEnv
1057 -- Some error; initTc will have printed it
1060 getModuleExports :: Module -> TcM GlobalRdrEnv
1061 getModuleExports mod
1062 = do { iface <- load_iface mod
1063 ; loadOrphanModules (dep_orphs (mi_deps iface))
1064 -- Load any orphan-module interfaces,
1065 -- so their instances are visible
1066 ; names <- exportsToAvails (mi_exports iface)
1067 ; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod }
1068 | name <- nameSetToList names ] }
1069 ; returnM (mkGlobalRdrEnv gres) }
1071 vanillaProv :: Module -> Provenance
1072 -- We're building a GlobalRdrEnv as if the user imported
1073 -- all the specified modules into the global interactive module
1074 vanillaProv mod = Imported [ImportSpec mod mod False
1075 (srcLocSpan interactiveSrcLoc)] False
1081 -> InteractiveContext
1082 -> Module -- Module to inspect
1083 -> Bool -- Grab just the exports, or the whole toplev
1084 -> IO (Maybe [IfaceDecl])
1086 getModuleContents hsc_env ictxt mod exports_only
1087 = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only)
1089 get_mod_contents exports_only
1090 | not exports_only -- We want the whole top-level type env
1091 -- so it had better be a home module
1092 = do { hpt <- getHpt
1093 ; case lookupModuleEnv hpt mod of
1094 Just mod_info -> return (map toIfaceDecl $
1097 md_types (hm_details mod_info))
1098 Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod)))
1099 -- This is a system error; the module should be in the HPT
1102 | otherwise -- Want the exports only
1103 = do { iface <- load_iface mod
1104 ; mappM get_decl [ (mod,avail) | (mod, avails) <- mi_exports iface
1108 get_decl (mod, avail)
1109 = do { main_name <- lookupOrig mod (availName avail)
1110 ; thing <- tcLookupGlobal main_name
1111 ; return (filter_decl (availNames avail) (toIfaceDecl thing)) }
1113 ---------------------
1114 filter_decl occs decl@(IfaceClass {ifSigs = sigs})
1115 = decl { ifSigs = filter (keep_sig occs) sigs }
1116 filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon th cons})
1117 = decl { ifCons = IfDataTyCon th (filter (keep_con occs) cons) }
1118 filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
1119 | keep_con occs con = decl
1120 | otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm?
1121 filter_decl occs decl
1124 keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs
1125 keep_con occs con = ifConOcc con `elem` occs
1127 wantToSee (AnId id) = not (isImplicitId id)
1128 wantToSee (ADataCon _) = False -- They'll come via their TyCon
1131 ---------------------
1132 load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
1134 doc = ptext SLIT("context for compiling statements")
1136 ---------------------
1137 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
1138 <+> quotes (ppr mod)
1142 tcRnGetInfo :: HscEnv
1143 -> InteractiveContext
1145 -> IO (Maybe [(IfaceDecl,
1147 [(IfaceInst, SrcLoc)])])
1148 -- Used to implemnent :info in GHCi
1150 -- Look up a RdrName and return all the TyThings it might be
1151 -- A capitalised RdrName is given to us in the DataName namespace,
1152 -- but we want to treat it as *both* a data constructor
1153 -- *and* as a type or class constructor;
1154 -- hence the call to dataTcOccs, and we return up to two results
1155 tcRnGetInfo hsc_env ictxt rdr_name
1156 = initTcPrintErrors hsc_env iNTERACTIVE $
1157 setInteractiveContext hsc_env ictxt $ do {
1159 -- If the identifier is a constructor (begins with an
1160 -- upper-case letter), then we need to consider both
1161 -- constructor and type class identifiers.
1162 let { rdr_names = dataTcOccs rdr_name } ;
1164 -- results :: [(Messages, Maybe Name)]
1165 results <- mapM (tryTc . lookupOccRn) rdr_names ;
1167 traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
1168 -- The successful lookups will be (Just name)
1169 let { (warns_s, good_names) = unzip [ (msgs, name)
1170 | (msgs, Just name) <- results] ;
1171 errs_s = [msgs | (msgs, Nothing) <- results] } ;
1173 -- Fail if nothing good happened, else add warnings
1174 if null good_names then
1175 -- No lookup succeeded, so
1176 -- pick the first error message and report it
1177 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
1178 -- while the other is "X is not in scope",
1179 -- we definitely want the former; but we might pick the latter
1180 do { addMessages (head errs_s) ; failM }
1181 else -- Add deprecation warnings
1182 mapM_ addMessages warns_s ;
1184 -- And lookup up the entities, avoiding duplicates, which arise
1185 -- because constructors and record selectors are represented by
1186 -- their parent declaration
1187 let { do_one name = do { thing <- tcLookupGlobal name
1188 ; fixity <- lookupFixityRn name
1189 ; insts <- lookupInsts print_unqual thing
1190 ; return (toIfaceDecl thing, fixity,
1191 getSrcLoc thing, insts) } } ;
1192 -- For the SrcLoc, the 'thing' has better info than
1193 -- the 'name' because getting the former forced the
1194 -- declaration to be loaded into the cache
1196 results <- mapM do_one good_names ;
1197 return (fst (removeDups cmp results))
1200 cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2
1202 print_unqual :: PrintUnqualified
1203 print_unqual = icPrintUnqual ictxt
1206 lookupInsts :: PrintUnqualified -> TyThing -> TcM [(IfaceInst, SrcLoc)]
1207 -- Filter the instances by the ones whose tycons (or clases resp)
1208 -- are in scope unqualified. Otherwise we list a whole lot too many!
1209 lookupInsts print_unqual (AClass cls)
1210 = do { loadImportedInsts cls [] -- [] means load all instances for cls
1211 ; inst_envs <- tcGetInstEnvs
1212 ; return [ (inst, getSrcLoc dfun)
1213 | (_,_,dfun) <- classInstances inst_envs cls
1214 , let inst = dfunToIfaceInst dfun
1215 (_, tycons) = ifaceInstGates (ifInstHead inst)
1216 , all print_tycon_unqual tycons ] }
1218 print_tycon_unqual (IfaceTc ext_nm) = ifPrintUnqual print_unqual ext_nm
1219 print_tycon_unqual other = True -- Int etc
1222 lookupInsts print_unqual (ATyCon tc)
1223 = do { eps <- getEps -- Load all instances for all classes that are
1224 -- in the type environment (which are all the ones
1225 -- we've seen in any interface file so far)
1226 ; mapM_ (\c -> loadImportedInsts c [])
1227 (typeEnvClasses (eps_PTE eps))
1228 ; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all
1229 ; return [ (inst, getSrcLoc dfun)
1230 | (_, _, dfun) <- instEnvElts home_ie ++ instEnvElts pkg_ie
1232 , let inst = dfunToIfaceInst dfun
1233 (cls, _) = ifaceInstGates (ifInstHead inst)
1234 , ifPrintUnqual print_unqual cls ] }
1236 relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
1237 tc_name = tyConName tc
1239 lookupInsts print_unqual other = return []
1242 toIfaceDecl :: TyThing -> IfaceDecl
1244 = tyThingToIfaceDecl True -- Discard IdInfo
1245 emptyNameSet -- Show data cons
1246 ext_nm (munge thing)
1248 ext_nm n = ExtPkg (nameModule n) (nameOccName n)
1250 -- munge transforms a thing to its "parent" thing
1251 munge (ADataCon dc) = ATyCon (dataConTyCon dc)
1252 munge (AnId id) = case globalIdDetails id of
1253 RecordSelId tc lbl -> ATyCon tc
1254 ClassOpId cls -> AClass cls
1256 munge other_thing = other_thing
1261 %************************************************************************
1265 %************************************************************************
1268 rnDump :: SDoc -> TcRn ()
1269 -- Dump, with a banner, if -ddump-rn
1270 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1272 tcDump :: TcGblEnv -> TcRn ()
1274 = do { dflags <- getDOpts ;
1276 -- Dump short output if -ddump-types or -ddump-tc
1277 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1278 (dumpTcRn short_dump) ;
1280 -- Dump bindings if -ddump-tc
1281 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1284 short_dump = pprTcGblEnv env
1285 full_dump = pprLHsBinds (tcg_binds env)
1286 -- NB: foreign x-d's have undefined's in their types;
1287 -- hence can't show the tc_fords
1290 = do { dflags <- getDOpts ;
1291 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1292 (dumpTcRn (pprModGuts mod_guts)) ;
1294 -- Dump bindings if -ddump-tc
1295 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1297 full_dump = pprCoreBindings (mg_binds mod_guts)
1299 -- It's unpleasant having both pprModGuts and pprModDetails here
1300 pprTcGblEnv :: TcGblEnv -> SDoc
1301 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1302 tcg_insts = dfun_ids,
1304 tcg_imports = imports })
1305 = vcat [ ppr_types dfun_ids type_env
1306 , ppr_insts dfun_ids
1307 , vcat (map ppr rules)
1308 , ppr_gen_tycons (typeEnvTyCons type_env)
1309 , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports))
1310 , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1312 pprModGuts :: ModGuts -> SDoc
1313 pprModGuts (ModGuts { mg_types = type_env,
1315 = vcat [ ppr_types [] type_env,
1319 ppr_types :: [Var] -> TypeEnv -> SDoc
1320 ppr_types dfun_ids type_env
1321 = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1323 ids = [id | id <- typeEnvIds type_env, want_sig id]
1324 want_sig id | opt_PprStyle_Debug = True
1325 | otherwise = isLocalId id &&
1326 isExternalName (idName id) &&
1327 not (id `elem` dfun_ids)
1328 -- isLocalId ignores data constructors, records selectors etc.
1329 -- The isExternalName ignores local dictionary and method bindings
1330 -- that the type checker has invented. Top-level user-defined things
1331 -- have External names.
1333 ppr_insts :: [Var] -> SDoc
1334 ppr_insts [] = empty
1335 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1337 ppr_sigs :: [Var] -> SDoc
1339 -- Print type signatures; sort by OccName
1340 = vcat (map ppr_sig (sortLe le_sig ids))
1342 le_sig id1 id2 = getOccName id1 <= getOccName id2
1343 ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
1345 ppr_rules :: [IdCoreRule] -> SDoc
1346 ppr_rules [] = empty
1347 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1348 nest 4 (pprIdRules rs),
1351 ppr_gen_tycons [] = empty
1352 ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"),
1353 nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]