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