ghc/compiler/typecheck/TcRnDriver.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[TcModule]{Typechecking a whole module}
   5
   6 \begin{code}
   7 module TcRnDriver (
   8 #ifdef GHCI
   9         mkExportEnv, getModuleContents, tcRnStmt,
  10         tcRnGetInfo, tcRnExpr, tcRnType,
  11 #endif
  12         tcRnModule,
  13         tcTopSrcDecls,
  14         tcRnExtCore
  15     ) where
  16
  17 #include "HsVersions.h"
  18
  19 #ifdef GHCI
  20 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
  21 #endif
  22
  23 import CmdLineOpts      ( DynFlag(..), opt_PprStyle_Debug, dopt )
  24 import DriverState      ( v_MainModIs, v_MainFunIs )
  25 import HsSyn            ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, SpliceDecl(..), HsBind(..),
  26                           nlHsApp, nlHsVar, pprLHsBinds )
  27 import RdrHsSyn         ( findSplice )
  28
  29 import PrelNames        ( runIOName, rootMainName, mAIN_Name,
  30                           main_RDR_Unqual )
  31 import RdrName          ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv,
  32                           plusGlobalRdrEnv )
  33 import TcHsSyn          ( zonkTopDecls )
  34 import TcExpr           ( tcInferRho )
  35 import TcRnMonad
  36 import TcType           ( tidyTopType, isUnLiftedType )
  37 import Inst             ( showLIE )
  38 import TcBinds          ( tcTopBinds )
  39 import TcDefaults       ( tcDefaults )
  40 import TcEnv            ( tcExtendGlobalValEnv )
  41 import TcRules          ( tcRules )
  42 import TcForeign        ( tcForeignImports, tcForeignExports )
  43 import TcInstDcls       ( tcInstDecls1, tcInstDecls2 )
  44 import TcIface          ( tcExtCoreBindings, loadImportedInsts )
  45 import TcSimplify       ( tcSimplifyTop )
  46 import TcTyClsDecls     ( tcTyAndClassDecls )
  47 import LoadIface        ( loadOrphanModules )
  48 import RnNames          ( importsFromLocalDecls, rnImports, exportsFromAvail,
  49                           reportUnusedNames, reportDeprecations )
  50 import RnEnv            ( lookupSrcOcc_maybe )
  51 import RnSource         ( rnSrcDecls, rnTyClDecls, checkModDeprec )
  52 import PprCore          ( pprIdRules, pprCoreBindings )
  53 import CoreSyn          ( IdCoreRule, bindersOfBinds )
  54 import ErrUtils         ( Messages, mkDumpDoc, showPass )
  55 import Id               ( mkExportedLocalId, isLocalId, idName, idType )
  56 import Var              ( Var )
  57 import Module           ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts )
  58 import OccName          ( mkVarOcc )
  59 import Name             ( Name, isExternalName, getSrcLoc, getOccName, nameSrcLoc )
  60 import NameSet
  61 import TyCon            ( tyConHasGenerics )
  62 import SrcLoc           ( SrcLoc, srcLocSpan, Located(..), noLoc )
  63 import Outputable
  64 import HscTypes         ( ModGuts(..), HscEnv(..), ExternalPackageState( eps_is_boot ),
  65                           GhciMode(..), isOneShot, Dependencies(..), noDependencies,
  66                           Deprecs( NoDeprecs ), plusDeprecs,
  67                           ForeignStubs(NoStubs), TypeEnv,
  68                           extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
  69                           emptyFixityEnv
  70                         )
  71 #ifdef GHCI
  72 import HsSyn            ( HsStmtContext(..), Stmt(..), HsExpr(..), HsBindGroup(..),
  73                           LStmt, LHsExpr, LHsType,
  74                           collectStmtsBinders, mkSimpleMatch, placeHolderType,
  75                           nlLetStmt, nlExprStmt, nlBindStmt, nlResultStmt, nlVarPat )
  76 import RdrName          ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
  77                           Provenance(..), ImportSpec(..),
  78                           lookupLocalRdrEnv, extendLocalRdrEnv )
  79 import RnSource         ( addTcgDUs )
  80 import TcHsSyn          ( mkHsLet, zonkTopLExpr, zonkTopBndrs )
  81 import TcHsType         ( kcHsType )
  82 import TcExpr           ( tcCheckRho )
  83 import TcMType          ( zonkTcType )
  84 import TcMatches        ( tcStmtsAndThen, TcStmtCtxt(..) )
  85 import TcSimplify       ( tcSimplifyInteractive, tcSimplifyInfer )
  86 import TcType           ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, tyClsNamesOfDFunHead )
  87 import TcEnv            ( tcLookupTyCon, tcLookupId, tcLookupGlobal )
  88 import RnTypes          ( rnLHsType )
  89 import Inst             ( tcStdSyntaxName, tcGetInstEnvs )
  90 import InstEnv          ( DFunId, classInstances, instEnvElts )
  91 import RnExpr           ( rnStmts, rnLExpr )
  92 import RnNames          ( exportsToAvails )
  93 import LoadIface        ( loadSrcInterface )
  94 import IfaceSyn         ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..),
  95                           IfaceExtName(..), IfaceConDecls(..), IfaceInst(..),
  96                           tyThingToIfaceDecl, dfunToIfaceInst )
  97 import RnEnv            ( lookupOccRn, dataTcOccs, lookupFixityRn )
  98 import Id               ( Id, isImplicitId, globalIdDetails )
  99 import FieldLabel       ( fieldLabelTyCon )
 100 import MkId             ( unsafeCoerceId )
 101 import DataCon          ( dataConTyCon )
 102 import TyCon            ( tyConName )
 103 import TysWiredIn       ( mkListTy, unitTy )
 104 import IdInfo           ( GlobalIdDetails(..) )
 105 import SrcLoc           ( interactiveSrcLoc, unLoc )
 106 import Kind             ( Kind )
 107 import Var              ( globaliseId )
 108 import Name             ( nameOccName, nameModuleName )
 109 import NameEnv          ( delListFromNameEnv )
 110 import PrelNames        ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName )
 111 import Module           ( ModuleName, lookupModuleEnvByName )
 112 import HscTypes         ( InteractiveContext(..), ExternalPackageState( eps_PTE ),
 113                           HomeModInfo(..), typeEnvElts, typeEnvClasses,
 114                           TyThing(..), availName, availNames, icPrintUnqual,
 115                           ModIface(..), ModDetails(..) )
 116 import BasicTypes       ( RecFlag(..), Fixity )
 117 import Bag              ( unitBag )
 118 import ListSetOps       ( removeDups )
 119 import Panic            ( ghcError, GhcException(..) )
 120 #endif
 121
 122 import FastString       ( mkFastString )
 123 import Util             ( sortLe )
 124 import Bag              ( unionBags, snocBag )
 125
 126 import Maybe            ( isJust )
 127 \end{code}
 128
 129
 130
 131 %************************************************************************
 132 %*                                                                      *
 133         Typecheck and rename a module
 134 %*                                                                      *
 135 %************************************************************************
 136
 137
 138 \begin{code}
 139 tcRnModule :: HscEnv
 140            -> Located (HsModule RdrName)
 141            -> IO (Messages, Maybe TcGblEnv)
 142
 143 tcRnModule hsc_env (L loc (HsModule maybe_mod exports
 144                                 import_decls local_decls mod_deprec))
 145  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 146
 147    let { this_mod = case maybe_mod of
 148                         Nothing  -> mkHomeModule mAIN_Name
 149                                         -- 'module M where' is omitted
 150                         Just (L _ mod) -> mod } ;
 151                                         -- The normal case
 152
 153    initTc hsc_env this_mod $
 154    addSrcSpan loc $
 155    do {         -- Deal with imports; sets tcg_rdr_env, tcg_imports
 156         (rdr_env, imports) <- rnImports import_decls ;
 157
 158                 -- In one-shot mode, record boot-file info in the EPS
 159         ifM (isOneShot (hsc_mode hsc_env)) $
 160             updateEps_ (\eps -> eps { eps_is_boot = imp_dep_mods imports }) ;
 161
 162                 -- Update the gbl env
 163         updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
 164                                    tcg_imports = tcg_imports gbl `plusImportAvails` imports })
 165                      $ do {
 166         traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
 167                 -- Fail if there are any errors so far
 168                 -- The error printing (if needed) takes advantage
 169                 -- of the tcg_env we have now set
 170         failIfErrsM ;
 171
 172                 -- Load any orphan-module interfaces, so that
 173                 -- their rules and instance decls will be found
 174         loadOrphanModules (imp_orphs imports) ;
 175
 176         traceRn (text "rn1a") ;
 177                 -- Rename and type check the declarations
 178         tcg_env <- tcRnSrcDecls local_decls ;
 179         setGblEnv tcg_env               $ do {
 180
 181         traceRn (text "rn3") ;
 182
 183                 -- Report the use of any deprecated things
 184                 -- We do this before processsing the export list so
 185                 -- that we don't bleat about re-exporting a deprecated
 186                 -- thing (especially via 'module Foo' export item)
 187                 -- Only uses in the body of the module are complained about
 188         reportDeprecations tcg_env ;
 189
 190                 -- Process the export list
 191         exports <- exportsFromAvail (isJust maybe_mod) exports ;
 192
 193 {-      Jan 04: I don't think this is necessary any more; usage info is derived from tcg_dus
 194                 -- Get any supporting decls for the exports that have not already
 195                 -- been sucked in for the declarations in the body of the module.
 196                 -- (This can happen if something is imported only to be re-exported.)
 197                 --
 198                 -- Importing these supporting declarations is required
 199                 --      *only* to gether usage information
 200                 --      (see comments with MkIface.mkImportInfo for why)
 201                 -- We don't need the results, but sucking them in may side-effect
 202                 -- the ExternalPackageState, apart from recording usage
 203         mappM (tcLookupGlobal . availName) export_avails ;
 204 -}
 205
 206                 -- Check whether the entire module is deprecated
 207                 -- This happens only once per module
 208         let { mod_deprecs = checkModDeprec mod_deprec } ;
 209
 210                 -- Add exports and deprecations to envt
 211         let { final_env  = tcg_env { tcg_exports = exports,
 212                                      tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports,
 213                                      tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
 214                                                    mod_deprecs }
 215                 -- A module deprecation over-rides the earlier ones
 216              } ;
 217
 218                 -- Report unused names
 219         reportUnusedNames final_env ;
 220
 221                 -- Dump output and return
 222         tcDump final_env ;
 223         return final_env
 224     }}}}
 225 \end{code}
 226
 227
 228 %************************************************************************
 229 %*                                                                      *
 230         Type-checking external-core modules
 231 %*                                                                      *
 232 %************************************************************************
 233
 234 \begin{code}
 235 tcRnExtCore :: HscEnv
 236             -> HsExtCore RdrName
 237             -> IO (Messages, Maybe ModGuts)
 238         -- Nothing => some error occurred
 239
 240 tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 241         -- The decls are IfaceDecls; all names are original names
 242  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 243
 244    initTc hsc_env this_mod $ do {
 245
 246    let { ldecls  = map noLoc decls } ;
 247
 248         -- Deal with the type declarations; first bring their stuff
 249         -- into scope, then rname them, then type check them
 250    (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ;
 251
 252    updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
 253                             tcg_imports = imports `plusImportAvails` tcg_imports gbl })
 254                   $ do {
 255
 256    rn_decls <- rnTyClDecls ldecls ;
 257    failIfErrsM ;
 258
 259         -- Dump trace of renaming part
 260    rnDump (ppr rn_decls) ;
 261
 262         -- Typecheck them all together so that
 263         -- any mutually recursive types are done right
 264    tcg_env <- checkNoErrs (tcTyAndClassDecls rn_decls) ;
 265         -- Make the new type env available to stuff slurped from interface files
 266
 267    setGblEnv tcg_env $ do {
 268
 269         -- Now the core bindings
 270    core_binds <- initIfaceExtCore (tcExtCoreBindings this_mod src_binds) ;
 271
 272         -- Wrap up
 273    let {
 274         bndrs      = bindersOfBinds core_binds ;
 275         my_exports = mkNameSet (map idName bndrs) ;
 276                 -- ToDo: export the data types also?
 277
 278         final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
 279
 280         mod_guts = ModGuts {    mg_module   = this_mod,
 281                                 mg_usages   = [],               -- ToDo: compute usage
 282                                 mg_dir_imps = [],               -- ??
 283                                 mg_deps     = noDependencies,   -- ??
 284                                 mg_exports  = my_exports,
 285                                 mg_types    = final_type_env,
 286                                 mg_insts    = tcg_insts tcg_env,
 287                                 mg_rules    = [],
 288                                 mg_binds    = core_binds,
 289
 290                                 -- Stubs
 291                                 mg_rdr_env  = emptyGlobalRdrEnv,
 292                                 mg_fix_env  = emptyFixityEnv,
 293                                 mg_deprecs  = NoDeprecs,
 294                                 mg_foreign  = NoStubs
 295                     } } ;
 296
 297    tcCoreDump mod_guts ;
 298
 299    return mod_guts
 300    }}}}
 301
 302 mkFakeGroup decls -- Rather clumsy; lots of unused fields
 303   = HsGroup {   hs_tyclds = decls,      -- This is the one we want
 304                 hs_valds = [], hs_fords = [],
 305                 hs_instds = [], hs_fixds = [], hs_depds = [],
 306                 hs_ruleds = [], hs_defds = [] }
 307 \end{code}
 308
 309
 310 %************************************************************************
 311 %*                                                                      *
 312         Type-checking the top level of a module
 313 %*                                                                      *
 314 %************************************************************************
 315
 316 \begin{code}
 317 tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
 318         -- Returns the variables free in the decls
 319         -- Reason: solely to report unused imports and bindings
 320 tcRnSrcDecls decls
 321  = do {         -- Do all the declarations
 322         (tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ;
 323
 324              -- tcSimplifyTop deals with constant or ambiguous InstIds.
 325              -- How could there be ambiguous ones?  They can only arise if a
 326              -- top-level decl falls under the monomorphism
 327              -- restriction, and no subsequent decl instantiates its
 328              -- type.  (Usually, ambiguous type variables are resolved
 329              -- during the generalisation step.)
 330         traceTc (text "Tc8") ;
 331         inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
 332                 -- Setting the global env exposes the instances to tcSimplifyTop
 333                 -- Setting the local env exposes the local Ids to tcSimplifyTop,
 334                 -- so that we get better error messages (monomorphism restriction)
 335
 336             -- Backsubstitution.  This must be done last.
 337             -- Even tcSimplifyTop may do some unification.
 338         traceTc (text "Tc9") ;
 339         let { (tcg_env, _) = tc_envs ;
 340               TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
 341                          tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
 342
 343         (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
 344                                                            rules fords ;
 345
 346         let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
 347
 348         -- Make the new type env available to stuff slurped from interface files
 349         writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
 350
 351         return (tcg_env { tcg_type_env = final_type_env,
 352                           tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' })
 353    }
 354
 355 tc_rn_src_decls :: [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
 356 -- Loops around dealing with each top level inter-splice group
 357 -- in turn, until it's dealt with the entire module
 358 tc_rn_src_decls ds
 359  = do { let { (first_group, group_tail) = findSplice ds } ;
 360                 -- If ds is [] we get ([], Nothing)
 361
 362         -- Type check the decls up to, but not including, the first splice
 363         tc_envs@(tcg_env,tcl_env) <- tcRnGroup first_group ;
 364
 365         -- Bale out if errors; for example, error recovery when checking
 366         -- the RHS of 'main' can mean that 'main' is not in the envt for
 367         -- the subsequent checkMain test
 368         failIfErrsM ;
 369
 370         setEnvs tc_envs $
 371
 372         -- If there is no splice, we're nearly done
 373         case group_tail of {
 374            Nothing -> do {      -- Last thing: check for `main'
 375                            tcg_env <- checkMain ;
 376                            return (tcg_env, tcl_env)
 377                       } ;
 378
 379         -- If there's a splice, we must carry on
 380            Just (SpliceDecl splice_expr, rest_ds) -> do {
 381 #ifndef GHCI
 382         failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
 383 #else
 384
 385         -- Rename the splice expression, and get its supporting decls
 386         (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
 387         failIfErrsM ;   -- Don't typecheck if renaming failed
 388
 389         -- Execute the splice
 390         spliced_decls <- tcSpliceDecls rn_splice_expr ;
 391
 392         -- Glue them on the front of the remaining decls and loop
 393         setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
 394         tc_rn_src_decls (spliced_decls ++ rest_ds)
 395 #endif /* GHCI */
 396     }}}
 397 \end{code}
 398
 399
 400 %************************************************************************
 401 %*                                                                      *
 402         Type-checking the top level of a module
 403 %*                                                                      *
 404 %************************************************************************
 405
 406 tcRnGroup takes a bunch of top-level source-code declarations, and
 407  * renames them
 408  * gets supporting declarations from interface files
 409  * typechecks them
 410  * zonks them
 411  * and augments the TcGblEnv with the results
 412
 413 In Template Haskell it may be called repeatedly for each group of
 414 declarations.  It expects there to be an incoming TcGblEnv in the
 415 monad; it augments it and returns the new TcGblEnv.
 416
 417 \begin{code}
 418 tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
 419         -- Returns the variables free in the decls, for unused-binding reporting
 420 tcRnGroup decls
 421  = do {         -- Rename the declarations
 422         (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
 423         setGblEnv tcg_env $ do {
 424
 425                 -- Typecheck the declarations
 426         tcTopSrcDecls rn_decls
 427   }}
 428
 429 ------------------------------------------------
 430 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
 431 rnTopSrcDecls group
 432  = do {         -- Bring top level binders into scope
 433         (rdr_env, imports) <- importsFromLocalDecls group ;
 434         updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
 435                                  tcg_imports = imports `plusImportAvails` tcg_imports gbl })
 436                   $ do {
 437
 438         traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
 439         failIfErrsM ;   -- No point in continuing if (say) we have duplicate declarations
 440
 441                 -- Rename the source decls
 442         (tcg_env, rn_decls) <- rnSrcDecls group ;
 443         failIfErrsM ;
 444
 445                 -- Dump trace of renaming part
 446         rnDump (ppr rn_decls) ;
 447
 448         return (tcg_env, rn_decls)
 449    }}
 450
 451 ------------------------------------------------
 452 tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
 453 tcTopSrcDecls
 454         (HsGroup { hs_tyclds = tycl_decls,
 455                    hs_instds = inst_decls,
 456                    hs_fords  = foreign_decls,
 457                    hs_defds  = default_decls,
 458                    hs_ruleds = rule_decls,
 459                    hs_valds  = val_binds })
 460  = do {         -- Type-check the type and class decls, and all imported decls
 461                 -- The latter come in via tycl_decls
 462         traceTc (text "Tc2") ;
 463
 464         tcg_env <- checkNoErrs (tcTyAndClassDecls tycl_decls) ;
 465         -- tcTyAndClassDecls recovers internally, but if anything gave rise to
 466         -- an error we'd better stop now, to avoid a cascade
 467
 468         -- Make these type and class decls available to stuff slurped from interface files
 469         writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
 470
 471
 472         setGblEnv tcg_env       $ do {
 473                 -- Source-language instances, including derivings,
 474                 -- and import the supporting declarations
 475         traceTc (text "Tc3") ;
 476         (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
 477         setGblEnv tcg_env       $ do {
 478
 479                 -- Foreign import declarations next.  No zonking necessary
 480                 -- here; we can tuck them straight into the global environment.
 481         traceTc (text "Tc4") ;
 482         (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
 483         tcExtendGlobalValEnv fi_ids     $ do {
 484
 485                 -- Default declarations
 486         traceTc (text "Tc4a") ;
 487         default_tys <- tcDefaults default_decls ;
 488         updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
 489
 490                 -- Value declarations next
 491                 -- We also typecheck any extra binds that came out
 492                 -- of the "deriving" process (deriv_binds)
 493         traceTc (text "Tc5") ;
 494         (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ;
 495         setLclTypeEnv lcl_env   $ do {
 496
 497                 -- Second pass over class and instance declarations,
 498         traceTc (text "Tc6") ;
 499         (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
 500         showLIE (text "after instDecls2") ;
 501
 502                 -- Foreign exports
 503                 -- They need to be zonked, so we return them
 504         traceTc (text "Tc7") ;
 505         (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
 506
 507                 -- Rules
 508         rules <- tcRules rule_decls ;
 509
 510                 -- Wrap up
 511         traceTc (text "Tc7a") ;
 512         tcg_env <- getGblEnv ;
 513         let { all_binds = tc_val_binds   `unionBags`
 514                           inst_binds     `unionBags`
 515                           foe_binds  ;
 516
 517                 -- Extend the GblEnv with the (as yet un-zonked)
 518                 -- bindings, rules, foreign decls
 519               tcg_env' = tcg_env {  tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
 520                                     tcg_rules = tcg_rules tcg_env ++ rules,
 521                                     tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
 522         return (tcg_env', lcl_env)
 523     }}}}}}
 524 \end{code}
 525
 526
 527 %************************************************************************
 528 %*                                                                      *
 529         Checking for 'main'
 530 %*                                                                      *
 531 %************************************************************************
 532
 533 \begin{code}
 534 checkMain
 535   = do { ghci_mode <- getGhciMode ;
 536          tcg_env   <- getGblEnv ;
 537
 538          mb_main_mod <- readMutVar v_MainModIs ;
 539          mb_main_fn  <- readMutVar v_MainFunIs ;
 540          let { main_mod = case mb_main_mod of {
 541                                 Just mod -> mkModuleName mod ;
 542                                 Nothing  -> mAIN_Name } ;
 543                main_fn  = case mb_main_fn of {
 544                                 Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
 545                                 Nothing -> main_RDR_Unqual } } ;
 546
 547          check_main ghci_mode tcg_env main_mod main_fn
 548     }
 549
 550
 551 check_main ghci_mode tcg_env main_mod main_fn
 552      -- If we are in module Main, check that 'main' is defined.
 553      -- It may be imported from another module!
 554      --
 555      -- ToDo: We have to return the main_name separately, because it's a
 556      -- bona fide 'use', and should be recorded as such, but the others
 557      -- aren't
 558      --
 559      -- Blimey: a whole page of code to do this...
 560  | mod_name /= main_mod
 561  = return tcg_env
 562
 563  | otherwise
 564  = addErrCtxt mainCtxt                  $
 565    do   { mb_main <- lookupSrcOcc_maybe main_fn
 566                 -- Check that 'main' is in scope
 567                 -- It might be imported from another module!
 568         ; case mb_main of {
 569              Nothing -> do { complain_no_main
 570                            ; return tcg_env } ;
 571              Just main_name -> do
 572         { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) }
 573                         -- :Main.main :: IO () = runIO main
 574
 575         ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $
 576                              tcInferRho rhs
 577
 578         ; let { root_main_id = mkExportedLocalId rootMainName ty ;
 579                 main_bind    = noLoc (VarBind root_main_id main_expr) }
 580
 581         ; return (tcg_env { tcg_binds = tcg_binds tcg_env
 582                                         `snocBag` main_bind,
 583                             tcg_dus   = tcg_dus tcg_env
 584                                         `plusDU` usesOnly (unitFV main_name)
 585                  })
 586     }}}
 587   where
 588     mod_name = moduleName (tcg_mod tcg_env)
 589
 590     complain_no_main | ghci_mode == Interactive = return ()
 591                      | otherwise                = failWithTc noMainMsg
 592         -- In interactive mode, don't worry about the absence of 'main'
 593         -- In other modes, fail altogether, so that we don't go on
 594         -- and complain a second time when processing the export list.
 595
 596     mainCtxt  = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
 597     noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
 598                 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
 599 \end{code}
 600
 601
 602 %*********************************************************
 603 %*                                                       *
 604                 GHCi stuff
 605 %*                                                       *
 606 %*********************************************************
 607
 608 \begin{code}
 609 #ifdef GHCI
 610 setInteractiveContext :: InteractiveContext -> TcRn a -> TcRn a
 611 setInteractiveContext icxt thing_inside
 612   = traceTc (text "setIC" <+> ppr (ic_type_env icxt))   `thenM_`
 613     (updGblEnv (\env -> env {tcg_rdr_env  = ic_rn_gbl_env icxt,
 614                              tcg_type_env = ic_type_env   icxt}) $
 615      updLclEnv (\env -> env {tcl_rdr = ic_rn_local_env icxt})   $
 616                thing_inside)
 617 \end{code}
 618
 619
 620 \begin{code}
 621 tcRnStmt :: HscEnv
 622          -> InteractiveContext
 623          -> LStmt RdrName
 624          -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
 625                 -- The returned [Name] is the same as the input except for
 626                 -- ExprStmt, in which case the returned [Name] is [itName]
 627                 --
 628                 -- The returned TypecheckedHsExpr is of type IO [ () ],
 629                 -- a list of the bound values, coerced to ().
 630
 631 tcRnStmt hsc_env ictxt rdr_stmt
 632   = initTcPrintErrors hsc_env iNTERACTIVE $
 633     setInteractiveContext ictxt $ do {
 634
 635     -- Rename; use CmdLineMode because tcRnStmt is only used interactively
 636     ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ;
 637     traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
 638     failIfErrsM ;
 639
 640     -- The real work is done here
 641     (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
 642
 643     traceTc (text "tcs 1") ;
 644     let {       -- Make all the bound ids "global" ids, now that
 645                 -- they're notionally top-level bindings.  This is
 646                 -- important: otherwise when we come to compile an expression
 647                 -- using these ids later, the byte code generator will consider
 648                 -- the occurrences to be free rather than global.
 649         global_ids     = map (globaliseId VanillaGlobal) bound_ids ;
 650
 651                 -- Update the interactive context
 652         rn_env   = ic_rn_local_env ictxt ;
 653         type_env = ic_type_env ictxt ;
 654
 655         bound_names = map idName global_ids ;
 656         new_rn_env  = extendLocalRdrEnv rn_env bound_names ;
 657
 658                 -- Remove any shadowed bindings from the type_env;
 659                 -- they are inaccessible but might, I suppose, cause
 660                 -- a space leak if we leave them there
 661         shadowed = [ n | name <- bound_names,
 662                          let rdr_name = mkRdrUnqual (nameOccName name),
 663                          Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
 664
 665         filtered_type_env = delListFromNameEnv type_env shadowed ;
 666         new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
 667
 668         new_ic = ictxt { ic_rn_local_env = new_rn_env,
 669                          ic_type_env     = new_type_env }
 670     } ;
 671
 672     dumpOptTcRn Opt_D_dump_tc
 673         (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
 674                text "Typechecked expr" <+> ppr tc_expr]) ;
 675
 676     returnM (new_ic, bound_names, tc_expr)
 677     }
 678 \end{code}
 679
 680
 681 Here is the grand plan, implemented in tcUserStmt
 682
 683         What you type                   The IO [HValue] that hscStmt returns
 684         -------------                   ------------------------------------
 685         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 686                                         bindings: [x,y,...]
 687
 688         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 689                                         bindings: [x,y,...]
 690
 691         expr (of IO type)       ==>     expr >>= \ it -> return [coerce HVal it]
 692           [NB: result not printed]      bindings: [it]
 693
 694         expr (of non-IO type,   ==>     let it = expr in print it >> return [coerce HVal it]
 695           result showable)              bindings: [it]
 696
 697         expr (of non-IO type,
 698           result not showable)  ==>     error
 699
 700
 701 \begin{code}
 702 ---------------------------
 703 tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
 704 tcUserStmt (L _ (ExprStmt expr _))
 705   = newUnique           `thenM` \ uniq ->
 706     let
 707         fresh_it = itName uniq
 708         the_bind = noLoc $ FunBind (noLoc fresh_it) False
 709                         [ mkSimpleMatch [] expr placeHolderType ]
 710     in
 711     tryTcLIE_ (do {     -- Try this if the other fails
 712                 traceTc (text "tcs 1b") ;
 713                 tc_stmts [
 714                     nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
 715                     nlExprStmt (nlHsApp (nlHsVar printName)
 716                                               (nlHsVar fresh_it))
 717         ] })
 718           (do {         -- Try this first
 719                 traceTc (text "tcs 1a") ;
 720                 tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] })
 721
 722 tcUserStmt stmt = tc_stmts [stmt]
 723
 724 ---------------------------
 725 tc_stmts stmts
 726  = do { ioTyCon <- tcLookupTyCon ioTyConName ;
 727         let {
 728             ret_ty    = mkListTy unitTy ;
 729             io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
 730
 731             names = map unLoc (collectStmtsBinders stmts) ;
 732
 733             stmt_ctxt = SC { sc_what = DoExpr,
 734                              sc_rhs  = check_rhs,
 735                              sc_body = check_body,
 736                              sc_ty   = ret_ty } ;
 737
 738             check_rhs rhs rhs_ty = tcCheckRho rhs  (mkTyConApp ioTyCon [rhs_ty]) ;
 739             check_body body      = tcCheckRho body io_ret_ty ;
 740
 741                 -- mk_return builds the expression
 742                 --      returnIO @ [()] [coerce () x, ..,  coerce () z]
 743                 --
 744                 -- Despite the inconvenience of building the type applications etc,
 745                 -- this *has* to be done in type-annotated post-typecheck form
 746                 -- because we are going to return a list of *polymorphic* values
 747                 -- coerced to type (). If we built a *source* stmt
 748                 --      return [coerce x, ..., coerce z]
 749                 -- then the type checker would instantiate x..z, and we wouldn't
 750                 -- get their *polymorphic* values.  (And we'd get ambiguity errs
 751                 -- if they were overloaded, since they aren't applied to anything.)
 752             mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
 753                                            (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
 754             mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
 755                                (nlHsVar id) ;
 756
 757             io_ty = mkTyConApp ioTyCon []
 758          } ;
 759
 760         -- OK, we're ready to typecheck the stmts
 761         traceTc (text "tcs 2") ;
 762         ((ids, tc_expr), lie) <- getLIE $ do {
 763             (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts   $
 764                         do {
 765                             -- Look up the names right in the middle,
 766                             -- where they will all be in scope
 767                             ids <- mappM tcLookupId names ;
 768                             ret_id <- tcLookupId returnIOName ;         -- return @ IO
 769                             return (ids, [nlResultStmt (mk_return ret_id ids)]) } ;
 770
 771             io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
 772             return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty))
 773         } ;
 774
 775         -- Simplify the context right here, so that we fail
 776         -- if there aren't enough instances.  Notably, when we see
 777         --              e
 778         -- we use recoverTc_ to try     it <- e
 779         -- and then                     let it = e
 780         -- It's the simplify step that rejects the first.
 781         traceTc (text "tcs 3") ;
 782         const_binds <- tcSimplifyInteractive lie ;
 783
 784         -- Build result expression and zonk it
 785         let { expr = mkHsLet const_binds tc_expr } ;
 786         zonked_expr <- zonkTopLExpr expr ;
 787         zonked_ids  <- zonkTopBndrs ids ;
 788
 789         -- None of the Ids should be of unboxed type, because we
 790         -- cast them all to HValues in the end!
 791         mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
 792
 793         return (zonked_ids, zonked_expr)
 794         }
 795   where
 796     combine stmt (ids, stmts) = (ids, stmt:stmts)
 797     bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
 798                                   nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
 799 \end{code}
 800
 801
 802 tcRnExpr just finds the type of an expression
 803
 804 \begin{code}
 805 tcRnExpr :: HscEnv
 806          -> InteractiveContext
 807          -> LHsExpr RdrName
 808          -> IO (Maybe Type)
 809 tcRnExpr hsc_env ictxt rdr_expr
 810   = initTcPrintErrors hsc_env iNTERACTIVE $
 811     setInteractiveContext ictxt $ do {
 812
 813     (rn_expr, fvs) <- rnLExpr rdr_expr ;
 814     failIfErrsM ;
 815
 816         -- Now typecheck the expression;
 817         -- it might have a rank-2 type (e.g. :t runST)
 818     ((tc_expr, res_ty), lie)       <- getLIE (tcInferRho rn_expr) ;
 819     ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie)  ;
 820     tcSimplifyInteractive lie_top ;
 821
 822     let { all_expr_ty = mkForAllTys qtvs                $
 823                         mkFunTys (map idType dict_ids)  $
 824                         res_ty } ;
 825     zonkTcType all_expr_ty
 826     }
 827   where
 828     smpl_doc = ptext SLIT("main expression")
 829 \end{code}
 830
 831 tcRnType just finds the kind of a type
 832
 833 \begin{code}
 834 tcRnType :: HscEnv
 835          -> InteractiveContext
 836          -> LHsType RdrName
 837          -> IO (Maybe Kind)
 838 tcRnType hsc_env ictxt rdr_type
 839   = initTcPrintErrors hsc_env iNTERACTIVE $
 840     setInteractiveContext ictxt $ do {
 841
 842     rn_type <- rnLHsType doc rdr_type ;
 843     failIfErrsM ;
 844
 845         -- Now kind-check the type
 846     (ty', kind) <- kcHsType rn_type ;
 847     return kind
 848     }
 849   where
 850     doc = ptext SLIT("In GHCi input")
 851
 852 #endif /* GHCi */
 853 \end{code}
 854
 855
 856 %************************************************************************
 857 %*                                                                      *
 858         More GHCi stuff, to do with browsing and getting info
 859 %*                                                                      *
 860 %************************************************************************
 861
 862 \begin{code}
 863 #ifdef GHCI
 864 mkExportEnv :: HscEnv -> [ModuleName]   -- Expose these modules' exports only
 865             -> IO GlobalRdrEnv
 866 mkExportEnv hsc_env exports
 867   = do  { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $
 868                      mappM getModuleExports exports
 869         ; case mb_envs of
 870              Just envs -> return (foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs)
 871              Nothing   -> return emptyGlobalRdrEnv
 872                              -- Some error; initTc will have printed it
 873     }
 874
 875 getModuleExports :: ModuleName -> TcM GlobalRdrEnv
 876 getModuleExports mod
 877   = do  { iface <- load_iface mod
 878         ; loadOrphanModules (dep_orphs (mi_deps iface))
 879                         -- Load any orphan-module interfaces,
 880                         -- so their instances are visible
 881         ; avails <- exportsToAvails (mi_exports iface)
 882         ; let { gres =  [ GRE  { gre_name = name, gre_prov = vanillaProv mod }
 883                         | avail <- avails, name <- availNames avail ] }
 884         ; returnM (mkGlobalRdrEnv gres) }
 885
 886 vanillaProv :: ModuleName -> Provenance
 887 -- We're building a GlobalRdrEnv as if the user imported
 888 -- all the specified modules into the global interactive module
 889 vanillaProv mod = Imported [ImportSpec mod mod False
 890                              (srcLocSpan interactiveSrcLoc)] False
 891 \end{code}
 892
 893 \begin{code}
 894 getModuleContents
 895   :: HscEnv
 896   -> InteractiveContext
 897   -> ModuleName                 -- Module to inspect
 898   -> Bool                       -- Grab just the exports, or the whole toplev
 899   -> IO (Maybe [IfaceDecl])
 900
 901 getModuleContents hsc_env ictxt mod exports_only
 902  = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only)
 903  where
 904    get_mod_contents exports_only
 905       | not exports_only  -- We want the whole top-level type env
 906                           -- so it had better be a home module
 907       = do { hpt <- getHpt
 908            ; case lookupModuleEnvByName hpt mod of
 909                Just mod_info -> return (map toIfaceDecl $
 910                                         filter wantToSee $
 911                                         typeEnvElts $
 912                                         md_types (hm_details mod_info))
 913                Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod)))
 914                           -- This is a system error; the module should be in the HPT
 915            }
 916
 917       | otherwise               -- Want the exports only
 918       = do { iface <- load_iface mod
 919            ; avails <- exportsToAvails (mi_exports iface)
 920            ; mappM get_decl avails
 921         }
 922
 923    get_decl avail
 924         = do { thing <- tcLookupGlobal (availName avail)
 925              ; return (filter_decl (availOccs avail) (toIfaceDecl thing)) }
 926
 927 ---------------------
 928 filter_decl occs decl@(IfaceClass {ifSigs = sigs})
 929   = decl { ifSigs = filter (keep_sig occs) sigs }
 930 filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon cons})
 931   = decl { ifCons = IfDataTyCon (filter (keep_con occs) cons) }
 932 filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
 933   | keep_con occs con = decl
 934   | otherwise         = decl {ifCons = IfAbstractTyCon} -- Hmm?
 935 filter_decl occs decl
 936   = decl
 937
 938 keep_sig occs (IfaceClassOp occ _ _)         = occ `elem` occs
 939 keep_con occs (IfaceConDecl occ _ _ _ _ _ _) = occ `elem` occs
 940
 941 availOccs avail = map nameOccName (availNames avail)
 942
 943 wantToSee (AnId id)    = not (isImplicitId id)
 944 wantToSee (ADataCon _) = False  -- They'll come via their TyCon
 945 wantToSee _            = True
 946
 947 ---------------------
 948 load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
 949                where
 950                  doc = ptext SLIT("context for compiling statements")
 951
 952 ---------------------
 953 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
 954                   <+> quotes (ppr mod)
 955 \end{code}
 956
 957 \begin{code}
 958 tcRnGetInfo :: HscEnv
 959             -> InteractiveContext
 960             -> RdrName
 961             -> IO (Maybe [(IfaceDecl,
 962                            Fixity, SrcLoc,
 963                            [(IfaceInst, SrcLoc)])])
 964 -- Used to implemnent :info in GHCi
 965 --
 966 -- Look up a RdrName and return all the TyThings it might be
 967 -- A capitalised RdrName is given to us in the DataName namespace,
 968 -- but we want to treat it as *both* a data constructor
 969 -- *and* as a type or class constructor;
 970 -- hence the call to dataTcOccs, and we return up to two results
 971 tcRnGetInfo hsc_env ictxt rdr_name
 972   = initTcPrintErrors hsc_env iNTERACTIVE $
 973     setInteractiveContext ictxt $ do {
 974
 975         -- If the identifier is a constructor (begins with an
 976         -- upper-case letter), then we need to consider both
 977         -- constructor and type class identifiers.
 978     let { rdr_names = dataTcOccs rdr_name } ;
 979
 980         -- results :: [(Messages, Maybe Name)]
 981     results <- mapM (tryTc . lookupOccRn) rdr_names ;
 982
 983     traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
 984         -- The successful lookups will be (Just name)
 985     let { (warns_s, good_names) = unzip [ (msgs, name)
 986                                         | (msgs, Just name) <- results] ;
 987           errs_s = [msgs | (msgs, Nothing) <- results] } ;
 988
 989         -- Fail if nothing good happened, else add warnings
 990     if null good_names then
 991                 -- No lookup succeeded, so
 992                 -- pick the first error message and report it
 993                 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
 994                 --       while the other is "X is not in scope",
 995                 --       we definitely want the former; but we might pick the latter
 996         do { addMessages (head errs_s) ; failM }
 997       else                      -- Add deprecation warnings
 998         mapM_ addMessages warns_s ;
 999
1000         -- And lookup up the entities, avoiding duplicates, which arise
1001         -- because constructors and record selectors are represented by
1002         -- their parent declaration
1003     let { do_one name = do { thing <- tcLookupGlobal name
1004                            ; let decl = toIfaceDecl thing
1005                            ; fixity <- lookupFixityRn name
1006                            ; insts  <- lookupInsts thing
1007                            ; return (decl, fixity, getSrcLoc thing,
1008                                      map mk_inst insts) } ;
1009                 -- For the SrcLoc, the 'thing' has better info than
1010                 -- the 'name' because getting the former forced the
1011                 -- declaration to be loaded into the cache
1012           mk_inst dfun = (dfunToIfaceInst dfun, getSrcLoc dfun) ;
1013           cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2 } ;
1014     results <- mapM do_one good_names ;
1015     return (fst (removeDups cmp results))
1016     }
1017
1018 lookupInsts :: TyThing -> TcM [DFunId]
1019 lookupInsts (AClass cls)
1020   = do  { loadImportedInsts cls []      -- [] means load all instances for cls
1021         ; inst_envs <- tcGetInstEnvs
1022         ; return [df | (_,_,df) <- classInstances inst_envs cls] }
1023
1024 lookupInsts (ATyCon tc)
1025   = do  { eps <- getEps -- Load all instances for all classes that are
1026                         -- in the type environment (which are all the ones
1027                         -- we've seen in any interface file so far
1028         ; mapM_ (\c -> loadImportedInsts c [])
1029                 (typeEnvClasses (eps_PTE eps))
1030         ; (pkg_ie, home_ie) <- tcGetInstEnvs    -- Search all
1031         ; return (get home_ie ++ get pkg_ie) }
1032   where
1033     get ie = [df | (_,_,df) <- instEnvElts ie, relevant df]
1034     relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
1035     tc_name = tyConName tc
1036
1037 lookupInsts other = return []
1038
1039
1040 toIfaceDecl :: TyThing -> IfaceDecl
1041 toIfaceDecl thing
1042   = tyThingToIfaceDecl True             -- Discard IdInfo
1043                        emptyNameSet     -- Show data cons
1044                        ext_nm (munge thing)
1045   where
1046     ext_nm n = ExtPkg (nameModuleName n) (nameOccName n)
1047
1048         -- munge transforms a thing to it's "parent" thing
1049     munge (ADataCon dc) = ATyCon (dataConTyCon dc)
1050     munge (AnId id) = case globalIdDetails id of
1051                         RecordSelId lbl -> ATyCon (fieldLabelTyCon lbl)
1052                         ClassOpId cls   -> AClass cls
1053                         other           -> AnId id
1054     munge other_thing = other_thing
1055
1056 #endif /* GHCI */
1057 \end{code}
1058
1059 %************************************************************************
1060 %*                                                                      *
1061                 Degugging output
1062 %*                                                                      *
1063 %************************************************************************
1064
1065 \begin{code}
1066 rnDump :: SDoc -> TcRn ()
1067 -- Dump, with a banner, if -ddump-rn
1068 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1069
1070 tcDump :: TcGblEnv -> TcRn ()
1071 tcDump env
1072  = do { dflags <- getDOpts ;
1073
1074         -- Dump short output if -ddump-types or -ddump-tc
1075         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1076             (dumpTcRn short_dump) ;
1077
1078         -- Dump bindings if -ddump-tc
1079         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1080    }
1081   where
1082     short_dump = pprTcGblEnv env
1083     full_dump  = pprLHsBinds (tcg_binds env)
1084         -- NB: foreign x-d's have undefined's in their types;
1085         --     hence can't show the tc_fords
1086
1087 tcCoreDump mod_guts
1088  = do { dflags <- getDOpts ;
1089         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1090             (dumpTcRn (pprModGuts mod_guts)) ;
1091
1092         -- Dump bindings if -ddump-tc
1093         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1094   where
1095     full_dump = pprCoreBindings (mg_binds mod_guts)
1096
1097 -- It's unpleasant having both pprModGuts and pprModDetails here
1098 pprTcGblEnv :: TcGblEnv -> SDoc
1099 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1100                         tcg_insts    = dfun_ids,
1101                         tcg_rules    = rules,
1102                         tcg_imports  = imports })
1103   = vcat [ ppr_types dfun_ids type_env
1104          , ppr_insts dfun_ids
1105          , vcat (map ppr rules)
1106          , ppr_gen_tycons (typeEnvTyCons type_env)
1107          , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports))
1108          , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1109
1110 pprModGuts :: ModGuts -> SDoc
1111 pprModGuts (ModGuts { mg_types = type_env,
1112                       mg_rules = rules })
1113   = vcat [ ppr_types [] type_env,
1114            ppr_rules rules ]
1115
1116
1117 ppr_types :: [Var] -> TypeEnv -> SDoc
1118 ppr_types dfun_ids type_env
1119   = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1120   where
1121     ids = [id | id <- typeEnvIds type_env, want_sig id]
1122     want_sig id | opt_PprStyle_Debug = True
1123                 | otherwise          = isLocalId id &&
1124                                        isExternalName (idName id) &&
1125                                        not (id `elem` dfun_ids)
1126         -- isLocalId ignores data constructors, records selectors etc.
1127         -- The isExternalName ignores local dictionary and method bindings
1128         -- that the type checker has invented.  Top-level user-defined things
1129         -- have External names.
1130
1131 ppr_insts :: [Var] -> SDoc
1132 ppr_insts []       = empty
1133 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1134
1135 ppr_sigs :: [Var] -> SDoc
1136 ppr_sigs ids
1137         -- Print type signatures; sort by OccName
1138   = vcat (map ppr_sig (sortLe le_sig ids))
1139   where
1140     le_sig id1 id2 = getOccName id1 <= getOccName id2
1141     ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
1142
1143 ppr_rules :: [IdCoreRule] -> SDoc
1144 ppr_rules [] = empty
1145 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1146                       nest 4 (pprIdRules rs),
1147                       ptext SLIT("#-}")]
1148
1149 ppr_gen_tycons []  = empty
1150 ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"),
1151                            nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]
1152 \end{code}