2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[TcModule]{Typechecking a whole module}
9 mkExportEnv, getModuleContents, tcRnStmt,
10 tcRnGetInfo, GetInfoResult,
19 #include "HsVersions.h"
23 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
26 import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
27 import StaticFlags ( opt_PprStyle_Debug )
28 import Packages ( moduleToPackageConfig, mkPackageId, package,
30 import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl,
31 SpliceDecl(..), HsBind(..), LHsBinds,
32 emptyGroup, appendGroups,
33 nlHsApp, nlHsVar, pprLHsBinds )
34 import RdrHsSyn ( findSplice )
36 import PrelNames ( runMainIOName, rootMainName, mAIN,
38 import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv,
40 import TcHsSyn ( zonkTopDecls )
41 import TcExpr ( tcInferRho )
43 import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith )
44 import Inst ( showLIE )
45 import InstEnv ( extendInstEnvList, Instance, pprInstances, instanceDFunId )
46 import TcBinds ( tcTopBinds, tcHsBootSigs )
47 import TcDefaults ( tcDefaults )
48 import TcEnv ( tcExtendGlobalValEnv, iDFunId )
49 import TcRules ( tcRules )
50 import TcForeign ( tcForeignImports, tcForeignExports )
51 import TcInstDcls ( tcInstDecls1, tcInstDecls2 )
52 import TcIface ( tcExtCoreBindings, tcHiBootIface )
53 import TcSimplify ( tcSimplifyTop )
54 import TcTyClsDecls ( tcTyAndClassDecls )
55 import LoadIface ( loadOrphanModules )
56 import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail,
57 reportUnusedNames, reportDeprecations )
58 import RnEnv ( lookupSrcOcc_maybe )
59 import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec )
60 import PprCore ( pprRules, pprCoreBindings )
61 import CoreSyn ( CoreRule, bindersOfBinds )
62 import DataCon ( dataConWrapId )
63 import ErrUtils ( Messages, mkDumpDoc, showPass )
64 import Id ( Id, mkExportedLocalId, isLocalId, idName, idType )
66 import Module ( Module, ModuleEnv, mkModule, moduleEnvElts, lookupModuleEnv )
67 import OccName ( mkVarOcc )
68 import Name ( Name, NamedThing(..), isExternalName, getSrcLoc,
69 getOccName, isWiredInName )
71 import TyCon ( tyConHasGenerics, isSynTyCon, getSynTyConDefn, tyConKind )
72 import SrcLoc ( srcLocSpan, Located(..), noLoc )
73 import DriverPhases ( HscSource(..), isHsBoot )
74 import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails,
75 HscEnv(..), ExternalPackageState(..),
76 IsBootInterface, noDependencies,
77 Deprecs( NoDeprecs ), plusDeprecs,
78 ForeignStubs(NoStubs), TyThing(..),
79 TypeEnv, lookupTypeEnv, hptInstances,
80 extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts,
86 import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
87 LStmt, LHsExpr, LHsType, mkMatchGroup,
88 collectLStmtsBinders, mkSimpleMatch, nlVarPat,
89 placeHolderType, noSyntaxExpr )
90 import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
91 Provenance(..), ImportSpec(..),
92 lookupLocalRdrEnv, extendLocalRdrEnv )
93 import RnSource ( addTcgDUs )
94 import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs )
95 import TcHsType ( kcHsType )
96 import TcIface ( loadImportedInsts )
97 import TcMType ( zonkTcType, zonkQuantifiedTyVar )
98 import TcMatches ( tcStmts, tcDoStmt )
99 import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer )
100 import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType,
101 isUnLiftedType, tyClsNamesOfDFunHead )
102 import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
103 import RnTypes ( rnLHsType )
104 import Inst ( tcGetInstEnvs )
105 import InstEnv ( DFunId, classInstances, instEnvElts )
106 import RnExpr ( rnStmts, rnLExpr )
107 import LoadIface ( loadSrcInterface, ifaceInstGates )
108 import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
109 IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
110 tyThingToIfaceDecl, instanceToIfaceInst )
111 import IfaceType ( IfaceTyCon(..), IfaceType, toIfaceType,
112 interactiveExtNameFun, isLocalIfaceExtName )
113 import IfaceEnv ( lookupOrig, ifaceExportNames )
114 import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn )
115 import Id ( Id, isImplicitId, setIdType, globalIdDetails )
116 import MkId ( unsafeCoerceId )
117 import DataCon ( dataConTyCon )
118 import TyCon ( tyConName )
119 import TysWiredIn ( mkListTy, unitTy )
120 import IdInfo ( GlobalIdDetails(..) )
121 import SrcLoc ( interactiveSrcLoc, unLoc )
123 import Var ( globaliseId )
124 import Name ( nameOccName )
125 import OccName ( occNameUserString )
126 import NameEnv ( delListFromNameEnv )
127 import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName,
128 bindIOName, thenIOName, returnIOName )
129 import HscTypes ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, typeEnvClasses,
130 availNames, availName, ModIface(..), icPrintUnqual,
131 ModDetails(..), Dependencies(..) )
132 import BasicTypes ( RecFlag(..), Fixity )
133 import ListSetOps ( removeDups )
134 import Panic ( ghcError, GhcException(..) )
135 import SrcLoc ( SrcLoc )
138 import FastString ( mkFastString )
139 import Util ( sortLe )
140 import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags )
142 import Maybe ( isJust )
147 %************************************************************************
149 Typecheck and rename a module
151 %************************************************************************
157 -> Bool -- True <=> save renamed syntax
158 -> Located (HsModule RdrName)
159 -> IO (Messages, Maybe TcGblEnv)
161 tcRnModule hsc_env hsc_src save_rn_decls
162 (L loc (HsModule maybe_mod export_ies
163 import_decls local_decls mod_deprec))
164 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
166 let { this_mod = case maybe_mod of
167 Nothing -> mAIN -- 'module M where' is omitted
168 Just (L _ mod) -> mod } ; -- The normal case
170 initTc hsc_env hsc_src this_mod $
173 checkForPackageModule (hsc_dflags hsc_env) this_mod;
175 -- Deal with imports; sets tcg_rdr_env, tcg_imports
176 (rdr_env, imports) <- rnImports import_decls ;
178 let { dep_mods :: ModuleEnv (Module, IsBootInterface)
179 ; dep_mods = imp_dep_mods imports
181 ; is_dep_mod :: Module -> Bool
182 ; is_dep_mod mod = case lookupModuleEnv dep_mods mod of
184 Just (_, is_boot) -> not is_boot
185 ; home_insts = hptInstances hsc_env is_dep_mod
188 -- Record boot-file info in the EPS, so that it's
189 -- visible to loadHiBootInterface in tcRnSrcDecls,
190 -- and any other incrementally-performed imports
191 updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ;
193 -- Update the gbl env
195 gbl { tcg_rdr_env = rdr_env,
196 tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts,
197 tcg_imports = tcg_imports gbl `plusImportAvails` imports,
198 tcg_rn_decls = if save_rn_decls then
204 traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
205 -- Fail if there are any errors so far
206 -- The error printing (if needed) takes advantage
207 -- of the tcg_env we have now set
210 -- Load any orphan-module interfaces, so that
211 -- their rules and instance decls will be found
212 loadOrphanModules (imp_orphs imports) ;
214 traceRn (text "rn1a") ;
215 -- Rename and type check the declarations
216 tcg_env <- if isHsBoot hsc_src then
217 tcRnHsBootDecls local_decls
219 tcRnSrcDecls local_decls ;
220 setGblEnv tcg_env $ do {
222 traceRn (text "rn3") ;
224 -- Report the use of any deprecated things
225 -- We do this before processsing the export list so
226 -- that we don't bleat about re-exporting a deprecated
227 -- thing (especially via 'module Foo' export item)
228 -- Only uses in the body of the module are complained about
229 reportDeprecations tcg_env ;
231 -- Process the export list
232 exports <- exportsFromAvail (isJust maybe_mod) export_ies ;
234 -- Check whether the entire module is deprecated
235 -- This happens only once per module
236 let { mod_deprecs = checkModDeprec mod_deprec } ;
238 -- Add exports and deprecations to envt
239 let { final_env = tcg_env { tcg_exports = exports,
240 tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
241 tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
243 -- A module deprecation over-rides the earlier ones
246 -- Report unused names
247 reportUnusedNames export_ies final_env ;
249 -- Dump output and return
254 -- This is really a sanity check that the user has given -package-name
255 -- if necessary. -package-name is only necessary when the package database
256 -- already contains the current package, because then we can't tell
257 -- whether a given module is in the current package or not, without knowing
258 -- the name of the current package.
259 checkForPackageModule dflags this_mod
260 | not (isHomeModule dflags this_mod),
261 Just (pkg,_) <- moduleToPackageConfig dflags this_mod =
263 ppr_pkg = ppr (mkPackageId (package pkg))
265 addErr (ptext SLIT("Module") <+> quotes (ppr this_mod) <+>
266 ptext SLIT("is a member of package") <+> ppr_pkg <> char '.' $$
267 ptext SLIT("To compile this module, please use -ignore-package") <+> ppr_pkg <> char '.')
268 | otherwise = return ()
272 %************************************************************************
274 Type-checking external-core modules
276 %************************************************************************
279 tcRnExtCore :: HscEnv
281 -> IO (Messages, Maybe ModGuts)
282 -- Nothing => some error occurred
284 tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
285 -- The decls are IfaceDecls; all names are original names
286 = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
288 initTc hsc_env ExtCoreFile this_mod $ do {
290 let { ldecls = map noLoc decls } ;
292 -- Deal with the type declarations; first bring their stuff
293 -- into scope, then rname them, then type check them
294 (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ;
296 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
297 tcg_imports = imports `plusImportAvails` tcg_imports gbl })
300 rn_decls <- rnTyClDecls ldecls ;
303 -- Dump trace of renaming part
304 rnDump (ppr rn_decls) ;
306 -- Typecheck them all together so that
307 -- any mutually recursive types are done right
308 tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails rn_decls) ;
309 -- Make the new type env available to stuff slurped from interface files
311 setGblEnv tcg_env $ do {
313 -- Now the core bindings
314 core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ;
318 bndrs = bindersOfBinds core_binds ;
319 my_exports = mkNameSet (map idName bndrs) ;
320 -- ToDo: export the data types also?
322 final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
324 mod_guts = ModGuts { mg_module = this_mod,
326 mg_usages = [], -- ToDo: compute usage
327 mg_dir_imps = [], -- ??
328 mg_deps = noDependencies, -- ??
329 mg_exports = my_exports,
330 mg_types = final_type_env,
331 mg_insts = tcg_insts tcg_env,
333 mg_binds = core_binds,
336 mg_rdr_env = emptyGlobalRdrEnv,
337 mg_fix_env = emptyFixityEnv,
338 mg_deprecs = NoDeprecs,
342 tcCoreDump mod_guts ;
347 mkFakeGroup decls -- Rather clumsy; lots of unused fields
348 = HsGroup { hs_tyclds = decls, -- This is the one we want
349 hs_valds = [], hs_fords = [],
350 hs_instds = [], hs_fixds = [], hs_depds = [],
351 hs_ruleds = [], hs_defds = [] }
355 %************************************************************************
357 Type-checking the top level of a module
359 %************************************************************************
362 tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
363 -- Returns the variables free in the decls
364 -- Reason: solely to report unused imports and bindings
366 = do { -- Load the hi-boot interface for this module, if any
367 -- We do this now so that the boot_names can be passed
368 -- to tcTyAndClassDecls, because the boot_names are
369 -- automatically considered to be loop breakers
371 boot_iface <- tcHiBootIface mod ;
373 -- Do all the declarations
374 (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_iface decls) ;
376 -- tcSimplifyTop deals with constant or ambiguous InstIds.
377 -- How could there be ambiguous ones? They can only arise if a
378 -- top-level decl falls under the monomorphism
379 -- restriction, and no subsequent decl instantiates its
380 -- type. (Usually, ambiguous type variables are resolved
381 -- during the generalisation step.)
382 traceTc (text "Tc8") ;
383 inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
384 -- Setting the global env exposes the instances to tcSimplifyTop
385 -- Setting the local env exposes the local Ids to tcSimplifyTop,
386 -- so that we get better error messages (monomorphism restriction)
388 -- Backsubstitution. This must be done last.
389 -- Even tcSimplifyTop may do some unification.
390 traceTc (text "Tc9") ;
391 let { (tcg_env, _) = tc_envs ;
392 TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
393 tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
395 (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
398 let { final_type_env = extendTypeEnvWithIds type_env bind_ids
399 ; tcg_env' = tcg_env { tcg_type_env = final_type_env,
402 tcg_fords = fords' } } ;
404 -- Make the new type env available to stuff slurped from interface files
405 writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
407 -- Compare the hi-boot iface (if any) with the real thing
408 dfun_binds <- checkHiBootIface tcg_env' boot_iface ;
410 return (tcg_env' { tcg_binds = tcg_binds tcg_env' `unionBags` dfun_binds })
413 tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
414 -- Loops around dealing with each top level inter-splice group
415 -- in turn, until it's dealt with the entire module
416 tc_rn_src_decls boot_details ds
417 = do { let { (first_group, group_tail) = findSplice ds } ;
418 -- If ds is [] we get ([], Nothing)
420 -- Type check the decls up to, but not including, the first splice
421 tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_details first_group ;
423 -- Bale out if errors; for example, error recovery when checking
424 -- the RHS of 'main' can mean that 'main' is not in the envt for
425 -- the subsequent checkMain test
430 -- If there is no splice, we're nearly done
432 Nothing -> do { -- Last thing: check for `main'
433 tcg_env <- checkMain ;
434 return (tcg_env, tcl_env)
437 -- If there's a splice, we must carry on
438 Just (SpliceDecl splice_expr, rest_ds) -> do {
440 failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
443 -- Rename the splice expression, and get its supporting decls
444 (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
445 failIfErrsM ; -- Don't typecheck if renaming failed
447 -- Execute the splice
448 spliced_decls <- tcSpliceDecls rn_splice_expr ;
450 -- Glue them on the front of the remaining decls and loop
451 setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
452 tc_rn_src_decls boot_details (spliced_decls ++ rest_ds)
457 %************************************************************************
459 Compiling hs-boot source files, and
460 comparing the hi-boot interface with the real thing
462 %************************************************************************
465 tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
466 tcRnHsBootDecls decls
467 = do { let { (first_group, group_tail) = findSplice decls }
470 Just stuff -> spliceInHsBootErr stuff
473 -- Rename the declarations
474 ; (tcg_env, rn_group) <- rnTopSrcDecls first_group
475 ; setGblEnv tcg_env $ do {
477 -- Todo: check no foreign decls, no rules, no default decls
479 -- Typecheck type/class decls
480 ; traceTc (text "Tc2")
481 ; let tycl_decls = hs_tyclds rn_group
482 ; tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails tycl_decls)
483 ; setGblEnv tcg_env $ do {
485 -- Typecheck instance decls
486 ; traceTc (text "Tc3")
487 ; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group)
488 ; setGblEnv tcg_env $ do {
490 -- Typecheck value declarations
491 ; traceTc (text "Tc5")
492 ; val_ids <- tcHsBootSigs (hs_valds rn_group)
495 -- No simplification or zonking to do
496 ; traceTc (text "Tc7a")
497 ; gbl_env <- getGblEnv
499 -- Make the final type-env
500 -- Include the dfun_ids so that their type sigs get
501 -- are written into the interface file
502 ; let { type_env0 = tcg_type_env gbl_env
503 ; type_env1 = extendTypeEnvWithIds type_env0 val_ids
504 ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids
505 ; dfun_ids = map iDFunId inst_infos }
506 ; return (gbl_env { tcg_type_env = type_env2 })
509 spliceInHsBootErr (SpliceDecl (L loc _), _)
510 = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files"))
513 Once we've typechecked the body of the module, we want to compare what
514 we've found (gathered in a TypeEnv) with the hi-boot details (if any).
517 checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id)
518 -- Compare the hi-boot file for this module (if there is one)
519 -- with the type environment we've just come up with
520 -- In the common case where there is no hi-boot file, the list
521 -- of boot_names is empty.
523 -- The bindings we return give bindings for the dfuns defined in the
524 -- hs-boot file, such as $fbEqT = $fEqT
527 (TcGblEnv { tcg_insts = local_insts, tcg_type_env = local_type_env })
528 (ModDetails { md_insts = boot_insts, md_types = boot_type_env })
529 = do { mapM_ check_one (typeEnvElts boot_type_env)
530 ; dfun_binds <- mapM check_inst boot_insts
531 ; return (unionManyBags dfun_binds) }
537 = case lookupTypeEnv local_type_env name of
538 Nothing -> addErrTc (missingBootThing boot_thing)
539 Just real_thing -> check_thing boot_thing real_thing
541 name = getName boot_thing
543 no_check name = isWiredInName name -- No checking for wired-in names. In particular,
544 -- 'error' is handled by a rather gross hack
545 -- (see comments in GHC.Err.hs-boot)
546 || name `elem` dfun_names
547 dfun_names = map getName boot_insts
550 = case [dfun | inst <- local_insts,
551 let dfun = instanceDFunId inst,
552 idType dfun `tcEqType` boot_inst_ty ] of
553 [] -> do { addErrTc (instMisMatch boot_inst); return emptyBag }
554 (dfun:_) -> return (unitBag $ noLoc $ VarBind boot_dfun (nlHsVar dfun))
556 boot_dfun = instanceDFunId boot_inst
557 boot_inst_ty = idType boot_dfun
560 check_thing (ATyCon boot_tc) (ATyCon real_tc)
561 | isSynTyCon boot_tc && isSynTyCon real_tc,
562 defn1 `tcEqType` substTyWith tvs2 (mkTyVarTys tvs1) defn2
565 | tyConKind boot_tc == tyConKind real_tc
568 (tvs1, defn1) = getSynTyConDefn boot_tc
569 (tvs2, defn2) = getSynTyConDefn boot_tc
571 check_thing (AnId boot_id) (AnId real_id)
572 | idType boot_id `tcEqType` idType real_id
575 check_thing (ADataCon dc1) (ADataCon dc2)
576 | idType (dataConWrapId dc1) `tcEqType` idType (dataConWrapId dc2)
579 -- Can't declare a class in a hi-boot file
581 check_thing boot_thing real_thing -- Default case; failure
582 = addErrAt (srcLocSpan (getSrcLoc real_thing))
583 (bootMisMatch real_thing)
586 missingBootThing thing
587 = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module")
589 = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file")
591 = hang (ptext SLIT("instance") <+> ppr inst)
592 2 (ptext SLIT("is defined in the hs-boot file, but not in the module"))
596 %************************************************************************
598 Type-checking the top level of a module
600 %************************************************************************
602 tcRnGroup takes a bunch of top-level source-code declarations, and
604 * gets supporting declarations from interface files
607 * and augments the TcGblEnv with the results
609 In Template Haskell it may be called repeatedly for each group of
610 declarations. It expects there to be an incoming TcGblEnv in the
611 monad; it augments it and returns the new TcGblEnv.
614 tcRnGroup :: ModDetails -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
615 -- Returns the variables free in the decls, for unused-binding reporting
616 tcRnGroup boot_details decls
617 = do { -- Rename the declarations
618 (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
619 setGblEnv tcg_env $ do {
621 -- Typecheck the declarations
622 tcTopSrcDecls boot_details rn_decls
625 ------------------------------------------------
626 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
628 = do { -- Bring top level binders into scope
629 (rdr_env, imports) <- importsFromLocalDecls group ;
630 updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
631 tcg_imports = imports `plusImportAvails` tcg_imports gbl })
634 traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
635 failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations
637 -- Rename the source decls
638 (tcg_env, rn_decls) <- rnSrcDecls group ;
641 -- save the renamed syntax, if we want it
643 | Just grp <- tcg_rn_decls tcg_env
644 = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) }
648 -- Dump trace of renaming part
649 rnDump (ppr rn_decls) ;
651 return (tcg_env', rn_decls)
654 ------------------------------------------------
655 tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
656 tcTopSrcDecls boot_details
657 (HsGroup { hs_tyclds = tycl_decls,
658 hs_instds = inst_decls,
659 hs_fords = foreign_decls,
660 hs_defds = default_decls,
661 hs_ruleds = rule_decls,
662 hs_valds = val_binds })
663 = do { -- Type-check the type and class decls, and all imported decls
664 -- The latter come in via tycl_decls
665 traceTc (text "Tc2") ;
667 tcg_env <- checkNoErrs (tcTyAndClassDecls boot_details tycl_decls) ;
668 -- tcTyAndClassDecls recovers internally, but if anything gave rise to
669 -- an error we'd better stop now, to avoid a cascade
671 -- Make these type and class decls available to stuff slurped from interface files
672 writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
675 setGblEnv tcg_env $ do {
676 -- Source-language instances, including derivings,
677 -- and import the supporting declarations
678 traceTc (text "Tc3") ;
679 (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
680 setGblEnv tcg_env $ do {
682 -- Foreign import declarations next. No zonking necessary
683 -- here; we can tuck them straight into the global environment.
684 traceTc (text "Tc4") ;
685 (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
686 tcExtendGlobalValEnv fi_ids $ do {
688 -- Default declarations
689 traceTc (text "Tc4a") ;
690 default_tys <- tcDefaults default_decls ;
691 updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
693 -- Value declarations next
694 -- We also typecheck any extra binds that came out
695 -- of the "deriving" process (deriv_binds)
696 traceTc (text "Tc5") ;
697 (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ;
698 setLclTypeEnv lcl_env $ do {
700 -- Second pass over class and instance declarations,
701 traceTc (text "Tc6") ;
702 (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
703 showLIE (text "after instDecls2") ;
706 -- They need to be zonked, so we return them
707 traceTc (text "Tc7") ;
708 (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
711 rules <- tcRules rule_decls ;
714 traceTc (text "Tc7a") ;
715 tcg_env <- getGblEnv ;
716 let { all_binds = tc_val_binds `unionBags`
717 inst_binds `unionBags`
720 -- Extend the GblEnv with the (as yet un-zonked)
721 -- bindings, rules, foreign decls
722 tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
723 tcg_rules = tcg_rules tcg_env ++ rules,
724 tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
725 return (tcg_env', lcl_env)
730 %************************************************************************
734 %************************************************************************
738 = do { ghci_mode <- getGhciMode ;
739 tcg_env <- getGblEnv ;
741 let { main_mod = case mainModIs dflags of {
742 Just mod -> mkModule mod ;
744 main_fn = case mainFunIs dflags of {
745 Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
746 Nothing -> main_RDR_Unqual } } ;
748 check_main ghci_mode tcg_env main_mod main_fn
752 check_main ghci_mode tcg_env main_mod main_fn
753 -- If we are in module Main, check that 'main' is defined.
754 -- It may be imported from another module!
757 -- Blimey: a whole page of code to do this...
762 = addErrCtxt mainCtxt $
763 do { mb_main <- lookupSrcOcc_maybe main_fn
764 -- Check that 'main' is in scope
765 -- It might be imported from another module!
767 Nothing -> do { complain_no_main
770 { let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) }
771 -- :Main.main :: IO () = runMainIO main
773 ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
776 ; let { root_main_id = mkExportedLocalId rootMainName ty ;
777 main_bind = noLoc (VarBind root_main_id main_expr) }
779 ; return (tcg_env { tcg_binds = tcg_binds tcg_env
781 tcg_dus = tcg_dus tcg_env
782 `plusDU` usesOnly (unitFV main_name)
783 -- Record the use of 'main', so that we don't
784 -- complain about it being defined but not used
788 mod = tcg_mod tcg_env
790 complain_no_main | ghci_mode == Interactive = return ()
791 | otherwise = failWithTc noMainMsg
792 -- In interactive mode, don't worry about the absence of 'main'
793 -- In other modes, fail altogether, so that we don't go on
794 -- and complain a second time when processing the export list.
796 mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
797 noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
798 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
801 %*********************************************************
805 %*********************************************************
809 setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
810 setInteractiveContext hsc_env icxt thing_inside
812 -- Initialise the tcg_inst_env with instances
813 -- from all home modules. This mimics the more selective
814 -- call to hptInstances in tcRnModule
815 dfuns = hptInstances hsc_env (\mod -> True)
817 updGblEnv (\env -> env {
818 tcg_rdr_env = ic_rn_gbl_env icxt,
819 tcg_type_env = ic_type_env icxt,
820 tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $
822 updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt }) $
824 do { traceTc (text "setIC" <+> ppr (ic_type_env icxt))
831 -> InteractiveContext
833 -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
834 -- The returned [Name] is the same as the input except for
835 -- ExprStmt, in which case the returned [Name] is [itName]
837 -- The returned TypecheckedHsExpr is of type IO [ () ],
838 -- a list of the bound values, coerced to ().
840 tcRnStmt hsc_env ictxt rdr_stmt
841 = initTcPrintErrors hsc_env iNTERACTIVE $
842 setInteractiveContext hsc_env ictxt $ do {
844 -- Rename; use CmdLineMode because tcRnStmt is only used interactively
845 (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ;
846 traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
849 -- The real work is done here
850 (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
852 traceTc (text "tcs 1") ;
853 let { -- (a) Make all the bound ids "global" ids, now that
854 -- they're notionally top-level bindings. This is
855 -- important: otherwise when we come to compile an expression
856 -- using these ids later, the byte code generator will consider
857 -- the occurrences to be free rather than global.
859 -- (b) Tidy their types; this is important, because :info may
860 -- ask to look at them, and :info expects the things it looks
861 -- up to have tidy types
862 global_ids = map globaliseAndTidy bound_ids ;
864 -- Update the interactive context
865 rn_env = ic_rn_local_env ictxt ;
866 type_env = ic_type_env ictxt ;
868 bound_names = map idName global_ids ;
869 new_rn_env = extendLocalRdrEnv rn_env bound_names ;
871 -- Remove any shadowed bindings from the type_env;
872 -- they are inaccessible but might, I suppose, cause
873 -- a space leak if we leave them there
874 shadowed = [ n | name <- bound_names,
875 let rdr_name = mkRdrUnqual (nameOccName name),
876 Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
878 filtered_type_env = delListFromNameEnv type_env shadowed ;
879 new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
881 new_ic = ictxt { ic_rn_local_env = new_rn_env,
882 ic_type_env = new_type_env }
885 dumpOptTcRn Opt_D_dump_tc
886 (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
887 text "Typechecked expr" <+> ppr tc_expr]) ;
889 returnM (new_ic, bound_names, tc_expr)
892 globaliseAndTidy :: Id -> Id
894 -- Give the Id a Global Name, and tidy its type
895 = setIdType (globaliseId VanillaGlobal id) tidy_type
897 tidy_type = tidyTopType (idType id)
900 Here is the grand plan, implemented in tcUserStmt
902 What you type The IO [HValue] that hscStmt returns
903 ------------- ------------------------------------
904 let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...]
907 pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
910 expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it]
911 [NB: result not printed] bindings: [it]
913 expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it]
914 result showable) bindings: [it]
916 expr (of non-IO type,
917 result not showable) ==> error
921 ---------------------------
922 tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
923 tcUserStmt (L loc (ExprStmt expr _ _))
924 = newUnique `thenM` \ uniq ->
926 fresh_it = itName uniq
927 the_bind = noLoc $ FunBind (noLoc fresh_it) False
928 (mkMatchGroup [mkSimpleMatch [] expr])
930 tryTcLIE_ (do { -- Try this if the other fails
931 traceTc (text "tcs 1b") ;
932 tc_stmts (map (L loc) [
933 LetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
934 ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it))
935 (HsVar thenIOName) placeHolderType
937 (do { -- Try this first
938 traceTc (text "tcs 1a") ;
939 tc_stmts [L loc (BindStmt (nlVarPat fresh_it) expr
940 (HsVar bindIOName) noSyntaxExpr) ] })
942 tcUserStmt stmt = tc_stmts [stmt]
944 ---------------------------
945 tc_stmts :: [LStmt Name] -> TcM ([Id], LHsExpr Id)
947 = do { ioTyCon <- tcLookupTyCon ioTyConName ;
949 ret_ty = mkListTy unitTy ;
950 io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
952 names = map unLoc (collectLStmtsBinders stmts) ;
954 -- mk_return builds the expression
955 -- returnIO @ [()] [coerce () x, .., coerce () z]
957 -- Despite the inconvenience of building the type applications etc,
958 -- this *has* to be done in type-annotated post-typecheck form
959 -- because we are going to return a list of *polymorphic* values
960 -- coerced to type (). If we built a *source* stmt
961 -- return [coerce x, ..., coerce z]
962 -- then the type checker would instantiate x..z, and we wouldn't
963 -- get their *polymorphic* values. (And we'd get ambiguity errs
964 -- if they were overloaded, since they aren't applied to anything.)
965 mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
966 (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
967 mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
970 io_ty = mkTyConApp ioTyCon []
973 -- OK, we're ready to typecheck the stmts
974 traceTc (text "tcs 2") ;
975 ((ids, tc_expr), lie) <- getLIE $ do {
976 (tc_stmts, ids) <- tcStmts DoExpr (tcDoStmt io_ty io_ret_ty) stmts $
978 -- Look up the names right in the middle,
979 -- where they will all be in scope
980 ids <- mappM tcLookupId names ;
983 ret_id <- tcLookupId returnIOName ; -- return @ IO
984 return (ids, noLoc (HsDo DoExpr tc_stmts (mk_return ret_id ids) io_ret_ty))
987 -- Simplify the context right here, so that we fail
988 -- if there aren't enough instances. Notably, when we see
990 -- we use recoverTc_ to try it <- e
991 -- and then let it = e
992 -- It's the simplify step that rejects the first.
993 traceTc (text "tcs 3") ;
994 const_binds <- tcSimplifyInteractive lie ;
996 -- Build result expression and zonk it
997 let { expr = mkHsLet const_binds tc_expr } ;
998 zonked_expr <- zonkTopLExpr expr ;
999 zonked_ids <- zonkTopBndrs ids ;
1001 -- None of the Ids should be of unboxed type, because we
1002 -- cast them all to HValues in the end!
1003 mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
1005 return (zonked_ids, zonked_expr)
1008 bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
1009 nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
1013 tcRnExpr just finds the type of an expression
1017 -> InteractiveContext
1020 tcRnExpr hsc_env ictxt rdr_expr
1021 = initTcPrintErrors hsc_env iNTERACTIVE $
1022 setInteractiveContext hsc_env ictxt $ do {
1024 (rn_expr, fvs) <- rnLExpr rdr_expr ;
1027 -- Now typecheck the expression;
1028 -- it might have a rank-2 type (e.g. :t runST)
1029 ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ;
1030 ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ;
1031 tcSimplifyInteractive lie_top ;
1032 qtvs' <- mappM zonkQuantifiedTyVar qtvs ;
1034 let { all_expr_ty = mkForAllTys qtvs' $
1035 mkFunTys (map idType dict_ids) $
1037 zonkTcType all_expr_ty
1040 smpl_doc = ptext SLIT("main expression")
1043 tcRnType just finds the kind of a type
1047 -> InteractiveContext
1050 tcRnType hsc_env ictxt rdr_type
1051 = initTcPrintErrors hsc_env iNTERACTIVE $
1052 setInteractiveContext hsc_env ictxt $ do {
1054 rn_type <- rnLHsType doc rdr_type ;
1057 -- Now kind-check the type
1058 (ty', kind) <- kcHsType rn_type ;
1062 doc = ptext SLIT("In GHCi input")
1068 %************************************************************************
1070 More GHCi stuff, to do with browsing and getting info
1072 %************************************************************************
1076 mkExportEnv :: HscEnv -> [Module] -- Expose these modules' exports only
1078 mkExportEnv hsc_env exports
1079 = do { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $
1080 mappM getModuleExports exports
1082 Just envs -> return (foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs)
1083 Nothing -> return emptyGlobalRdrEnv
1084 -- Some error; initTc will have printed it
1087 getModuleExports :: Module -> TcM GlobalRdrEnv
1088 getModuleExports mod
1089 = do { iface <- load_iface mod
1090 ; loadOrphanModules (dep_orphs (mi_deps iface))
1091 -- Load any orphan-module interfaces,
1092 -- so their instances are visible
1093 ; names <- ifaceExportNames (mi_exports iface)
1094 ; let { gres = [ GRE { gre_name = name, gre_prov = vanillaProv mod }
1095 | name <- nameSetToList names ] }
1096 ; returnM (mkGlobalRdrEnv gres) }
1098 vanillaProv :: Module -> Provenance
1099 -- We're building a GlobalRdrEnv as if the user imported
1100 -- all the specified modules into the global interactive module
1101 vanillaProv mod = Imported [ImportSpec mod mod False
1102 (srcLocSpan interactiveSrcLoc)] False
1108 -> Module -- Module to inspect
1109 -> Bool -- Grab just the exports, or the whole toplev
1110 -> IO (Maybe [IfaceDecl])
1112 getModuleContents hsc_env mod exports_only
1113 = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only)
1115 get_mod_contents exports_only
1116 | not exports_only -- We want the whole top-level type env
1117 -- so it had better be a home module
1118 = do { hpt <- getHpt
1119 ; case lookupModuleEnv hpt mod of
1120 Just mod_info -> return (map (toIfaceDecl ext_nm) $
1123 md_types (hm_details mod_info))
1124 Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod)))
1125 -- This is a system error; the module should be in the HPT
1128 | otherwise -- Want the exports only
1129 = do { iface <- load_iface mod
1130 ; mappM get_decl [ (mod,avail) | (mod, avails) <- mi_exports iface
1134 get_decl (mod, avail)
1135 = do { main_name <- lookupOrig mod (availName avail)
1136 ; thing <- tcLookupGlobal main_name
1137 ; return (filter_decl (availNames avail) (toIfaceDecl ext_nm thing)) }
1139 ext_nm = interactiveExtNameFun (icPrintUnqual (hsc_IC hsc_env))
1141 ---------------------
1142 filter_decl occs decl@(IfaceClass {ifSigs = sigs})
1143 = decl { ifSigs = filter (keep_sig occs) sigs }
1144 filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon cons})
1145 = decl { ifCons = IfDataTyCon (filter (keep_con occs) cons) }
1146 filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
1147 | keep_con occs con = decl
1148 | otherwise = decl {ifCons = IfAbstractTyCon} -- Hmm?
1149 filter_decl occs decl
1152 keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs
1153 keep_con occs con = ifConOcc con `elem` occs
1155 wantToSee (AnId id) = not (isImplicitId id)
1156 wantToSee (ADataCon _) = False -- They'll come via their TyCon
1159 ---------------------
1160 load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
1162 doc = ptext SLIT("context for compiling statements")
1164 ---------------------
1165 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
1166 <+> quotes (ppr mod)
1170 type GetInfoResult = (String, IfaceDecl, Fixity, SrcLoc,
1171 [(IfaceType,SrcLoc)] -- Instances
1174 tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name])
1176 tcRnLookupRdrName hsc_env rdr_name
1177 = initTcPrintErrors hsc_env iNTERACTIVE $
1178 setInteractiveContext hsc_env (hsc_IC hsc_env) $
1179 lookup_rdr_name rdr_name
1182 lookup_rdr_name rdr_name = do {
1183 -- If the identifier is a constructor (begins with an
1184 -- upper-case letter), then we need to consider both
1185 -- constructor and type class identifiers.
1186 let { rdr_names = dataTcOccs rdr_name } ;
1188 -- results :: [(Messages, Maybe Name)]
1189 results <- mapM (tryTc . lookupOccRn) rdr_names ;
1191 traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
1192 -- The successful lookups will be (Just name)
1193 let { (warns_s, good_names) = unzip [ (msgs, name)
1194 | (msgs, Just name) <- results] ;
1195 errs_s = [msgs | (msgs, Nothing) <- results] } ;
1197 -- Fail if nothing good happened, else add warnings
1198 if null good_names then
1199 -- No lookup succeeded, so
1200 -- pick the first error message and report it
1201 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
1202 -- while the other is "X is not in scope",
1203 -- we definitely want the former; but we might pick the latter
1204 do { addMessages (head errs_s) ; failM }
1205 else -- Add deprecation warnings
1206 mapM_ addMessages warns_s ;
1212 tcRnGetInfo :: HscEnv
1213 -> InteractiveContext
1215 -> IO (Maybe [GetInfoResult])
1217 -- Used to implemnent :info in GHCi
1219 -- Look up a RdrName and return all the TyThings it might be
1220 -- A capitalised RdrName is given to us in the DataName namespace,
1221 -- but we want to treat it as *both* a data constructor
1222 -- *and* as a type or class constructor;
1223 -- hence the call to dataTcOccs, and we return up to two results
1224 tcRnGetInfo hsc_env ictxt rdr_name
1225 = initTcPrintErrors hsc_env iNTERACTIVE $
1226 setInteractiveContext hsc_env ictxt $ do {
1228 good_names <- lookup_rdr_name rdr_name ;
1230 -- And lookup up the entities, avoiding duplicates, which arise
1231 -- because constructors and record selectors are represented by
1232 -- their parent declaration
1233 let { do_one name = do { thing <- tcLookupGlobal name
1234 ; fixity <- lookupFixityRn name
1235 ; ispecs <- lookupInsts ext_nm thing
1236 ; return (str, toIfaceDecl ext_nm thing, fixity,
1238 [(toIfaceType ext_nm (idType dfun), getSrcLoc dfun)
1239 | dfun <- map instanceDFunId ispecs ]
1242 -- str is the the naked occurrence name
1243 -- after stripping off qualification and parens (+)
1244 str = occNameUserString (nameOccName name)
1247 -- For the SrcLoc, the 'thing' has better info than
1248 -- the 'name' because getting the former forced the
1249 -- declaration to be loaded into the cache
1251 results <- mapM do_one good_names ;
1252 return (fst (removeDups cmp results))
1255 cmp (_,d1,_,_,_) (_,d2,_,_,_) = ifName d1 `compare` ifName d2
1256 ext_nm = interactiveExtNameFun (icPrintUnqual ictxt)
1259 lookupInsts :: (Name -> IfaceExtName) -> TyThing -> TcM [Instance]
1260 -- Filter the instances by the ones whose tycons (or clases resp)
1261 -- are in scope unqualified. Otherwise we list a whole lot too many!
1262 lookupInsts ext_nm (AClass cls)
1263 = do { loadImportedInsts cls [] -- [] means load all instances for cls
1264 ; inst_envs <- tcGetInstEnvs
1266 | ispec <- classInstances inst_envs cls
1267 , let (_, tycons) = ifaceInstGates (ifInstHead (instanceToIfaceInst ext_nm ispec))
1268 -- Rather an indirect/inefficient test, but there we go
1269 , all print_tycon_unqual tycons ] }
1271 print_tycon_unqual (IfaceTc nm) = isLocalIfaceExtName nm
1272 print_tycon_unqual other = True -- Int etc
1275 lookupInsts ext_nm (ATyCon tc)
1276 = do { eps <- getEps -- Load all instances for all classes that are
1277 -- in the type environment (which are all the ones
1278 -- we've seen in any interface file so far)
1279 ; mapM_ (\c -> loadImportedInsts c [])
1280 (typeEnvClasses (eps_PTE eps))
1281 ; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all
1283 | (_, _, dfun) <- instEnvElts home_ie ++ instEnvElts pkg_ie
1285 , let (cls, _) = ifaceInstGates (ifInstHead (instanceToIfaceInst ext_nm dfun))
1286 , isLocalIfaceExtName cls ] }
1288 relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType (instanceDFunId df))
1289 tc_name = tyConName tc
1291 lookupInsts ext_nm other = return []
1294 toIfaceDecl :: (Name -> IfaceExtName) -> TyThing -> IfaceDecl
1295 toIfaceDecl ext_nm thing
1296 = tyThingToIfaceDecl True -- Discard IdInfo
1297 emptyNameSet -- Show data cons
1298 ext_nm (munge thing)
1300 -- munge transforms a thing to its "parent" thing
1301 munge (ADataCon dc) = ATyCon (dataConTyCon dc)
1302 munge (AnId id) = case globalIdDetails id of
1303 RecordSelId tc lbl -> ATyCon tc
1304 ClassOpId cls -> AClass cls
1306 munge other_thing = other_thing
1310 %************************************************************************
1314 %************************************************************************
1317 rnDump :: SDoc -> TcRn ()
1318 -- Dump, with a banner, if -ddump-rn
1319 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1321 tcDump :: TcGblEnv -> TcRn ()
1323 = do { dflags <- getDOpts ;
1325 -- Dump short output if -ddump-types or -ddump-tc
1326 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1327 (dumpTcRn short_dump) ;
1329 -- Dump bindings if -ddump-tc
1330 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1333 short_dump = pprTcGblEnv env
1334 full_dump = pprLHsBinds (tcg_binds env)
1335 -- NB: foreign x-d's have undefined's in their types;
1336 -- hence can't show the tc_fords
1339 = do { dflags <- getDOpts ;
1340 ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1341 (dumpTcRn (pprModGuts mod_guts)) ;
1343 -- Dump bindings if -ddump-tc
1344 dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1346 full_dump = pprCoreBindings (mg_binds mod_guts)
1348 -- It's unpleasant having both pprModGuts and pprModDetails here
1349 pprTcGblEnv :: TcGblEnv -> SDoc
1350 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1351 tcg_insts = dfun_ids,
1353 tcg_imports = imports })
1354 = vcat [ ppr_types dfun_ids type_env
1355 , ppr_insts dfun_ids
1356 , vcat (map ppr rules)
1357 , ppr_gen_tycons (typeEnvTyCons type_env)
1358 , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports))
1359 , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1361 pprModGuts :: ModGuts -> SDoc
1362 pprModGuts (ModGuts { mg_types = type_env,
1364 = vcat [ ppr_types [] type_env,
1368 ppr_types :: [Instance] -> TypeEnv -> SDoc
1369 ppr_types ispecs type_env
1370 = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1372 dfun_ids = map instanceDFunId ispecs
1373 ids = [id | id <- typeEnvIds type_env, want_sig id]
1374 want_sig id | opt_PprStyle_Debug = True
1375 | otherwise = isLocalId id &&
1376 isExternalName (idName id) &&
1377 not (id `elem` dfun_ids)
1378 -- isLocalId ignores data constructors, records selectors etc.
1379 -- The isExternalName ignores local dictionary and method bindings
1380 -- that the type checker has invented. Top-level user-defined things
1381 -- have External names.
1383 ppr_insts :: [Instance] -> SDoc
1384 ppr_insts [] = empty
1385 ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs)
1387 ppr_sigs :: [Var] -> SDoc
1389 -- Print type signatures; sort by OccName
1390 = vcat (map ppr_sig (sortLe le_sig ids))
1392 le_sig id1 id2 = getOccName id1 <= getOccName id2
1393 ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
1395 ppr_rules :: [CoreRule] -> SDoc
1396 ppr_rules [] = empty
1397 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1398 nest 4 (pprRules rs),
1401 ppr_gen_tycons [] = empty
1402 ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"),
1403 nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]