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