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