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 )
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 Module ( lookupModuleEnv )
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 -- Record boot-file info in the EPS, so that it's
173 -- visible to loadHiBootInterface in tcRnSrcDecls,
174 -- and any other incrementally-performed imports
175 let { dep_mods :: ModuleEnv (Module, IsBootInterface)
176 ; dep_mods = imp_dep_mods imports } ;
178 updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
180 -- Update the gbl env
181 let { home_insts = hptInstances hsc_env (moduleEnvElts dep_mods) } ;
183 gbl { tcg_rdr_env = rdr_env,
184 tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
185 tcg_imports = tcg_imports gbl `plusImportAvails` imports })
188 traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
189 -- Fail if there are any errors so far
190 -- The error printing (if needed) takes advantage
191 -- of the tcg_env we have now set
194 -- Load any orphan-module interfaces, so that
195 -- their rules and instance decls will be found
196 loadOrphanModules (imp_orphs imports) ;
198 traceRn (text "rn1a") ;
199 -- Rename and type check the declarations
200 tcg_env <- if isHsBoot hsc_src then
201 tcRnHsBootDecls local_decls
203 tcRnSrcDecls local_decls ;
204 setGblEnv tcg_env $ do {
206 traceRn (text "rn3") ;
208 -- Report the use of any deprecated things
209 -- We do this before processsing the export list so
210 -- that we don't bleat about re-exporting a deprecated
211 -- thing (especially via 'module Foo' export item)
212 -- Only uses in the body of the module are complained about
213 reportDeprecations tcg_env ;
215 -- Process the export list
216 exports <- exportsFromAvail (isJust maybe_mod) export_ies ;
218 -- Check whether the entire module is deprecated
219 -- This happens only once per module
220 let { mod_deprecs = checkModDeprec mod_deprec } ;
222 -- Add exports and deprecations to envt
223 let { final_env = tcg_env { tcg_exports = exports,
224 tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
225 tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
227 -- A module deprecation over-rides the earlier ones
230 -- Report unused names
231 reportUnusedNames final_env ;
233 -- Dump output and return
238 -- This is really a sanity check that the user has given -package-name
239 -- if necessary. -package-name is only necessary when the package database
240 -- already contains the current package, because then we can't tell
241 -- whether a given module is in the current package or not, without knowing
242 -- the name of the current package.
243 checkForPackageModule dflags this_mod
244 | not (isHomeModule dflags this_mod),
245 Just (pkg,_) <- moduleToPackageConfig dflags this_mod =
247 ppr_pkg = ppr (mkPackageId (package pkg))
249 addErr (ptext SLIT("Module") <+> quotes (ppr this_mod) <+>
250 ptext SLIT("is a member of package") <+> ppr_pkg <> char '.' $$
251 ptext SLIT("To compile this module, please use -ignore-package") <+> ppr_pkg <> char '.')
252 | otherwise = return ()
256 %************************************************************************
258 Type-checking external-core modules
260 %************************************************************************
263 tcRnExtCore :: HscEnv
265 -> IO (Messages, Maybe ModGuts)
266 -- Nothing => some error occurred
268 tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
269 -- The decls are IfaceDecls; all names are original names
270 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
272 initTc hsc_env ExtCoreFile this_mod $ do {
274 let { ldecls = map noLoc decls } ;
276 -- Deal with the type declarations; first bring their stuff
277 -- into scope, then rname them, then type check them
278 (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ;
280 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
281 tcg_imports = imports `plusImportAvails` tcg_imports gbl })
284 rn_decls <- rnTyClDecls ldecls ;
287 -- Dump trace of renaming part
288 rnDump (ppr rn_decls) ;
290 -- Typecheck them all together so that
291 -- any mutually recursive types are done right
292 tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot names -}] rn_decls) ;
293 -- Make the new type env available to stuff slurped from interface files
295 setGblEnv tcg_env $ do {
297 -- Now the core bindings
298 core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
302 bndrs = bindersOfBinds core_binds ;
303 my_exports = mkNameSet (map idName bndrs) ;
304 -- ToDo: export the data types also?
306 final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
308 mod_guts = ModGuts { mg_module = this_mod,
310 mg_usages = [], -- ToDo: compute usage
311 mg_dir_imps = [], -- ??
312 mg_deps = noDependencies, -- ??
313 mg_exports = my_exports,
314 mg_types = final_type_env,
315 mg_insts = tcg_insts tcg_env,
317 mg_binds = core_binds,
320 mg_rdr_env = emptyGlobalRdrEnv,
321 mg_fix_env = emptyFixityEnv,
322 mg_deprecs = NoDeprecs,
326 tcCoreDump mod_guts ;
331 mkFakeGroup decls -- Rather clumsy; lots of unused fields
332 = HsGroup { hs_tyclds = decls, -- This is the one we want
333 hs_valds = [], hs_fords = [],
334 hs_instds = [], hs_fixds = [], hs_depds = [],
335 hs_ruleds = [], hs_defds = [] }
339 %************************************************************************
341 Type-checking the top level of a module
343 %************************************************************************
346 tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
347 -- Returns the variables free in the decls
348 -- Reason: solely to report unused imports and bindings
350 = do { -- Load the hi-boot interface for this module, if any
351 -- We do this now so that the boot_names can be passed
352 -- to tcTyAndClassDecls, because the boot_names are
353 -- automatically considered to be loop breakers
354 boot_names <- loadHiBootInterface ;
356 -- Do all the declarations
357 (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_names decls) ;
359 -- tcSimplifyTop deals with constant or ambiguous InstIds.
360 -- How could there be ambiguous ones? They can only arise if a
361 -- top-level decl falls under the monomorphism
362 -- restriction, and no subsequent decl instantiates its
363 -- type. (Usually, ambiguous type variables are resolved
364 -- during the generalisation step.)
365 traceTc (text "Tc8") ;
366 inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
367 -- Setting the global env exposes the instances to tcSimplifyTop
368 -- Setting the local env exposes the local Ids to tcSimplifyTop,
369 -- so that we get better error messages (monomorphism restriction)
371 -- Backsubstitution. This must be done last.
372 -- Even tcSimplifyTop may do some unification.
373 traceTc (text "Tc9") ;
374 let { (tcg_env, _) = tc_envs ;
375 TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
376 tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
378 (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
381 let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
383 -- Compre the hi-boot iface (if any) with the real thing
384 checkHiBootIface final_type_env boot_names ;
386 -- Make the new type env available to stuff slurped from interface files
387 writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
389 return (tcg_env { tcg_type_env = final_type_env,
390 tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' })
393 tc_rn_src_decls :: [Name] -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
394 -- Loops around dealing with each top level inter-splice group
395 -- in turn, until it's dealt with the entire module
396 tc_rn_src_decls boot_names ds
397 = do { let { (first_group, group_tail) = findSplice ds } ;
398 -- If ds is [] we get ([], Nothing)
400 -- Type check the decls up to, but not including, the first splice
401 tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_names first_group ;
403 -- Bale out if errors; for example, error recovery when checking
404 -- the RHS of 'main' can mean that 'main' is not in the envt for
405 -- the subsequent checkMain test
410 -- If there is no splice, we're nearly done
412 Nothing -> do { -- Last thing: check for `main'
413 tcg_env <- checkMain ;
414 return (tcg_env, tcl_env)
417 -- If there's a splice, we must carry on
418 Just (SpliceDecl splice_expr, rest_ds) -> do {
420 failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
423 -- Rename the splice expression, and get its supporting decls
424 (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
425 failIfErrsM ; -- Don't typecheck if renaming failed
427 -- Execute the splice
428 spliced_decls <- tcSpliceDecls rn_splice_expr ;
430 -- Glue them on the front of the remaining decls and loop
431 setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
432 tc_rn_src_decls boot_names (spliced_decls ++ rest_ds)
437 %************************************************************************
439 Compiling hs-boot source files, and
440 comparing the hi-boot interface with the real thing
442 %************************************************************************
445 tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
446 tcRnHsBootDecls decls
447 = do { let { (first_group, group_tail) = findSplice decls }
450 Just stuff -> spliceInHsBootErr stuff
453 -- Rename the declarations
454 ; (tcg_env, rn_group) <- rnTopSrcDecls first_group
455 ; setGblEnv tcg_env $ do {
457 -- Todo: check no foreign decls, no rules, no default decls
459 -- Typecheck type/class decls
460 ; traceTc (text "Tc2")
461 ; let tycl_decls = hs_tyclds rn_group
462 ; tcg_env <- checkNoErrs (tcTyAndClassDecls [{- no boot_names -}] tycl_decls)
463 ; setGblEnv tcg_env $ do {
465 -- Typecheck instance decls
466 ; traceTc (text "Tc3")
467 ; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group)
468 ; setGblEnv tcg_env $ do {
470 -- Typecheck value declarations
471 ; traceTc (text "Tc5")
472 ; (tc_val_binds, lcl_env) <- tcHsBootSigs (hs_valds rn_group)
475 -- No simplification or zonking to do
476 ; traceTc (text "Tc7a")
477 ; gbl_env <- getGblEnv
479 ; let { new_ids = [ id | ATcId id _ _ <- varEnvElts (tcl_env lcl_env) ]
480 ; final_type_env = extendTypeEnvWithIds (tcg_type_env gbl_env) new_ids }
482 ; return (gbl_env { tcg_type_env = final_type_env })
485 spliceInHsBootErr (SpliceDecl (L loc _), _)
486 = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files"))
489 In both one-shot mode and GHCi mode, hi-boot interfaces are demand-loaded
490 into the External Package Table. Once we've typechecked the body of the
491 module, we want to compare what we've found (gathered in a TypeEnv) with
492 the hi-boot stuff in the EPT. We do so here, using the export list of
493 the hi-boot interface as our checklist.
496 checkHiBootIface :: TypeEnv -> [Name] -> TcM ()
497 -- Compare the hi-boot file for this module (if there is one)
498 -- with the type environment we've just come up with
499 -- In the common case where there is no hi-boot file, the list
500 -- of boot_names is empty.
501 checkHiBootIface env boot_names
502 = mapM_ (check_one env) boot_names
505 check_one local_env name
506 | isWiredInName name -- No checking for wired-in names. In particular, 'error'
507 = return () -- is handled by a rather gross hack (see comments in GHC.Err.hs-boot)
509 = do { (eps,hpt) <- getEpsAndHpt
511 -- Look up the hi-boot one;
512 -- it should jolly well be there (else GHC bug)
513 ; case lookupType hpt (eps_PTE eps) name of {
514 Nothing -> pprPanic "checkHiBootIface" (ppr name) ;
517 -- Look it up in the local type env
518 -- It should be there, but it's a programmer error if not
519 case lookupTypeEnv local_env name of
520 Nothing -> addErrTc (missingBootThing boot_thing)
521 Just real_thing -> check_thing boot_thing real_thing
525 check_thing (ATyCon boot_tc) (ATyCon real_tc)
526 | isSynTyCon boot_tc && isSynTyCon real_tc,
527 defn1 `tcEqType` substTyWith tvs2 (mkTyVarTys tvs1) defn2
530 | tyConKind boot_tc == tyConKind real_tc
533 (tvs1, defn1) = getSynTyConDefn boot_tc
534 (tvs2, defn2) = getSynTyConDefn boot_tc
536 check_thing (AnId boot_id) (AnId real_id)
537 | idType boot_id `tcEqType` idType real_id
540 check_thing (ADataCon dc1) (ADataCon dc2)
541 | idType (dataConWrapId dc1) `tcEqType` idType (dataConWrapId dc2)
544 -- Can't declare a class in a hi-boot file
546 check_thing boot_thing real_thing -- Default case; failure
547 = addErrAt (srcLocSpan (getSrcLoc real_thing))
548 (bootMisMatch real_thing)
551 missingBootThing thing
552 = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
554 = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")
558 %************************************************************************
560 Type-checking the top level of a module
562 %************************************************************************
564 tcRnGroup takes a bunch of top-level source-code declarations, and
566 * gets supporting declarations from interface files
569 * and augments the TcGblEnv with the results
571 In Template Haskell it may be called repeatedly for each group of
572 declarations. It expects there to be an incoming TcGblEnv in the
573 monad; it augments it and returns the new TcGblEnv.
576 tcRnGroup :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
577 -- Returns the variables free in the decls, for unused-binding reporting
578 tcRnGroup boot_names decls
579 = do { -- Rename the declarations
580 (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
581 setGblEnv tcg_env $ do {
583 -- Typecheck the declarations
584 tcTopSrcDecls boot_names rn_decls
587 ------------------------------------------------
588 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
590 = do { -- Bring top level binders into scope
591 (rdr_env, imports) <- importsFromLocalDecls group ;
592 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
593 tcg_imports = imports `plusImportAvails` tcg_imports gbl })
596 traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
597 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
599 -- Rename the source decls
600 (tcg_env, rn_decls) <- rnSrcDecls group ;
603 -- Dump trace of renaming part
604 rnDump (ppr rn_decls) ;
606 return (tcg_env, rn_decls)
609 ------------------------------------------------
610 tcTopSrcDecls :: [Name] -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
611 tcTopSrcDecls boot_names
612 (HsGroup { hs_tyclds = tycl_decls,
613 hs_instds = inst_decls,
614 hs_fords = foreign_decls,
615 hs_defds = default_decls,
616 hs_ruleds = rule_decls,
617 hs_valds = val_binds })
618 = do { -- Type-check the type and class decls, and all imported decls
619 -- The latter come in via tycl_decls
620 traceTc (text "Tc2") ;
622 tcg_env <- checkNoErrs (tcTyAndClassDecls boot_names tycl_decls) ;
623 -- tcTyAndClassDecls recovers internally, but if anything gave rise to
624 -- an error we'd better stop now, to avoid a cascade
626 -- Make these type and class decls available to stuff slurped from interface files
627 writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
630 setGblEnv tcg_env $ do {
631 -- Source-language instances, including derivings,
632 -- and import the supporting declarations
633 traceTc (text "Tc3") ;
634 (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
635 setGblEnv tcg_env $ do {
637 -- Foreign import declarations next. No zonking necessary
638 -- here; we can tuck them straight into the global environment.
639 traceTc (text "Tc4") ;
640 (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
641 tcExtendGlobalValEnv fi_ids $ do {
643 -- Default declarations
644 traceTc (text "Tc4a") ;
645 default_tys <- tcDefaults default_decls ;
646 updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
648 -- Value declarations next
649 -- We also typecheck any extra binds that came out
650 -- of the "deriving" process (deriv_binds)
651 traceTc (text "Tc5") ;
652 (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ;
653 setLclTypeEnv lcl_env $ do {
655 -- Second pass over class and instance declarations,
656 traceTc (text "Tc6") ;
657 (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
658 showLIE (text "after instDecls2") ;
661 -- They need to be zonked, so we return them
662 traceTc (text "Tc7") ;
663 (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
666 rules <- tcRules rule_decls ;
669 traceTc (text "Tc7a") ;
670 tcg_env <- getGblEnv ;
671 let { all_binds = tc_val_binds `unionBags`
672 inst_binds `unionBags`
675 -- Extend the GblEnv with the (as yet un-zonked)
676 -- bindings, rules, foreign decls
677 tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
678 tcg_rules = tcg_rules tcg_env ++ rules,
679 tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
680 return (tcg_env', lcl_env)
685 %************************************************************************
689 %************************************************************************
693 = do { ghci_mode <- getGhciMode ;
694 tcg_env <- getGblEnv ;
696 mb_main_mod <- readMutVar v_MainModIs ;
697 mb_main_fn <- readMutVar v_MainFunIs ;
698 let { main_mod = case mb_main_mod of {
699 Just mod -> mkModule mod ;
701 main_fn = case mb_main_fn of {
702 Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
703 Nothing -> main_RDR_Unqual } } ;
705 check_main ghci_mode tcg_env main_mod main_fn
709 check_main ghci_mode tcg_env main_mod main_fn
710 -- If we are in module Main, check that 'main' is defined.
711 -- It may be imported from another module!
714 -- Blimey: a whole page of code to do this...
719 = addErrCtxt mainCtxt $
720 do { mb_main <- lookupSrcOcc_maybe main_fn
721 -- Check that 'main' is in scope
722 -- It might be imported from another module!
724 Nothing -> do { complain_no_main
727 { let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) }
728 -- :Main.main :: IO () = runMainIO main
730 ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
733 ; let { root_main_id = mkExportedLocalId rootMainName ty ;
734 main_bind = noLoc (VarBind root_main_id main_expr) }
736 ; return (tcg_env { tcg_binds = tcg_binds tcg_env
738 tcg_dus = tcg_dus tcg_env
739 `plusDU` usesOnly (unitFV main_name)
740 -- Record the use of 'main', so that we don't
741 -- complain about it being defined but not used
745 mod = tcg_mod tcg_env
747 complain_no_main | ghci_mode == Interactive = return ()
748 | otherwise = failWithTc noMainMsg
749 -- In interactive mode, don't worry about the absence of 'main'
750 -- In other modes, fail altogether, so that we don't go on
751 -- and complain a second time when processing the export list.
753 mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
754 noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
755 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
759 %*********************************************************
763 %*********************************************************
767 setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
768 setInteractiveContext hsc_env icxt thing_inside
770 root_modules :: [(Module, IsBootInterface)]
771 root_modules = [(mkModule m, False) | m <- ic_toplev_scope icxt]
772 dfuns = hptInstances hsc_env root_modules
774 updGblEnv (\env -> env {
775 tcg_rdr_env = ic_rn_gbl_env icxt,
776 tcg_type_env = ic_type_env icxt,
777 tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $
779 updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt }) $
781 do { traceTc (text "setIC" <+> ppr (ic_type_env icxt))
788 -> InteractiveContext
790 -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
791 -- The returned [Name] is the same as the input except for
792 -- ExprStmt, in which case the returned [Name] is [itName]
794 -- The returned TypecheckedHsExpr is of type IO [ () ],
795 -- a list of the bound values, coerced to ().
797 tcRnStmt hsc_env ictxt rdr_stmt
798 = initTcPrintErrors hsc_env iNTERACTIVE $
799 setInteractiveContext hsc_env ictxt $ do {
801 -- Rename; use CmdLineMode because tcRnStmt is only used interactively
802 ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ;
803 traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
806 -- The real work is done here
807 (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
809 traceTc (text "tcs 1") ;
810 let { -- (a) Make all the bound ids "global" ids, now that
811 -- they're notionally top-level bindings. This is
812 -- important: otherwise when we come to compile an expression
813 -- using these ids later, the byte code generator will consider
814 -- the occurrences to be free rather than global.
816 -- (b) Tidy their types; this is important, because :info may
817 -- ask to look at them, and :info expects the things it looks
818 -- up to have tidy types
819 global_ids = map globaliseAndTidy bound_ids ;
821 -- Update the interactive context
822 rn_env = ic_rn_local_env ictxt ;
823 type_env = ic_type_env ictxt ;
825 bound_names = map idName global_ids ;
826 new_rn_env = extendLocalRdrEnv rn_env bound_names ;
828 -- Remove any shadowed bindings from the type_env;
829 -- they are inaccessible but might, I suppose, cause
830 -- a space leak if we leave them there
831 shadowed = [ n | name <- bound_names,
832 let rdr_name = mkRdrUnqual (nameOccName name),
833 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
835 filtered_type_env = delListFromNameEnv type_env shadowed ;
836 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
838 new_ic = ictxt { ic_rn_local_env = new_rn_env,
839 ic_type_env = new_type_env }
842 dumpOptTcRn Opt_D_dump_tc
843 (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
844 text "Typechecked expr" <+> ppr tc_expr]) ;
846 returnM (new_ic, bound_names, tc_expr)
849 globaliseAndTidy :: Id -> Id
851 -- Give the Id a Global Name, and tidy its type
852 = setIdType (globaliseId VanillaGlobal id) tidy_type
854 tidy_type = tidyTopType (idType id)
857 Here is the grand plan, implemented in tcUserStmt
859 What you type The IO [HValue] that hscStmt returns
860 ------------- ------------------------------------
861 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
864 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
867 expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it]
868 [NB: result not printed] bindings: [it]
870 expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it]
871 result showable) bindings: [it]
873 expr (of non-IO type,
874 result not showable) ==> error
878 ---------------------------
879 tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
880 tcUserStmt (L _ (ExprStmt expr _))
881 = newUnique `thenM` \ uniq ->
883 fresh_it = itName uniq
884 the_bind = noLoc $ FunBind (noLoc fresh_it) False
885 (mkMatchGroup [mkSimpleMatch [] expr])
887 tryTcLIE_ (do { -- Try this if the other fails
888 traceTc (text "tcs 1b") ;
890 nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
891 nlExprStmt (nlHsApp (nlHsVar printName)
894 (do { -- Try this first
895 traceTc (text "tcs 1a") ;
896 tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] })
898 tcUserStmt stmt = tc_stmts [stmt]
900 ---------------------------
902 = do { ioTyCon <- tcLookupTyCon ioTyConName ;
904 ret_ty = mkListTy unitTy ;
905 io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
907 names = map unLoc (collectStmtsBinders stmts) ;
909 stmt_ctxt = SC { sc_what = DoExpr,
911 sc_body = check_body,
914 infer_rhs rhs = do { (rhs', rhs_ty) <- tcInferRho rhs
915 ; [pat_ty] <- unifyTyConApp ioTyCon rhs_ty
916 ; return (rhs', pat_ty) } ;
917 check_body body = tcCheckRho body io_ret_ty ;
919 -- mk_return builds the expression
920 -- returnIO @ [()] [coerce () x, .., coerce () z]
922 -- Despite the inconvenience of building the type applications etc,
923 -- this *has* to be done in type-annotated post-typecheck form
924 -- because we are going to return a list of *polymorphic* values
925 -- coerced to type (). If we built a *source* stmt
926 -- return [coerce x, ..., coerce z]
927 -- then the type checker would instantiate x..z, and we wouldn't
928 -- get their *polymorphic* values. (And we'd get ambiguity errs
929 -- if they were overloaded, since they aren't applied to anything.)
930 mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
931 (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
932 mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
935 io_ty = mkTyConApp ioTyCon []
938 -- OK, we're ready to typecheck the stmts
939 traceTc (text "tcs 2") ;
940 ((ids, tc_expr), lie) <- getLIE $ do {
941 (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts $
943 -- Look up the names right in the middle,
944 -- where they will all be in scope
945 ids <- mappM tcLookupId names ;
946 ret_id <- tcLookupId returnIOName ; -- return @ IO
947 return (ids, [nlResultStmt (mk_return ret_id ids)]) } ;
949 io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
950 return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty))
953 -- Simplify the context right here, so that we fail
954 -- if there aren't enough instances. Notably, when we see
956 -- we use recoverTc_ to try it <- e
957 -- and then let it = e
958 -- It's the simplify step that rejects the first.
959 traceTc (text "tcs 3") ;
960 const_binds <- tcSimplifyInteractive lie ;
962 -- Build result expression and zonk it
963 let { expr = mkHsLet const_binds tc_expr } ;
964 zonked_expr <- zonkTopLExpr expr ;
965 zonked_ids <- zonkTopBndrs ids ;
967 -- None of the Ids should be of unboxed type, because we
968 -- cast them all to HValues in the end!
969 mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
971 return (zonked_ids, zonked_expr)
974 combine stmt (ids, stmts) = (ids, stmt:stmts)
975 bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
976 nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
980 tcRnExpr just finds the type of an expression
984 -> InteractiveContext
987 tcRnExpr hsc_env ictxt rdr_expr
988 = initTcPrintErrors hsc_env iNTERACTIVE $
989 setInteractiveContext hsc_env ictxt $ do {
991 (rn_expr, fvs) <- rnLExpr rdr_expr ;
994 -- Now typecheck the expression;
995 -- it might have a rank-2 type (e.g. :t runST)
996 ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
997 ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
998 tcSimplifyInteractive lie_top ;
999 qtvs' <- mappM zonkQuantifiedTyVar qtvs ;
1001 let { all_expr_ty = mkForAllTys qtvs' $
1002 mkFunTys (map idType dict_ids) $
1004 zonkTcType all_expr_ty
1007 smpl_doc = ptext SLIT("main expression")
1010 tcRnType just finds the kind of a type
1014 -> InteractiveContext
1017 tcRnType hsc_env ictxt rdr_type
1018 = initTcPrintErrors hsc_env iNTERACTIVE $
1019 setInteractiveContext hsc_env ictxt $ do {
1021 rn_type <- rnLHsType doc rdr_type ;
1024 -- Now kind-check the type
1025 (ty', kind) <- kcHsType rn_type ;
1029 doc = ptext SLIT("In GHCi input")
1035 %************************************************************************
1037 More GHCi stuff, to do with browsing and getting info
1039 %************************************************************************
1043 mkExportEnv :: HscEnv -> [Module] -- Expose these modules' exports only
1045 mkExportEnv hsc_env exports
1046 = do { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $
1047 mappM getModuleExports exports
1049 Just envs -> return (foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs)
1050 Nothing -> return emptyGlobalRdrEnv
1051 -- Some error; initTc will have printed it
1054 getModuleExports :: Module -> TcM GlobalRdrEnv
1055 getModuleExports mod
1056 = do { iface <- load_iface mod
1057 ; loadOrphanModules (dep_orphs (mi_deps iface))
1058 -- Load any orphan-module interfaces,
1059 -- so their instances are visible
1060 ; names <- exportsToAvails (mi_exports iface)
1061 ; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod }
1062 | name <- nameSetToList names ] }
1063 ; returnM (mkGlobalRdrEnv gres) }
1065 vanillaProv :: Module -> Provenance
1066 -- We're building a GlobalRdrEnv as if the user imported
1067 -- all the specified modules into the global interactive module
1068 vanillaProv mod = Imported [ImportSpec mod mod False
1069 (srcLocSpan interactiveSrcLoc)] False
1075 -> InteractiveContext
1076 -> Module -- Module to inspect
1077 -> Bool -- Grab just the exports, or the whole toplev
1078 -> IO (Maybe [IfaceDecl])
1080 getModuleContents hsc_env ictxt mod exports_only
1081 = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only)
1083 get_mod_contents exports_only
1084 | not exports_only -- We want the whole top-level type env
1085 -- so it had better be a home module
1086 = do { hpt <- getHpt
1087 ; case lookupModuleEnv hpt mod of
1088 Just mod_info -> return (map toIfaceDecl $
1091 md_types (hm_details mod_info))
1092 Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod)))
1093 -- This is a system error; the module should be in the HPT
1096 | otherwise -- Want the exports only
1097 = do { iface <- load_iface mod
1098 ; mappM get_decl [ (mod,avail) | (mod, avails) <- mi_exports iface
1102 get_decl (mod, avail)
1103 = do { main_name <- lookupOrig mod (availName avail)
1104 ; thing <- tcLookupGlobal main_name
1105 ; return (filter_decl (availNames avail) (toIfaceDecl thing)) }
1107 ---------------------
1108 filter_decl occs decl@(IfaceClass {ifSigs = sigs})
1109 = decl { ifSigs = filter (keep_sig occs) sigs }
1110 filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon th cons})
1111 = decl { ifCons = IfDataTyCon th (filter (keep_con occs) cons) }
1112 filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
1113 | keep_con occs con = decl
1114 | otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm?
1115 filter_decl occs decl
1118 keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs
1119 keep_con occs con = ifConOcc con `elem` occs
1121 wantToSee (AnId id) = not (isImplicitId id)
1122 wantToSee (ADataCon _) = False -- They'll come via their TyCon
1125 ---------------------
1126 load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
1128 doc = ptext SLIT("context for compiling statements")
1130 ---------------------
1131 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
1132 <+> quotes (ppr mod)
1136 tcRnGetInfo :: HscEnv
1137 -> InteractiveContext
1139 -> IO (Maybe [(IfaceDecl,
1141 [(IfaceInst, SrcLoc)])])
1142 -- Used to implemnent :info in GHCi
1144 -- Look up a RdrName and return all the TyThings it might be
1145 -- A capitalised RdrName is given to us in the DataName namespace,
1146 -- but we want to treat it as *both* a data constructor
1147 -- *and* as a type or class constructor;
1148 -- hence the call to dataTcOccs, and we return up to two results
1149 tcRnGetInfo hsc_env ictxt rdr_name
1150 = initTcPrintErrors hsc_env iNTERACTIVE $
1151 setInteractiveContext hsc_env ictxt $ do {
1153 -- If the identifier is a constructor (begins with an
1154 -- upper-case letter), then we need to consider both
1155 -- constructor and type class identifiers.
1156 let { rdr_names = dataTcOccs rdr_name } ;
1158 -- results :: [(Messages, Maybe Name)]
1159 results <- mapM (tryTc . lookupOccRn) rdr_names ;
1161 traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
1162 -- The successful lookups will be (Just name)
1163 let { (warns_s, good_names) = unzip [ (msgs, name)
1164 | (msgs, Just name) <- results] ;
1165 errs_s = [msgs | (msgs, Nothing) <- results] } ;
1167 -- Fail if nothing good happened, else add warnings
1168 if null good_names then
1169 -- No lookup succeeded, so
1170 -- pick the first error message and report it
1171 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
1172 -- while the other is "X is not in scope",
1173 -- we definitely want the former; but we might pick the latter
1174 do { addMessages (head errs_s) ; failM }
1175 else -- Add deprecation warnings
1176 mapM_ addMessages warns_s ;
1178 -- And lookup up the entities, avoiding duplicates, which arise
1179 -- because constructors and record selectors are represented by
1180 -- their parent declaration
1181 let { do_one name = do { thing <- tcLookupGlobal name
1182 ; fixity <- lookupFixityRn name
1183 ; insts <- lookupInsts print_unqual thing
1184 ; return (toIfaceDecl thing, fixity,
1185 getSrcLoc thing, insts) } } ;
1186 -- For the SrcLoc, the 'thing' has better info than
1187 -- the 'name' because getting the former forced the
1188 -- declaration to be loaded into the cache
1190 results <- mapM do_one good_names ;
1191 return (fst (removeDups cmp results))
1194 cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2
1196 print_unqual :: PrintUnqualified
1197 print_unqual = icPrintUnqual ictxt
1200 lookupInsts :: PrintUnqualified -> TyThing -> TcM [(IfaceInst, SrcLoc)]
1201 -- Filter the instances by the ones whose tycons (or clases resp)
1202 -- are in scope unqualified. Otherwise we list a whole lot too many!
1203 lookupInsts print_unqual (AClass cls)
1204 = do { loadImportedInsts cls [] -- [] means load all instances for cls
1205 ; inst_envs <- tcGetInstEnvs
1206 ; return [ (inst, getSrcLoc dfun)
1207 | (_,_,dfun) <- classInstances inst_envs cls
1208 , let inst = dfunToIfaceInst dfun
1209 (_, tycons) = ifaceInstGates (ifInstHead inst)
1210 , all print_tycon_unqual tycons ] }
1212 print_tycon_unqual (IfaceTc ext_nm) = ifPrintUnqual print_unqual ext_nm
1213 print_tycon_unqual other = True -- Int etc
1216 lookupInsts print_unqual (ATyCon tc)
1217 = do { eps <- getEps -- Load all instances for all classes that are
1218 -- in the type environment (which are all the ones
1219 -- we've seen in any interface file so far)
1220 ; mapM_ (\c -> loadImportedInsts c [])
1221 (typeEnvClasses (eps_PTE eps))
1222 ; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all
1223 ; return [ (inst, getSrcLoc dfun)
1224 | (_, _, dfun) <- instEnvElts home_ie ++ instEnvElts pkg_ie
1226 , let inst = dfunToIfaceInst dfun
1227 (cls, _) = ifaceInstGates (ifInstHead inst)
1228 , ifPrintUnqual print_unqual cls ] }
1230 relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
1231 tc_name = tyConName tc
1233 lookupInsts print_unqual other = return []
1236 toIfaceDecl :: TyThing -> IfaceDecl
1238 = tyThingToIfaceDecl True -- Discard IdInfo
1239 emptyNameSet -- Show data cons
1240 ext_nm (munge thing)
1242 ext_nm n = ExtPkg (nameModule n) (nameOccName n)
1244 -- munge transforms a thing to its "parent" thing
1245 munge (ADataCon dc) = ATyCon (dataConTyCon dc)
1246 munge (AnId id) = case globalIdDetails id of
1247 RecordSelId tc lbl -> ATyCon tc
1248 ClassOpId cls -> AClass cls
1250 munge other_thing = other_thing
1255 %************************************************************************
1259 %************************************************************************
1262 rnDump :: SDoc -> TcRn ()
1263 -- Dump, with a banner, if -ddump-rn
1264 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1266 tcDump :: TcGblEnv -> TcRn ()
1268 = do { dflags <- getDOpts ;
1270 -- Dump short output if -ddump-types or -ddump-tc
1271 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1272 (dumpTcRn short_dump) ;
1274 -- Dump bindings if -ddump-tc
1275 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1278 short_dump = pprTcGblEnv env
1279 full_dump = pprLHsBinds (tcg_binds env)
1280 -- NB: foreign x-d's have undefined's in their types;
1281 -- hence can't show the tc_fords
1284 = do { dflags <- getDOpts ;
1285 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1286 (dumpTcRn (pprModGuts mod_guts)) ;
1288 -- Dump bindings if -ddump-tc
1289 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1291 full_dump = pprCoreBindings (mg_binds mod_guts)
1293 -- It's unpleasant having both pprModGuts and pprModDetails here
1294 pprTcGblEnv :: TcGblEnv -> SDoc
1295 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1296 tcg_insts = dfun_ids,
1298 tcg_imports = imports })
1299 = vcat [ ppr_types dfun_ids type_env
1300 , ppr_insts dfun_ids
1301 , vcat (map ppr rules)
1302 , ppr_gen_tycons (typeEnvTyCons type_env)
1303 , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports))
1304 , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1306 pprModGuts :: ModGuts -> SDoc
1307 pprModGuts (ModGuts { mg_types = type_env,
1309 = vcat [ ppr_types [] type_env,
1313 ppr_types :: [Var] -> TypeEnv -> SDoc
1314 ppr_types dfun_ids type_env
1315 = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1317 ids = [id | id <- typeEnvIds type_env, want_sig id]
1318 want_sig id | opt_PprStyle_Debug = True
1319 | otherwise = isLocalId id &&
1320 isExternalName (idName id) &&
1321 not (id `elem` dfun_ids)
1322 -- isLocalId ignores data constructors, records selectors etc.
1323 -- The isExternalName ignores local dictionary and method bindings
1324 -- that the type checker has invented. Top-level user-defined things
1325 -- have External names.
1327 ppr_insts :: [Var] -> SDoc
1328 ppr_insts [] = empty
1329 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1331 ppr_sigs :: [Var] -> SDoc
1333 -- Print type signatures; sort by OccName
1334 = vcat (map ppr_sig (sortLe le_sig ids))
1336 le_sig id1 id2 = getOccName id1 <= getOccName id2
1337 ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
1339 ppr_rules :: [IdCoreRule] -> SDoc
1340 ppr_rules [] = empty
1341 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1342 nest 4 (pprIdRules rs),
1345 ppr_gen_tycons [] = empty
1346 ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"),
1347 nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]