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 DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
26 import StaticFlags ( opt_PprStyle_Debug )
27 import Packages ( moduleToPackageConfig, mkPackageId, package,
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 Module ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv )
64 import OccName ( mkVarOcc )
65 import Name ( Name, isExternalName, getSrcLoc, getOccName, isWiredInName )
67 import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
68 import SrcLoc ( srcLocSpan, Located(..), noLoc )
69 import DriverPhases ( HscSource(..), isHsBoot )
70 import HscTypes ( ModGuts(..), HscEnv(..), ExternalPackageState(..),
71 IsBootInterface, noDependencies,
72 Deprecs( NoDeprecs ), plusDeprecs,
73 ForeignStubs(NoStubs), TyThing(..),
74 TypeEnv, lookupTypeEnv, hptInstances, lookupType,
75 extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
81 import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
82 LStmt, LHsExpr, LHsType, mkMatchGroup,
83 collectLStmtsBinders, mkSimpleMatch,
84 mkExprStmt, mkBindStmt, nlVarPat )
85 import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
86 Provenance(..), ImportSpec(..),
87 lookupLocalRdrEnv, extendLocalRdrEnv )
88 import RnSource ( addTcgDUs )
89 import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs )
90 import TcHsType ( kcHsType )
91 import TcIface ( loadImportedInsts )
92 import TcMType ( zonkTcType, zonkQuantifiedTyVar )
93 import TcMatches ( tcStmts, tcDoStmt )
94 import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer )
95 import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType,
96 isUnLiftedType, tyClsNamesOfDFunHead )
97 import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
98 import RnTypes ( rnLHsType )
99 import Inst ( tcGetInstEnvs )
100 import InstEnv ( DFunId, classInstances, instEnvElts )
101 import RnExpr ( rnStmts, rnLExpr )
102 import RnNames ( exportsToAvails )
103 import LoadIface ( loadSrcInterface, ifaceInstGates )
104 import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
105 IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
106 tyThingToIfaceDecl, dfunToIfaceInst )
107 import IfaceType ( IfaceTyCon(..), IfaceType, toIfaceType,
108 interactiveExtNameFun, isLocalIfaceExtName )
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 )
121 import OccName ( occNameUserString )
122 import NameEnv ( delListFromNameEnv )
123 import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName, returnIOName )
124 import HscTypes ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnvClasses,
125 availNames, availName, ModIface(..), icPrintUnqual,
126 ModDetails(..), Dependencies(..) )
127 import BasicTypes ( RecFlag(..), Fixity )
128 import Bag ( unitBag )
129 import ListSetOps ( removeDups )
130 import Panic ( ghcError, GhcException(..) )
131 import SrcLoc ( SrcLoc )
134 import FastString ( mkFastString )
135 import Util ( sortLe )
136 import Bag ( unionBags, snocBag )
138 import Maybe ( isJust )
143 %************************************************************************
145 Typecheck and rename a module
147 %************************************************************************
153 -> Located (HsModule RdrName)
154 -> IO (Messages, Maybe TcGblEnv)
156 tcRnModule hsc_env hsc_src (L loc (HsModule maybe_mod export_ies
157 import_decls local_decls mod_deprec))
158 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
160 let { this_mod = case maybe_mod of
161 Nothing -> mAIN -- 'module M where' is omitted
162 Just (L _ mod) -> mod } ; -- The normal case
164 initTc hsc_env hsc_src this_mod $
167 checkForPackageModule (hsc_dflags hsc_env) this_mod;
169 -- Deal with imports; sets tcg_rdr_env, tcg_imports
170 (rdr_env, imports) <- rnImports import_decls ;
172 let { dep_mods :: ModuleEnv (Module, IsBootInterface)
173 ; dep_mods = imp_dep_mods imports
175 ; is_dep_mod :: Module -> Bool
176 ; is_dep_mod mod = case lookupModuleEnv dep_mods mod of
178 Just (_, is_boot) -> not is_boot
179 ; home_insts = hptInstances hsc_env is_dep_mod
182 -- Record boot-file info in the EPS, so that it's
183 -- visible to loadHiBootInterface in tcRnSrcDecls,
184 -- and any other incrementally-performed imports
185 updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
187 -- Update the gbl env
189 gbl { tcg_rdr_env = rdr_env,
190 tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
191 tcg_imports = tcg_imports gbl `plusImportAvails` imports })
194 traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
195 -- Fail if there are any errors so far
196 -- The error printing (if needed) takes advantage
197 -- of the tcg_env we have now set
200 -- Load any orphan-module interfaces, so that
201 -- their rules and instance decls will be found
202 loadOrphanModules (imp_orphs imports) ;
204 traceRn (text "rn1a") ;
205 -- Rename and type check the declarations
206 tcg_env <- if isHsBoot hsc_src then
207 tcRnHsBootDecls local_decls
209 tcRnSrcDecls local_decls ;
210 setGblEnv tcg_env $ do {
212 traceRn (text "rn3") ;
214 -- Report the use of any deprecated things
215 -- We do this before processsing the export list so
216 -- that we don't bleat about re-exporting a deprecated
217 -- thing (especially via 'module Foo' export item)
218 -- Only uses in the body of the module are complained about
219 reportDeprecations tcg_env ;
221 -- Process the export list
222 exports <- exportsFromAvail (isJust maybe_mod) export_ies ;
224 -- Check whether the entire module is deprecated
225 -- This happens only once per module
226 let { mod_deprecs = checkModDeprec mod_deprec } ;
228 -- Add exports and deprecations to envt
229 let { final_env = tcg_env { tcg_exports = exports,
230 tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
231 tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
233 -- A module deprecation over-rides the earlier ones
236 -- Report unused names
237 reportUnusedNames export_ies final_env ;
239 -- Dump output and return
244 -- This is really a sanity check that the user has given -package-name
245 -- if necessary. -package-name is only necessary when the package database
246 -- already contains the current package, because then we can't tell
247 -- whether a given module is in the current package or not, without knowing
248 -- the name of the current package.
249 checkForPackageModule dflags this_mod
250 | not (isHomeModule dflags this_mod),
251 Just (pkg,_) <- moduleToPackageConfig dflags this_mod =
253 ppr_pkg = ppr (mkPackageId (package pkg))
255 addErr (ptext SLIT("Module") <+> quotes (ppr this_mod) <+>
256 ptext SLIT("is a member of package") <+> ppr_pkg <> char '.' $$
257 ptext SLIT("To compile this module, please use -ignore-package") <+> ppr_pkg <> char '.')
258 | otherwise = return ()
262 %************************************************************************
264 Type-checking external-core modules
266 %************************************************************************
269 tcRnExtCore :: HscEnv
271 -> IO (Messages, Maybe ModGuts)
272 -- Nothing => some error occurred
274 tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
275 -- The decls are IfaceDecls; all names are original names
276 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
278 initTc hsc_env ExtCoreFile this_mod $ do {
280 let { ldecls = map noLoc decls } ;
282 -- Deal with the type declarations; first bring their stuff
283 -- into scope, then rname them, then type check them
284 (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ;
286 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
287 tcg_imports = imports `plusImportAvails` tcg_imports gbl })
290 rn_decls <- rnTyClDecls ldecls ;
293 -- Dump trace of renaming part
294 rnDump (ppr rn_decls) ;
296 -- Typecheck them all together so that
297 -- any mutually recursive types are done right
298 tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot names -}] rn_decls) ;
299 -- Make the new type env available to stuff slurped from interface files
301 setGblEnv tcg_env $ do {
303 -- Now the core bindings
304 core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
308 bndrs = bindersOfBinds core_binds ;
309 my_exports = mkNameSet (map idName bndrs) ;
310 -- ToDo: export the data types also?
312 final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
314 mod_guts = ModGuts { mg_module = this_mod,
316 mg_usages = [], -- ToDo: compute usage
317 mg_dir_imps = [], -- ??
318 mg_deps = noDependencies, -- ??
319 mg_exports = my_exports,
320 mg_types = final_type_env,
321 mg_insts = tcg_insts tcg_env,
323 mg_binds = core_binds,
326 mg_rdr_env = emptyGlobalRdrEnv,
327 mg_fix_env = emptyFixityEnv,
328 mg_deprecs = NoDeprecs,
332 tcCoreDump mod_guts ;
337 mkFakeGroup decls -- Rather clumsy; lots of unused fields
338 = HsGroup { hs_tyclds = decls, -- This is the one we want
339 hs_valds = [], hs_fords = [],
340 hs_instds = [], hs_fixds = [], hs_depds = [],
341 hs_ruleds = [], hs_defds = [] }
345 %************************************************************************
347 Type-checking the top level of a module
349 %************************************************************************
352 tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
353 -- Returns the variables free in the decls
354 -- Reason: solely to report unused imports and bindings
356 = do { -- Load the hi-boot interface for this module, if any
357 -- We do this now so that the boot_names can be passed
358 -- to tcTyAndClassDecls, because the boot_names are
359 -- automatically considered to be loop breakers
360 boot_names <- loadHiBootInterface ;
362 -- Do all the declarations
363 (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_names decls) ;
365 -- tcSimplifyTop deals with constant or ambiguous InstIds.
366 -- How could there be ambiguous ones? They can only arise if a
367 -- top-level decl falls under the monomorphism
368 -- restriction, and no subsequent decl instantiates its
369 -- type. (Usually, ambiguous type variables are resolved
370 -- during the generalisation step.)
371 traceTc (text "Tc8") ;
372 inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
373 -- Setting the global env exposes the instances to tcSimplifyTop
374 -- Setting the local env exposes the local Ids to tcSimplifyTop,
375 -- so that we get better error messages (monomorphism restriction)
377 -- Backsubstitution. This must be done last.
378 -- Even tcSimplifyTop may do some unification.
379 traceTc (text "Tc9") ;
380 let { (tcg_env, _) = tc_envs ;
381 TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
382 tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
384 (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
387 let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
389 -- Compre the hi-boot iface (if any) with the real thing
390 checkHiBootIface final_type_env boot_names ;
392 -- Make the new type env available to stuff slurped from interface files
393 writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
395 return (tcg_env { tcg_type_env = final_type_env,
396 tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' })
399 tc_rn_src_decls :: [Name] -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
400 -- Loops around dealing with each top level inter-splice group
401 -- in turn, until it's dealt with the entire module
402 tc_rn_src_decls boot_names ds
403 = do { let { (first_group, group_tail) = findSplice ds } ;
404 -- If ds is [] we get ([], Nothing)
406 -- Type check the decls up to, but not including, the first splice
407 tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_names first_group ;
409 -- Bale out if errors; for example, error recovery when checking
410 -- the RHS of 'main' can mean that 'main' is not in the envt for
411 -- the subsequent checkMain test
416 -- If there is no splice, we're nearly done
418 Nothing -> do { -- Last thing: check for `main'
419 tcg_env <- checkMain ;
420 return (tcg_env, tcl_env)
423 -- If there's a splice, we must carry on
424 Just (SpliceDecl splice_expr, rest_ds) -> do {
426 failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
429 -- Rename the splice expression, and get its supporting decls
430 (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
431 failIfErrsM ; -- Don't typecheck if renaming failed
433 -- Execute the splice
434 spliced_decls <- tcSpliceDecls rn_splice_expr ;
436 -- Glue them on the front of the remaining decls and loop
437 setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
438 tc_rn_src_decls boot_names (spliced_decls ++ rest_ds)
443 %************************************************************************
445 Compiling hs-boot source files, and
446 comparing the hi-boot interface with the real thing
448 %************************************************************************
451 tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
452 tcRnHsBootDecls decls
453 = do { let { (first_group, group_tail) = findSplice decls }
456 Just stuff -> spliceInHsBootErr stuff
459 -- Rename the declarations
460 ; (tcg_env, rn_group) <- rnTopSrcDecls first_group
461 ; setGblEnv tcg_env $ do {
463 -- Todo: check no foreign decls, no rules, no default decls
465 -- Typecheck type/class decls
466 ; traceTc (text "Tc2")
467 ; let tycl_decls = hs_tyclds rn_group
468 ; tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot_names -}] tycl_decls)
469 ; setGblEnv tcg_env $ do {
471 -- Typecheck instance decls
472 ; traceTc (text "Tc3")
473 ; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group)
474 ; setGblEnv tcg_env $ do {
476 -- Typecheck value declarations
477 ; traceTc (text "Tc5")
478 ; new_ids <- tcHsBootSigs (hs_valds rn_group)
481 -- No simplification or zonking to do
482 ; traceTc (text "Tc7a")
483 ; gbl_env <- getGblEnv
485 ; let { final_type_env = extendTypeEnvWithIds (tcg_type_env gbl_env) new_ids }
486 ; return (gbl_env { tcg_type_env = final_type_env })
489 spliceInHsBootErr (SpliceDecl (L loc _), _)
490 = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files"))
493 In both one-shot mode and GHCi mode, hi-boot interfaces are demand-loaded
494 into the External Package Table. Once we've typechecked the body of the
495 module, we want to compare what we've found (gathered in a TypeEnv) with
496 the hi-boot stuff in the EPT. We do so here, using the export list of
497 the hi-boot interface as our checklist.
500 checkHiBootIface :: TypeEnv -> [Name] -> TcM ()
501 -- Compare the hi-boot file for this module (if there is one)
502 -- with the type environment we've just come up with
503 -- In the common case where there is no hi-boot file, the list
504 -- of boot_names is empty.
505 checkHiBootIface env boot_names
506 = mapM_ (check_one env) boot_names
509 check_one local_env name
510 | isWiredInName name -- No checking for wired-in names. In particular, 'error'
511 = return () -- is handled by a rather gross hack (see comments in GHC.Err.hs-boot)
513 = do { (eps,hpt) <- getEpsAndHpt
515 -- Look up the hi-boot one;
516 -- it should jolly well be there (else GHC bug)
517 ; case lookupType hpt (eps_PTE eps) name of {
518 Nothing -> pprPanic "checkHiBootIface" (ppr name) ;
521 -- Look it up in the local type env
522 -- It should be there, but it's a programmer error if not
523 case lookupTypeEnv local_env name of
524 Nothing -> addErrTc (missingBootThing boot_thing)
525 Just real_thing -> check_thing boot_thing real_thing
529 check_thing (ATyCon boot_tc) (ATyCon real_tc)
530 | isSynTyCon boot_tc && isSynTyCon real_tc,
531 defn1 `tcEqType` substTyWith tvs2 (mkTyVarTys tvs1) defn2
534 | tyConKind boot_tc == tyConKind real_tc
537 (tvs1, defn1) = getSynTyConDefn boot_tc
538 (tvs2, defn2) = getSynTyConDefn boot_tc
540 check_thing (AnId boot_id) (AnId real_id)
541 | idType boot_id `tcEqType` idType real_id
544 check_thing (ADataCon dc1) (ADataCon dc2)
545 | idType (dataConWrapId dc1) `tcEqType` idType (dataConWrapId dc2)
548 -- Can't declare a class in a hi-boot file
550 check_thing boot_thing real_thing -- Default case; failure
551 = addErrAt (srcLocSpan (getSrcLoc real_thing))
552 (bootMisMatch real_thing)
555 missingBootThing thing
556 = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
558 = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")
562 %************************************************************************
564 Type-checking the top level of a module
566 %************************************************************************
568 tcRnGroup takes a bunch of top-level source-code declarations, and
570 * gets supporting declarations from interface files
573 * and augments the TcGblEnv with the results
575 In Template Haskell it may be called repeatedly for each group of
576 declarations. It expects there to be an incoming TcGblEnv in the
577 monad; it augments it and returns the new TcGblEnv.
580 tcRnGroup :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
581 -- Returns the variables free in the decls, for unused-binding reporting
582 tcRnGroup boot_names decls
583 = do { -- Rename the declarations
584 (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
585 setGblEnv tcg_env $ do {
587 -- Typecheck the declarations
588 tcTopSrcDecls boot_names rn_decls
591 ------------------------------------------------
592 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
594 = do { -- Bring top level binders into scope
595 (rdr_env, imports) <- importsFromLocalDecls group ;
596 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
597 tcg_imports = imports `plusImportAvails` tcg_imports gbl })
600 traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
601 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
603 -- Rename the source decls
604 (tcg_env, rn_decls) <- rnSrcDecls group ;
607 -- Dump trace of renaming part
608 rnDump (ppr rn_decls) ;
610 return (tcg_env, rn_decls)
613 ------------------------------------------------
614 tcTopSrcDecls :: [Name] -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
615 tcTopSrcDecls boot_names
616 (HsGroup { hs_tyclds = tycl_decls,
617 hs_instds = inst_decls,
618 hs_fords = foreign_decls,
619 hs_defds = default_decls,
620 hs_ruleds = rule_decls,
621 hs_valds = val_binds })
622 = do { -- Type-check the type and class decls, and all imported decls
623 -- The latter come in via tycl_decls
624 traceTc (text "Tc2") ;
626 tcg_env <- checkNoErrs (tcTyAndClassDecls boot_names tycl_decls) ;
627 -- tcTyAndClassDecls recovers internally, but if anything gave rise to
628 -- an error we'd better stop now, to avoid a cascade
630 -- Make these type and class decls available to stuff slurped from interface files
631 writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
634 setGblEnv tcg_env $ do {
635 -- Source-language instances, including derivings,
636 -- and import the supporting declarations
637 traceTc (text "Tc3") ;
638 (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
639 setGblEnv tcg_env $ do {
641 -- Foreign import declarations next. No zonking necessary
642 -- here; we can tuck them straight into the global environment.
643 traceTc (text "Tc4") ;
644 (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
645 tcExtendGlobalValEnv fi_ids $ do {
647 -- Default declarations
648 traceTc (text "Tc4a") ;
649 default_tys <- tcDefaults default_decls ;
650 updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
652 -- Value declarations next
653 -- We also typecheck any extra binds that came out
654 -- of the "deriving" process (deriv_binds)
655 traceTc (text "Tc5") ;
656 (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ;
657 setLclTypeEnv lcl_env $ do {
659 -- Second pass over class and instance declarations,
660 traceTc (text "Tc6") ;
661 (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
662 showLIE (text "after instDecls2") ;
665 -- They need to be zonked, so we return them
666 traceTc (text "Tc7") ;
667 (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
670 rules <- tcRules rule_decls ;
673 traceTc (text "Tc7a") ;
674 tcg_env <- getGblEnv ;
675 let { all_binds = tc_val_binds `unionBags`
676 inst_binds `unionBags`
679 -- Extend the GblEnv with the (as yet un-zonked)
680 -- bindings, rules, foreign decls
681 tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
682 tcg_rules = tcg_rules tcg_env ++ rules,
683 tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
684 return (tcg_env', lcl_env)
689 %************************************************************************
693 %************************************************************************
697 = do { ghci_mode <- getGhciMode ;
698 tcg_env <- getGblEnv ;
700 let { main_mod = case mainModIs dflags of {
701 Just mod -> mkModule mod ;
703 main_fn = case mainFunIs dflags of {
704 Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
705 Nothing -> main_RDR_Unqual } } ;
707 check_main ghci_mode tcg_env main_mod main_fn
711 check_main ghci_mode tcg_env main_mod main_fn
712 -- If we are in module Main, check that 'main' is defined.
713 -- It may be imported from another module!
716 -- Blimey: a whole page of code to do this...
721 = addErrCtxt mainCtxt $
722 do { mb_main <- lookupSrcOcc_maybe main_fn
723 -- Check that 'main' is in scope
724 -- It might be imported from another module!
726 Nothing -> do { complain_no_main
729 { let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) }
730 -- :Main.main :: IO () = runMainIO main
732 ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
735 ; let { root_main_id = mkExportedLocalId rootMainName ty ;
736 main_bind = noLoc (VarBind root_main_id main_expr) }
738 ; return (tcg_env { tcg_binds = tcg_binds tcg_env
740 tcg_dus = tcg_dus tcg_env
741 `plusDU` usesOnly (unitFV main_name)
742 -- Record the use of 'main', so that we don't
743 -- complain about it being defined but not used
747 mod = tcg_mod tcg_env
749 complain_no_main | ghci_mode == Interactive = return ()
750 | otherwise = failWithTc noMainMsg
751 -- In interactive mode, don't worry about the absence of 'main'
752 -- In other modes, fail altogether, so that we don't go on
753 -- and complain a second time when processing the export list.
755 mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
756 noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
757 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
761 %*********************************************************
765 %*********************************************************
769 setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
770 setInteractiveContext hsc_env icxt thing_inside
772 -- Initialise the tcg_inst_env with instances
773 -- from all home modules. This mimics the more selective
774 -- call to hptInstances in tcRnModule
775 dfuns = hptInstances hsc_env (\mod -> True)
777 updGblEnv (\env -> env {
778 tcg_rdr_env = ic_rn_gbl_env icxt,
779 tcg_type_env = ic_type_env icxt,
780 tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $
782 updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt }) $
784 do { traceTc (text "setIC" <+> ppr (ic_type_env icxt))
791 -> InteractiveContext
793 -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
794 -- The returned [Name] is the same as the input except for
795 -- ExprStmt, in which case the returned [Name] is [itName]
797 -- The returned TypecheckedHsExpr is of type IO [ () ],
798 -- a list of the bound values, coerced to ().
800 tcRnStmt hsc_env ictxt rdr_stmt
801 = initTcPrintErrors hsc_env iNTERACTIVE $
802 setInteractiveContext hsc_env ictxt $ do {
804 -- Rename; use CmdLineMode because tcRnStmt is only used interactively
805 (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ;
806 traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
809 -- The real work is done here
810 (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
812 traceTc (text "tcs 1") ;
813 let { -- (a) Make all the bound ids "global" ids, now that
814 -- they're notionally top-level bindings. This is
815 -- important: otherwise when we come to compile an expression
816 -- using these ids later, the byte code generator will consider
817 -- the occurrences to be free rather than global.
819 -- (b) Tidy their types; this is important, because :info may
820 -- ask to look at them, and :info expects the things it looks
821 -- up to have tidy types
822 global_ids = map globaliseAndTidy bound_ids ;
824 -- Update the interactive context
825 rn_env = ic_rn_local_env ictxt ;
826 type_env = ic_type_env ictxt ;
828 bound_names = map idName global_ids ;
829 new_rn_env = extendLocalRdrEnv rn_env bound_names ;
831 -- Remove any shadowed bindings from the type_env;
832 -- they are inaccessible but might, I suppose, cause
833 -- a space leak if we leave them there
834 shadowed = [ n | name <- bound_names,
835 let rdr_name = mkRdrUnqual (nameOccName name),
836 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
838 filtered_type_env = delListFromNameEnv type_env shadowed ;
839 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
841 new_ic = ictxt { ic_rn_local_env = new_rn_env,
842 ic_type_env = new_type_env }
845 dumpOptTcRn Opt_D_dump_tc
846 (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
847 text "Typechecked expr" <+> ppr tc_expr]) ;
849 returnM (new_ic, bound_names, tc_expr)
852 globaliseAndTidy :: Id -> Id
854 -- Give the Id a Global Name, and tidy its type
855 = setIdType (globaliseId VanillaGlobal id) tidy_type
857 tidy_type = tidyTopType (idType id)
860 Here is the grand plan, implemented in tcUserStmt
862 What you type The IO [HValue] that hscStmt returns
863 ------------- ------------------------------------
864 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
867 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
870 expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it]
871 [NB: result not printed] bindings: [it]
873 expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it]
874 result showable) bindings: [it]
876 expr (of non-IO type,
877 result not showable) ==> error
881 ---------------------------
882 tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
883 tcUserStmt (L loc (ExprStmt expr _ _))
884 = newUnique `thenM` \ uniq ->
886 fresh_it = itName uniq
887 the_bind = noLoc $ FunBind (noLoc fresh_it) False
888 (mkMatchGroup [mkSimpleMatch [] expr])
890 tryTcLIE_ (do { -- Try this if the other fails
891 traceTc (text "tcs 1b") ;
892 tc_stmts (map (L loc) [
893 LetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
894 mkExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
896 (do { -- Try this first
897 traceTc (text "tcs 1a") ;
898 tc_stmts [L loc (mkBindStmt (nlVarPat fresh_it) expr)] })
900 tcUserStmt stmt = tc_stmts [stmt]
902 ---------------------------
903 tc_stmts :: [LStmt Name] -> TcM ([Id], LHsExpr Id)
905 = do { ioTyCon <- tcLookupTyCon ioTyConName ;
907 ret_ty = mkListTy unitTy ;
908 io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
910 names = map unLoc (collectLStmtsBinders stmts) ;
912 -- mk_return builds the expression
913 -- returnIO @ [()] [coerce () x, .., coerce () z]
915 -- Despite the inconvenience of building the type applications etc,
916 -- this *has* to be done in type-annotated post-typecheck form
917 -- because we are going to return a list of *polymorphic* values
918 -- coerced to type (). If we built a *source* stmt
919 -- return [coerce x, ..., coerce z]
920 -- then the type checker would instantiate x..z, and we wouldn't
921 -- get their *polymorphic* values. (And we'd get ambiguity errs
922 -- if they were overloaded, since they aren't applied to anything.)
923 mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
924 (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
925 mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
928 io_ty = mkTyConApp ioTyCon []
931 -- OK, we're ready to typecheck the stmts
932 traceTc (text "tcs 2") ;
933 ((ids, tc_expr), lie) <- getLIE $ do {
934 (tc_stmts, ids) <- tcStmts DoExpr (tcDoStmt io_ty io_ret_ty) stmts $
936 -- Look up the names right in the middle,
937 -- where they will all be in scope
938 ids <- mappM tcLookupId names ;
941 ret_id <- tcLookupId returnIOName ; -- return @ IO
942 return (ids, noLoc (HsDo DoExpr tc_stmts (mk_return ret_id ids) io_ret_ty))
945 -- Simplify the context right here, so that we fail
946 -- if there aren't enough instances. Notably, when we see
948 -- we use recoverTc_ to try it <- e
949 -- and then let it = e
950 -- It's the simplify step that rejects the first.
951 traceTc (text "tcs 3") ;
952 const_binds <- tcSimplifyInteractive lie ;
954 -- Build result expression and zonk it
955 let { expr = mkHsLet const_binds tc_expr } ;
956 zonked_expr <- zonkTopLExpr expr ;
957 zonked_ids <- zonkTopBndrs ids ;
959 -- None of the Ids should be of unboxed type, because we
960 -- cast them all to HValues in the end!
961 mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
963 return (zonked_ids, zonked_expr)
966 bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
967 nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
971 tcRnExpr just finds the type of an expression
975 -> InteractiveContext
978 tcRnExpr hsc_env ictxt rdr_expr
979 = initTcPrintErrors hsc_env iNTERACTIVE $
980 setInteractiveContext hsc_env ictxt $ do {
982 (rn_expr, fvs) <- rnLExpr rdr_expr ;
985 -- Now typecheck the expression;
986 -- it might have a rank-2 type (e.g. :t runST)
987 ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
988 ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
989 tcSimplifyInteractive lie_top ;
990 qtvs' <- mappM zonkQuantifiedTyVar qtvs ;
992 let { all_expr_ty = mkForAllTys qtvs' $
993 mkFunTys (map idType dict_ids) $
995 zonkTcType all_expr_ty
998 smpl_doc = ptext SLIT("main expression")
1001 tcRnType just finds the kind of a type
1005 -> InteractiveContext
1008 tcRnType hsc_env ictxt rdr_type
1009 = initTcPrintErrors hsc_env iNTERACTIVE $
1010 setInteractiveContext hsc_env ictxt $ do {
1012 rn_type <- rnLHsType doc rdr_type ;
1015 -- Now kind-check the type
1016 (ty', kind) <- kcHsType rn_type ;
1020 doc = ptext SLIT("In GHCi input")
1026 %************************************************************************
1028 More GHCi stuff, to do with browsing and getting info
1030 %************************************************************************
1034 mkExportEnv :: HscEnv -> [Module] -- Expose these modules' exports only
1036 mkExportEnv hsc_env exports
1037 = do { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $
1038 mappM getModuleExports exports
1040 Just envs -> return (foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs)
1041 Nothing -> return emptyGlobalRdrEnv
1042 -- Some error; initTc will have printed it
1045 getModuleExports :: Module -> TcM GlobalRdrEnv
1046 getModuleExports mod
1047 = do { iface <- load_iface mod
1048 ; loadOrphanModules (dep_orphs (mi_deps iface))
1049 -- Load any orphan-module interfaces,
1050 -- so their instances are visible
1051 ; names <- exportsToAvails (mi_exports iface)
1052 ; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod }
1053 | name <- nameSetToList names ] }
1054 ; returnM (mkGlobalRdrEnv gres) }
1056 vanillaProv :: Module -> Provenance
1057 -- We're building a GlobalRdrEnv as if the user imported
1058 -- all the specified modules into the global interactive module
1059 vanillaProv mod = Imported [ImportSpec mod mod False
1060 (srcLocSpan interactiveSrcLoc)] False
1066 -> Module -- Module to inspect
1067 -> Bool -- Grab just the exports, or the whole toplev
1068 -> IO (Maybe [IfaceDecl])
1070 getModuleContents hsc_env mod exports_only
1071 = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only)
1073 get_mod_contents exports_only
1074 | not exports_only -- We want the whole top-level type env
1075 -- so it had better be a home module
1076 = do { hpt <- getHpt
1077 ; case lookupModuleEnv hpt mod of
1078 Just mod_info -> return (map (toIfaceDecl ext_nm) $
1081 md_types (hm_details mod_info))
1082 Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod)))
1083 -- This is a system error; the module should be in the HPT
1086 | otherwise -- Want the exports only
1087 = do { iface <- load_iface mod
1088 ; mappM get_decl [ (mod,avail) | (mod, avails) <- mi_exports iface
1092 get_decl (mod, avail)
1093 = do { main_name <- lookupOrig mod (availName avail)
1094 ; thing <- tcLookupGlobal main_name
1095 ; return (filter_decl (availNames avail) (toIfaceDecl ext_nm thing)) }
1097 ext_nm = interactiveExtNameFun (icPrintUnqual (hsc_IC hsc_env))
1099 ---------------------
1100 filter_decl occs decl@(IfaceClass {ifSigs = sigs})
1101 = decl { ifSigs = filter (keep_sig occs) sigs }
1102 filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon th cons})
1103 = decl { ifCons = IfDataTyCon th (filter (keep_con occs) cons) }
1104 filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
1105 | keep_con occs con = decl
1106 | otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm?
1107 filter_decl occs decl
1110 keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs
1111 keep_con occs con = ifConOcc con `elem` occs
1113 wantToSee (AnId id) = not (isImplicitId id)
1114 wantToSee (ADataCon _) = False -- They'll come via their TyCon
1117 ---------------------
1118 load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
1120 doc = ptext SLIT("context for compiling statements")
1122 ---------------------
1123 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
1124 <+> quotes (ppr mod)
1128 type GetInfoResult = (String, IfaceDecl, Fixity, SrcLoc,
1129 [(IfaceType,SrcLoc)] -- Instances
1132 tcRnGetInfo :: HscEnv
1133 -> InteractiveContext
1135 -> IO (Maybe [GetInfoResult])
1137 -- Used to implemnent :info in GHCi
1139 -- Look up a RdrName and return all the TyThings it might be
1140 -- A capitalised RdrName is given to us in the DataName namespace,
1141 -- but we want to treat it as *both* a data constructor
1142 -- *and* as a type or class constructor;
1143 -- hence the call to dataTcOccs, and we return up to two results
1144 tcRnGetInfo hsc_env ictxt rdr_name
1145 = initTcPrintErrors hsc_env iNTERACTIVE $
1146 setInteractiveContext hsc_env ictxt $ do {
1148 -- If the identifier is a constructor (begins with an
1149 -- upper-case letter), then we need to consider both
1150 -- constructor and type class identifiers.
1151 let { rdr_names = dataTcOccs rdr_name } ;
1153 -- results :: [(Messages, Maybe Name)]
1154 results <- mapM (tryTc . lookupOccRn) rdr_names ;
1156 traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
1157 -- The successful lookups will be (Just name)
1158 let { (warns_s, good_names) = unzip [ (msgs, name)
1159 | (msgs, Just name) <- results] ;
1160 errs_s = [msgs | (msgs, Nothing) <- results] } ;
1162 -- Fail if nothing good happened, else add warnings
1163 if null good_names then
1164 -- No lookup succeeded, so
1165 -- pick the first error message and report it
1166 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
1167 -- while the other is "X is not in scope",
1168 -- we definitely want the former; but we might pick the latter
1169 do { addMessages (head errs_s) ; failM }
1170 else -- Add deprecation warnings
1171 mapM_ addMessages warns_s ;
1173 -- And lookup up the entities, avoiding duplicates, which arise
1174 -- because constructors and record selectors are represented by
1175 -- their parent declaration
1176 let { do_one name = do { thing <- tcLookupGlobal name
1177 ; fixity <- lookupFixityRn name
1178 ; dfuns <- lookupInsts ext_nm thing
1179 ; return (str, toIfaceDecl ext_nm thing, fixity,
1181 [(toIfaceType ext_nm (idType dfun), getSrcLoc dfun) | dfun <- dfuns]
1184 -- str is the the naked occurrence name
1185 -- after stripping off qualification and parens (+)
1186 str = occNameUserString (nameOccName name)
1189 -- For the SrcLoc, the 'thing' has better info than
1190 -- the 'name' because getting the former forced the
1191 -- declaration to be loaded into the cache
1193 results <- mapM do_one good_names ;
1194 return (fst (removeDups cmp results))
1197 cmp (_,d1,_,_,_) (_,d2,_,_,_) = ifName d1 `compare` ifName d2
1198 ext_nm = interactiveExtNameFun (icPrintUnqual ictxt)
1201 lookupInsts :: (Name -> IfaceExtName) -> TyThing -> TcM [DFunId]
1202 -- Filter the instances by the ones whose tycons (or clases resp)
1203 -- are in scope unqualified. Otherwise we list a whole lot too many!
1204 lookupInsts ext_nm (AClass cls)
1205 = do { loadImportedInsts cls [] -- [] means load all instances for cls
1206 ; inst_envs <- tcGetInstEnvs
1208 | (_,_,dfun) <- classInstances inst_envs cls
1209 , let (_, tycons) = ifaceInstGates (ifInstHead (dfunToIfaceInst ext_nm dfun))
1210 -- Rather an indirect/inefficient test, but there we go
1211 , all print_tycon_unqual tycons ] }
1213 print_tycon_unqual (IfaceTc nm) = isLocalIfaceExtName nm
1214 print_tycon_unqual other = True -- Int etc
1217 lookupInsts ext_nm (ATyCon tc)
1218 = do { eps <- getEps -- Load all instances for all classes that are
1219 -- in the type environment (which are all the ones
1220 -- we've seen in any interface file so far)
1221 ; mapM_ (\c -> loadImportedInsts c [])
1222 (typeEnvClasses (eps_PTE eps))
1223 ; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all
1225 | (_, _, dfun) <- instEnvElts home_ie ++ instEnvElts pkg_ie
1227 , let (cls, _) = ifaceInstGates (ifInstHead (dfunToIfaceInst ext_nm dfun))
1228 , isLocalIfaceExtName cls ] }
1230 relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
1231 tc_name = tyConName tc
1233 lookupInsts ext_nm other = return []
1236 toIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl
1237 toIfaceDecl ext_nm thing
1238 = tyThingToIfaceDecl True -- Discard IdInfo
1239 emptyNameSet -- Show data cons
1240 ext_nm (munge thing)
1242 -- munge transforms a thing to its "parent" thing
1243 munge (ADataCon dc) = ATyCon (dataConTyCon dc)
1244 munge (AnId id) = case globalIdDetails id of
1245 RecordSelId tc lbl -> ATyCon tc
1246 ClassOpId cls -> AClass cls
1248 munge other_thing = other_thing
1252 %************************************************************************
1256 %************************************************************************
1259 rnDump :: SDoc -> TcRn ()
1260 -- Dump, with a banner, if -ddump-rn
1261 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1263 tcDump :: TcGblEnv -> TcRn ()
1265 = do { dflags <- getDOpts ;
1267 -- Dump short output if -ddump-types or -ddump-tc
1268 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1269 (dumpTcRn short_dump) ;
1271 -- Dump bindings if -ddump-tc
1272 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1275 short_dump = pprTcGblEnv env
1276 full_dump = pprLHsBinds (tcg_binds env)
1277 -- NB: foreign x-d's have undefined's in their types;
1278 -- hence can't show the tc_fords
1281 = do { dflags <- getDOpts ;
1282 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1283 (dumpTcRn (pprModGuts mod_guts)) ;
1285 -- Dump bindings if -ddump-tc
1286 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1288 full_dump = pprCoreBindings (mg_binds mod_guts)
1290 -- It's unpleasant having both pprModGuts and pprModDetails here
1291 pprTcGblEnv :: TcGblEnv -> SDoc
1292 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1293 tcg_insts = dfun_ids,
1295 tcg_imports = imports })
1296 = vcat [ ppr_types dfun_ids type_env
1297 , ppr_insts dfun_ids
1298 , vcat (map ppr rules)
1299 , ppr_gen_tycons (typeEnvTyCons type_env)
1300 , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports))
1301 , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1303 pprModGuts :: ModGuts -> SDoc
1304 pprModGuts (ModGuts { mg_types = type_env,
1306 = vcat [ ppr_types [] type_env,
1310 ppr_types :: [Var] -> TypeEnv -> SDoc
1311 ppr_types dfun_ids type_env
1312 = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1314 ids = [id | id <- typeEnvIds type_env, want_sig id]
1315 want_sig id | opt_PprStyle_Debug = True
1316 | otherwise = isLocalId id &&
1317 isExternalName (idName id) &&
1318 not (id `elem` dfun_ids)
1319 -- isLocalId ignores data constructors, records selectors etc.
1320 -- The isExternalName ignores local dictionary and method bindings
1321 -- that the type checker has invented. Top-level user-defined things
1322 -- have External names.
1324 ppr_insts :: [Var] -> SDoc
1325 ppr_insts [] = empty
1326 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1328 ppr_sigs :: [Var] -> SDoc
1330 -- Print type signatures; sort by OccName
1331 = vcat (map ppr_sig (sortLe le_sig ids))
1333 le_sig id1 id2 = getOccName id1 <= getOccName id2
1334 ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
1336 ppr_rules :: [IdCoreRule] -> SDoc
1337 ppr_rules [] = empty
1338 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1339 nest 4 (pprIdRules rs),
1342 ppr_gen_tycons [] = empty
1343 ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"),
1344 nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]