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 checkHiBootIface env boot_names
 428   = mapM_ (check_one env) boot_names
 429
 430 ----------------
 431 check_one local_env name
 432   = do  { eps  <- getEps
 433
 434                 -- Look up the hi-boot one;
 435                 -- it should jolly well be there (else GHC bug)
 436        ; case lookupTypeEnv (eps_PTE eps) name of {
 437             Nothing -> pprPanic "checkHiBootIface" (ppr name) ;
 438             Just boot_thing ->
 439
 440                 -- Look it up in the local type env
 441                 -- It should be there, but it's a programmer error if not
 442          case lookupTypeEnv local_env name of
 443            Nothing         -> addErrTc (missingBootThing boot_thing)
 444            Just real_thing -> check_thing boot_thing real_thing
 445     } }
 446
 447 ----------------
 448 check_thing (ATyCon boot_tc) (ATyCon real_tc)
 449   | isSynTyCon boot_tc && isSynTyCon real_tc,
 450     defn1 `tcEqType` substTyWith tvs2 (mkTyVarTys tvs1) defn2
 451   = return ()
 452
 453   | tyConKind boot_tc == tyConKind real_tc
 454   = return ()
 455   where
 456     (tvs1, defn1) = getSynTyConDefn boot_tc
 457     (tvs2, defn2) = getSynTyConDefn boot_tc
 458
 459 check_thing (AnId boot_id) (AnId real_id)
 460   | idType boot_id `tcEqType` idType real_id
 461   = return ()
 462
 463 check_thing (ADataCon dc1) (ADataCon dc2)
 464   | idType (dataConWrapId dc1) `tcEqType` idType (dataConWrapId dc2)
 465   = return ()
 466
 467         -- Can't declare a class in a hi-boot file
 468
 469 check_thing boot_thing real_thing       -- Default case; failure
 470   = addErrAt (srcLocSpan (getSrcLoc real_thing))
 471              (bootMisMatch real_thing)
 472
 473 ----------------
 474 missingBootThing thing
 475   = ppr thing <+> ptext SLIT("is defined in the hi-boot file, but not in the module")
 476 bootMisMatch thing
 477   = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hi-boot file")
 478 \end{code}
 479
 480
 481 %************************************************************************
 482 %*                                                                      *
 483         Type-checking the top level of a module
 484 %*                                                                      *
 485 %************************************************************************
 486
 487 tcRnGroup takes a bunch of top-level source-code declarations, and
 488  * renames them
 489  * gets supporting declarations from interface files
 490  * typechecks them
 491  * zonks them
 492  * and augments the TcGblEnv with the results
 493
 494 In Template Haskell it may be called repeatedly for each group of
 495 declarations.  It expects there to be an incoming TcGblEnv in the
 496 monad; it augments it and returns the new TcGblEnv.
 497
 498 \begin{code}
 499 tcRnGroup :: [Name] -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
 500         -- Returns the variables free in the decls, for unused-binding reporting
 501 tcRnGroup boot_names decls
 502  = do {         -- Rename the declarations
 503         (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
 504         setGblEnv tcg_env $ do {
 505
 506                 -- Typecheck the declarations
 507         tcTopSrcDecls boot_names rn_decls
 508   }}
 509
 510 ------------------------------------------------
 511 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
 512 rnTopSrcDecls group
 513  = do {         -- Bring top level binders into scope
 514         (rdr_env, imports) <- importsFromLocalDecls group ;
 515         updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
 516                                  tcg_imports = imports `plusImportAvails` tcg_imports gbl })
 517                   $ do {
 518
 519         traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
 520         failIfErrsM ;   -- No point in continuing if (say) we have duplicate declarations
 521
 522                 -- Rename the source decls
 523         (tcg_env, rn_decls) <- rnSrcDecls group ;
 524         failIfErrsM ;
 525
 526                 -- Dump trace of renaming part
 527         rnDump (ppr rn_decls) ;
 528
 529         return (tcg_env, rn_decls)
 530    }}
 531
 532 ------------------------------------------------
 533 tcTopSrcDecls :: [Name] -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
 534 tcTopSrcDecls boot_names
 535         (HsGroup { hs_tyclds = tycl_decls,
 536                    hs_instds = inst_decls,
 537                    hs_fords  = foreign_decls,
 538                    hs_defds  = default_decls,
 539                    hs_ruleds = rule_decls,
 540                    hs_valds  = val_binds })
 541  = do {         -- Type-check the type and class decls, and all imported decls
 542                 -- The latter come in via tycl_decls
 543         traceTc (text "Tc2") ;
 544
 545         tcg_env <- checkNoErrs (tcTyAndClassDecls boot_names tycl_decls) ;
 546         -- tcTyAndClassDecls recovers internally, but if anything gave rise to
 547         -- an error we'd better stop now, to avoid a cascade
 548
 549         -- Make these type and class decls available to stuff slurped from interface files
 550         writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
 551
 552
 553         setGblEnv tcg_env       $ do {
 554                 -- Source-language instances, including derivings,
 555                 -- and import the supporting declarations
 556         traceTc (text "Tc3") ;
 557         (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
 558         setGblEnv tcg_env       $ do {
 559
 560                 -- Foreign import declarations next.  No zonking necessary
 561                 -- here; we can tuck them straight into the global environment.
 562         traceTc (text "Tc4") ;
 563         (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
 564         tcExtendGlobalValEnv fi_ids     $ do {
 565
 566                 -- Default declarations
 567         traceTc (text "Tc4a") ;
 568         default_tys <- tcDefaults default_decls ;
 569         updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
 570
 571                 -- Value declarations next
 572                 -- We also typecheck any extra binds that came out
 573                 -- of the "deriving" process (deriv_binds)
 574         traceTc (text "Tc5") ;
 575         (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ;
 576         setLclTypeEnv lcl_env   $ do {
 577
 578                 -- Second pass over class and instance declarations,
 579         traceTc (text "Tc6") ;
 580         (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
 581         showLIE (text "after instDecls2") ;
 582
 583                 -- Foreign exports
 584                 -- They need to be zonked, so we return them
 585         traceTc (text "Tc7") ;
 586         (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
 587
 588                 -- Rules
 589         rules <- tcRules rule_decls ;
 590
 591                 -- Wrap up
 592         traceTc (text "Tc7a") ;
 593         tcg_env <- getGblEnv ;
 594         let { all_binds = tc_val_binds   `unionBags`
 595                           inst_binds     `unionBags`
 596                           foe_binds  ;
 597
 598                 -- Extend the GblEnv with the (as yet un-zonked)
 599                 -- bindings, rules, foreign decls
 600               tcg_env' = tcg_env {  tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
 601                                     tcg_rules = tcg_rules tcg_env ++ rules,
 602                                     tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
 603         return (tcg_env', lcl_env)
 604     }}}}}}
 605 \end{code}
 606
 607
 608 %************************************************************************
 609 %*                                                                      *
 610         Checking for 'main'
 611 %*                                                                      *
 612 %************************************************************************
 613
 614 \begin{code}
 615 checkMain
 616   = do { ghci_mode <- getGhciMode ;
 617          tcg_env   <- getGblEnv ;
 618
 619          mb_main_mod <- readMutVar v_MainModIs ;
 620          mb_main_fn  <- readMutVar v_MainFunIs ;
 621          let { main_mod = case mb_main_mod of {
 622                                 Just mod -> mkModuleName mod ;
 623                                 Nothing  -> mAIN_Name } ;
 624                main_fn  = case mb_main_fn of {
 625                                 Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
 626                                 Nothing -> main_RDR_Unqual } } ;
 627
 628          check_main ghci_mode tcg_env main_mod main_fn
 629     }
 630
 631
 632 check_main ghci_mode tcg_env main_mod main_fn
 633      -- If we are in module Main, check that 'main' is defined.
 634      -- It may be imported from another module!
 635      --
 636      -- ToDo: We have to return the main_name separately, because it's a
 637      -- bona fide 'use', and should be recorded as such, but the others
 638      -- aren't
 639      --
 640      -- Blimey: a whole page of code to do this...
 641  | mod_name /= main_mod
 642  = return tcg_env
 643
 644  | otherwise
 645  = addErrCtxt mainCtxt                  $
 646    do   { mb_main <- lookupSrcOcc_maybe main_fn
 647                 -- Check that 'main' is in scope
 648                 -- It might be imported from another module!
 649         ; case mb_main of {
 650              Nothing -> do { complain_no_main
 651                            ; return tcg_env } ;
 652              Just main_name -> do
 653         { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) }
 654                         -- :Main.main :: IO () = runIO main
 655
 656         ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $
 657                              tcInferRho rhs
 658
 659         ; let { root_main_id = mkExportedLocalId rootMainName ty ;
 660                 main_bind    = noLoc (VarBind root_main_id main_expr) }
 661
 662         ; return (tcg_env { tcg_binds = tcg_binds tcg_env
 663                                         `snocBag` main_bind,
 664                             tcg_dus   = tcg_dus tcg_env
 665                                         `plusDU` usesOnly (unitFV main_name)
 666                  })
 667     }}}
 668   where
 669     mod_name = moduleName (tcg_mod tcg_env)
 670
 671     complain_no_main | ghci_mode == Interactive = return ()
 672                      | otherwise                = failWithTc noMainMsg
 673         -- In interactive mode, don't worry about the absence of 'main'
 674         -- In other modes, fail altogether, so that we don't go on
 675         -- and complain a second time when processing the export list.
 676
 677     mainCtxt  = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
 678     noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
 679                 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
 680 \end{code}
 681
 682
 683 %*********************************************************
 684 %*                                                       *
 685                 GHCi stuff
 686 %*                                                       *
 687 %*********************************************************
 688
 689 \begin{code}
 690 #ifdef GHCI
 691 setInteractiveContext :: InteractiveContext -> TcRn a -> TcRn a
 692 setInteractiveContext icxt thing_inside
 693   = traceTc (text "setIC" <+> ppr (ic_type_env icxt))   `thenM_`
 694     (updGblEnv (\env -> env {tcg_rdr_env  = ic_rn_gbl_env icxt,
 695                              tcg_type_env = ic_type_env   icxt}) $
 696      updLclEnv (\env -> env {tcl_rdr = ic_rn_local_env icxt})   $
 697                thing_inside)
 698 \end{code}
 699
 700
 701 \begin{code}
 702 tcRnStmt :: HscEnv
 703          -> InteractiveContext
 704          -> LStmt RdrName
 705          -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
 706                 -- The returned [Name] is the same as the input except for
 707                 -- ExprStmt, in which case the returned [Name] is [itName]
 708                 --
 709                 -- The returned TypecheckedHsExpr is of type IO [ () ],
 710                 -- a list of the bound values, coerced to ().
 711
 712 tcRnStmt hsc_env ictxt rdr_stmt
 713   = initTcPrintErrors hsc_env iNTERACTIVE $
 714     setInteractiveContext ictxt $ do {
 715
 716     -- Rename; use CmdLineMode because tcRnStmt is only used interactively
 717     ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ;
 718     traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
 719     failIfErrsM ;
 720
 721     -- The real work is done here
 722     (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
 723
 724     traceTc (text "tcs 1") ;
 725     let {       -- Make all the bound ids "global" ids, now that
 726                 -- they're notionally top-level bindings.  This is
 727                 -- important: otherwise when we come to compile an expression
 728                 -- using these ids later, the byte code generator will consider
 729                 -- the occurrences to be free rather than global.
 730         global_ids     = map (globaliseId VanillaGlobal) bound_ids ;
 731
 732                 -- Update the interactive context
 733         rn_env   = ic_rn_local_env ictxt ;
 734         type_env = ic_type_env ictxt ;
 735
 736         bound_names = map idName global_ids ;
 737         new_rn_env  = extendLocalRdrEnv rn_env bound_names ;
 738
 739                 -- Remove any shadowed bindings from the type_env;
 740                 -- they are inaccessible but might, I suppose, cause
 741                 -- a space leak if we leave them there
 742         shadowed = [ n | name <- bound_names,
 743                          let rdr_name = mkRdrUnqual (nameOccName name),
 744                          Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
 745
 746         filtered_type_env = delListFromNameEnv type_env shadowed ;
 747         new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
 748
 749         new_ic = ictxt { ic_rn_local_env = new_rn_env,
 750                          ic_type_env     = new_type_env }
 751     } ;
 752
 753     dumpOptTcRn Opt_D_dump_tc
 754         (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
 755                text "Typechecked expr" <+> ppr tc_expr]) ;
 756
 757     returnM (new_ic, bound_names, tc_expr)
 758     }
 759 \end{code}
 760
 761
 762 Here is the grand plan, implemented in tcUserStmt
 763
 764         What you type                   The IO [HValue] that hscStmt returns
 765         -------------                   ------------------------------------
 766         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 767                                         bindings: [x,y,...]
 768
 769         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 770                                         bindings: [x,y,...]
 771
 772         expr (of IO type)       ==>     expr >>= \ it -> return [coerce HVal it]
 773           [NB: result not printed]      bindings: [it]
 774
 775         expr (of non-IO type,   ==>     let it = expr in print it >> return [coerce HVal it]
 776           result showable)              bindings: [it]
 777
 778         expr (of non-IO type,
 779           result not showable)  ==>     error
 780
 781
 782 \begin{code}
 783 ---------------------------
 784 tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
 785 tcUserStmt (L _ (ExprStmt expr _))
 786   = newUnique           `thenM` \ uniq ->
 787     let
 788         fresh_it = itName uniq
 789         the_bind = noLoc $ FunBind (noLoc fresh_it) False
 790                              (mkMatchGroup [mkSimpleMatch [] expr])
 791     in
 792     tryTcLIE_ (do {     -- Try this if the other fails
 793                 traceTc (text "tcs 1b") ;
 794                 tc_stmts [
 795                     nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
 796                     nlExprStmt (nlHsApp (nlHsVar printName)
 797                                               (nlHsVar fresh_it))
 798         ] })
 799           (do {         -- Try this first
 800                 traceTc (text "tcs 1a") ;
 801                 tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] })
 802
 803 tcUserStmt stmt = tc_stmts [stmt]
 804
 805 ---------------------------
 806 tc_stmts stmts
 807  = do { ioTyCon <- tcLookupTyCon ioTyConName ;
 808         let {
 809             ret_ty    = mkListTy unitTy ;
 810             io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
 811
 812             names = map unLoc (collectStmtsBinders stmts) ;
 813
 814             stmt_ctxt = SC { sc_what = DoExpr,
 815                              sc_rhs  = infer_rhs,
 816                              sc_body = check_body,
 817                              sc_ty   = ret_ty } ;
 818
 819             infer_rhs rhs   = do { (rhs', rhs_ty) <- tcInferRho rhs
 820                                  ; [pat_ty] <- unifyTyConApp ioTyCon rhs_ty
 821                                  ; return (rhs', pat_ty) } ;
 822             check_body body = tcCheckRho body io_ret_ty ;
 823
 824                 -- mk_return builds the expression
 825                 --      returnIO @ [()] [coerce () x, ..,  coerce () z]
 826                 --
 827                 -- Despite the inconvenience of building the type applications etc,
 828                 -- this *has* to be done in type-annotated post-typecheck form
 829                 -- because we are going to return a list of *polymorphic* values
 830                 -- coerced to type (). If we built a *source* stmt
 831                 --      return [coerce x, ..., coerce z]
 832                 -- then the type checker would instantiate x..z, and we wouldn't
 833                 -- get their *polymorphic* values.  (And we'd get ambiguity errs
 834                 -- if they were overloaded, since they aren't applied to anything.)
 835             mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
 836                                            (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
 837             mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
 838                                (nlHsVar id) ;
 839
 840             io_ty = mkTyConApp ioTyCon []
 841          } ;
 842
 843         -- OK, we're ready to typecheck the stmts
 844         traceTc (text "tcs 2") ;
 845         ((ids, tc_expr), lie) <- getLIE $ do {
 846             (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts   $
 847                         do {
 848                             -- Look up the names right in the middle,
 849                             -- where they will all be in scope
 850                             ids <- mappM tcLookupId names ;
 851                             ret_id <- tcLookupId returnIOName ;         -- return @ IO
 852                             return (ids, [nlResultStmt (mk_return ret_id ids)]) } ;
 853
 854             io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
 855             return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty))
 856         } ;
 857
 858         -- Simplify the context right here, so that we fail
 859         -- if there aren't enough instances.  Notably, when we see
 860         --              e
 861         -- we use recoverTc_ to try     it <- e
 862         -- and then                     let it = e
 863         -- It's the simplify step that rejects the first.
 864         traceTc (text "tcs 3") ;
 865         const_binds <- tcSimplifyInteractive lie ;
 866
 867         -- Build result expression and zonk it
 868         let { expr = mkHsLet const_binds tc_expr } ;
 869         zonked_expr <- zonkTopLExpr expr ;
 870         zonked_ids  <- zonkTopBndrs ids ;
 871
 872         -- None of the Ids should be of unboxed type, because we
 873         -- cast them all to HValues in the end!
 874         mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ;
 875
 876         return (zonked_ids, zonked_expr)
 877         }
 878   where
 879     combine stmt (ids, stmts) = (ids, stmt:stmts)
 880     bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"),
 881                                   nest 2 (ppr id <+> dcolon <+> ppr (idType id))])
 882 \end{code}
 883
 884
 885 tcRnExpr just finds the type of an expression
 886
 887 \begin{code}
 888 tcRnExpr :: HscEnv
 889          -> InteractiveContext
 890          -> LHsExpr RdrName
 891          -> IO (Maybe Type)
 892 tcRnExpr hsc_env ictxt rdr_expr
 893   = initTcPrintErrors hsc_env iNTERACTIVE $
 894     setInteractiveContext ictxt $ do {
 895
 896     (rn_expr, fvs) <- rnLExpr rdr_expr ;
 897     failIfErrsM ;
 898
 899         -- Now typecheck the expression;
 900         -- it might have a rank-2 type (e.g. :t runST)
 901     ((tc_expr, res_ty), lie)       <- getLIE (tcInferRho rn_expr) ;
 902     ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie)  ;
 903     tcSimplifyInteractive lie_top ;
 904
 905     let { all_expr_ty = mkForAllTys qtvs                $
 906                         mkFunTys (map idType dict_ids)  $
 907                         res_ty } ;
 908     zonkTcType all_expr_ty
 909     }
 910   where
 911     smpl_doc = ptext SLIT("main expression")
 912 \end{code}
 913
 914 tcRnType just finds the kind of a type
 915
 916 \begin{code}
 917 tcRnType :: HscEnv
 918          -> InteractiveContext
 919          -> LHsType RdrName
 920          -> IO (Maybe Kind)
 921 tcRnType hsc_env ictxt rdr_type
 922   = initTcPrintErrors hsc_env iNTERACTIVE $
 923     setInteractiveContext ictxt $ do {
 924
 925     rn_type <- rnLHsType doc rdr_type ;
 926     failIfErrsM ;
 927
 928         -- Now kind-check the type
 929     (ty', kind) <- kcHsType rn_type ;
 930     return kind
 931     }
 932   where
 933     doc = ptext SLIT("In GHCi input")
 934
 935 #endif /* GHCi */
 936 \end{code}
 937
 938
 939 %************************************************************************
 940 %*                                                                      *
 941         More GHCi stuff, to do with browsing and getting info
 942 %*                                                                      *
 943 %************************************************************************
 944
 945 \begin{code}
 946 #ifdef GHCI
 947 mkExportEnv :: HscEnv -> [ModuleName]   -- Expose these modules' exports only
 948             -> IO GlobalRdrEnv
 949 mkExportEnv hsc_env exports
 950   = do  { mb_envs <- initTcPrintErrors hsc_env iNTERACTIVE $
 951                      mappM getModuleExports exports
 952         ; case mb_envs of
 953              Just envs -> return (foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs)
 954              Nothing   -> return emptyGlobalRdrEnv
 955                              -- Some error; initTc will have printed it
 956     }
 957
 958 getModuleExports :: ModuleName -> TcM GlobalRdrEnv
 959 getModuleExports mod
 960   = do  { iface <- load_iface mod
 961         ; loadOrphanModules (dep_orphs (mi_deps iface))
 962                         -- Load any orphan-module interfaces,
 963                         -- so their instances are visible
 964         ; avails <- exportsToAvails (mi_exports iface)
 965         ; let { gres =  [ GRE  { gre_name = name, gre_prov = vanillaProv mod }
 966                         | avail <- avails, name <- availNames avail ] }
 967         ; returnM (mkGlobalRdrEnv gres) }
 968
 969 vanillaProv :: ModuleName -> Provenance
 970 -- We're building a GlobalRdrEnv as if the user imported
 971 -- all the specified modules into the global interactive module
 972 vanillaProv mod = Imported [ImportSpec mod mod False
 973                              (srcLocSpan interactiveSrcLoc)] False
 974 \end{code}
 975
 976 \begin{code}
 977 getModuleContents
 978   :: HscEnv
 979   -> InteractiveContext
 980   -> ModuleName                 -- Module to inspect
 981   -> Bool                       -- Grab just the exports, or the whole toplev
 982   -> IO (Maybe [IfaceDecl])
 983
 984 getModuleContents hsc_env ictxt mod exports_only
 985  = initTcPrintErrors hsc_env iNTERACTIVE (get_mod_contents exports_only)
 986  where
 987    get_mod_contents exports_only
 988       | not exports_only  -- We want the whole top-level type env
 989                           -- so it had better be a home module
 990       = do { hpt <- getHpt
 991            ; case lookupModuleEnvByName hpt mod of
 992                Just mod_info -> return (map toIfaceDecl $
 993                                         filter wantToSee $
 994                                         typeEnvElts $
 995                                         md_types (hm_details mod_info))
 996                Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod)))
 997                           -- This is a system error; the module should be in the HPT
 998            }
 999
1000       | otherwise               -- Want the exports only
1001       = do { iface <- load_iface mod
1002            ; avails <- exportsToAvails (mi_exports iface)
1003            ; mappM get_decl avails
1004         }
1005
1006    get_decl avail
1007         = do { thing <- tcLookupGlobal (availName avail)
1008              ; return (filter_decl (availOccs avail) (toIfaceDecl thing)) }
1009
1010 ---------------------
1011 filter_decl occs decl@(IfaceClass {ifSigs = sigs})
1012   = decl { ifSigs = filter (keep_sig occs) sigs }
1013 filter_decl occs decl@(IfaceData {ifCons = IfDataTyCon th cons})
1014   = decl { ifCons = IfDataTyCon th (filter (keep_con occs) cons) }
1015 filter_decl occs decl@(IfaceData {ifCons = IfNewTyCon con})
1016   | keep_con occs con = decl
1017   | otherwise         = decl {ifCons = IfAbstractTyCon} -- Hmm?
1018 filter_decl occs decl
1019   = decl
1020
1021 keep_sig occs (IfaceClassOp occ _ _) = occ `elem` occs
1022 keep_con occs con                    = ifConOcc con `elem` occs
1023
1024 availOccs avail = map nameOccName (availNames avail)
1025
1026 wantToSee (AnId id)    = not (isImplicitId id)
1027 wantToSee (ADataCon _) = False  -- They'll come via their TyCon
1028 wantToSee _            = True
1029
1030 ---------------------
1031 load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
1032                where
1033                  doc = ptext SLIT("context for compiling statements")
1034
1035 ---------------------
1036 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
1037                   <+> quotes (ppr mod)
1038 \end{code}
1039
1040 \begin{code}
1041 tcRnGetInfo :: HscEnv
1042             -> InteractiveContext
1043             -> RdrName
1044             -> IO (Maybe [(IfaceDecl,
1045                            Fixity, SrcLoc,
1046                            [(IfaceInst, SrcLoc)])])
1047 -- Used to implemnent :info in GHCi
1048 --
1049 -- Look up a RdrName and return all the TyThings it might be
1050 -- A capitalised RdrName is given to us in the DataName namespace,
1051 -- but we want to treat it as *both* a data constructor
1052 -- *and* as a type or class constructor;
1053 -- hence the call to dataTcOccs, and we return up to two results
1054 tcRnGetInfo hsc_env ictxt rdr_name
1055   = initTcPrintErrors hsc_env iNTERACTIVE $
1056     setInteractiveContext ictxt $ do {
1057
1058         -- If the identifier is a constructor (begins with an
1059         -- upper-case letter), then we need to consider both
1060         -- constructor and type class identifiers.
1061     let { rdr_names = dataTcOccs rdr_name } ;
1062
1063         -- results :: [(Messages, Maybe Name)]
1064     results <- mapM (tryTc . lookupOccRn) rdr_names ;
1065
1066     traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]);
1067         -- The successful lookups will be (Just name)
1068     let { (warns_s, good_names) = unzip [ (msgs, name)
1069                                         | (msgs, Just name) <- results] ;
1070           errs_s = [msgs | (msgs, Nothing) <- results] } ;
1071
1072         -- Fail if nothing good happened, else add warnings
1073     if null good_names then
1074                 -- No lookup succeeded, so
1075                 -- pick the first error message and report it
1076                 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
1077                 --       while the other is "X is not in scope",
1078                 --       we definitely want the former; but we might pick the latter
1079         do { addMessages (head errs_s) ; failM }
1080       else                      -- Add deprecation warnings
1081         mapM_ addMessages warns_s ;
1082
1083         -- And lookup up the entities, avoiding duplicates, which arise
1084         -- because constructors and record selectors are represented by
1085         -- their parent declaration
1086     let { do_one name = do { thing <- tcLookupGlobal name
1087                            ; let decl = toIfaceDecl thing
1088                            ; fixity <- lookupFixityRn name
1089                            ; insts  <- lookupInsts thing
1090                            ; return (decl, fixity, getSrcLoc thing,
1091                                      map mk_inst insts) } ;
1092                 -- For the SrcLoc, the 'thing' has better info than
1093                 -- the 'name' because getting the former forced the
1094                 -- declaration to be loaded into the cache
1095           mk_inst dfun = (dfunToIfaceInst dfun, getSrcLoc dfun) ;
1096           cmp (d1,_,_,_) (d2,_,_,_) = ifName d1 `compare` ifName d2 } ;
1097     results <- mapM do_one good_names ;
1098     return (fst (removeDups cmp results))
1099     }
1100
1101 lookupInsts :: TyThing -> TcM [DFunId]
1102 lookupInsts (AClass cls)
1103   = do  { loadImportedInsts cls []      -- [] means load all instances for cls
1104         ; inst_envs <- tcGetInstEnvs
1105         ; return [df | (_,_,df) <- classInstances inst_envs cls] }
1106
1107 lookupInsts (ATyCon tc)
1108   = do  { eps <- getEps -- Load all instances for all classes that are
1109                         -- in the type environment (which are all the ones
1110                         -- we've seen in any interface file so far
1111         ; mapM_ (\c -> loadImportedInsts c [])
1112                 (typeEnvClasses (eps_PTE eps))
1113         ; (pkg_ie, home_ie) <- tcGetInstEnvs    -- Search all
1114         ; return (get home_ie ++ get pkg_ie) }
1115   where
1116     get ie = [df | (_,_,df) <- instEnvElts ie, relevant df]
1117     relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df)
1118     tc_name = tyConName tc
1119
1120 lookupInsts other = return []
1121
1122
1123 toIfaceDecl :: TyThing -> IfaceDecl
1124 toIfaceDecl thing
1125   = tyThingToIfaceDecl True             -- Discard IdInfo
1126                        emptyNameSet     -- Show data cons
1127                        ext_nm (munge thing)
1128   where
1129     ext_nm n = ExtPkg (nameModuleName n) (nameOccName n)
1130
1131         -- munge transforms a thing to it's "parent" thing
1132     munge (ADataCon dc) = ATyCon (dataConTyCon dc)
1133     munge (AnId id) = case globalIdDetails id of
1134                         RecordSelId tc lbl -> ATyCon tc
1135                         ClassOpId cls      -> AClass cls
1136                         other              -> AnId id
1137     munge other_thing = other_thing
1138
1139 #endif /* GHCI */
1140 \end{code}
1141
1142 %************************************************************************
1143 %*                                                                      *
1144                 Degugging output
1145 %*                                                                      *
1146 %************************************************************************
1147
1148 \begin{code}
1149 rnDump :: SDoc -> TcRn ()
1150 -- Dump, with a banner, if -ddump-rn
1151 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
1152
1153 tcDump :: TcGblEnv -> TcRn ()
1154 tcDump env
1155  = do { dflags <- getDOpts ;
1156
1157         -- Dump short output if -ddump-types or -ddump-tc
1158         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1159             (dumpTcRn short_dump) ;
1160
1161         -- Dump bindings if -ddump-tc
1162         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1163    }
1164   where
1165     short_dump = pprTcGblEnv env
1166     full_dump  = pprLHsBinds (tcg_binds env)
1167         -- NB: foreign x-d's have undefined's in their types;
1168         --     hence can't show the tc_fords
1169
1170 tcCoreDump mod_guts
1171  = do { dflags <- getDOpts ;
1172         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1173             (dumpTcRn (pprModGuts mod_guts)) ;
1174
1175         -- Dump bindings if -ddump-tc
1176         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1177   where
1178     full_dump = pprCoreBindings (mg_binds mod_guts)
1179
1180 -- It's unpleasant having both pprModGuts and pprModDetails here
1181 pprTcGblEnv :: TcGblEnv -> SDoc
1182 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1183                         tcg_insts    = dfun_ids,
1184                         tcg_rules    = rules,
1185                         tcg_imports  = imports })
1186   = vcat [ ppr_types dfun_ids type_env
1187          , ppr_insts dfun_ids
1188          , vcat (map ppr rules)
1189          , ppr_gen_tycons (typeEnvTyCons type_env)
1190          , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports))
1191          , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1192
1193 pprModGuts :: ModGuts -> SDoc
1194 pprModGuts (ModGuts { mg_types = type_env,
1195                       mg_rules = rules })
1196   = vcat [ ppr_types [] type_env,
1197            ppr_rules rules ]
1198
1199
1200 ppr_types :: [Var] -> TypeEnv -> SDoc
1201 ppr_types dfun_ids type_env
1202   = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1203   where
1204     ids = [id | id <- typeEnvIds type_env, want_sig id]
1205     want_sig id | opt_PprStyle_Debug = True
1206                 | otherwise          = isLocalId id &&
1207                                        isExternalName (idName id) &&
1208                                        not (id `elem` dfun_ids)
1209         -- isLocalId ignores data constructors, records selectors etc.
1210         -- The isExternalName ignores local dictionary and method bindings
1211         -- that the type checker has invented.  Top-level user-defined things
1212         -- have External names.
1213
1214 ppr_insts :: [Var] -> SDoc
1215 ppr_insts []       = empty
1216 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1217
1218 ppr_sigs :: [Var] -> SDoc
1219 ppr_sigs ids
1220         -- Print type signatures; sort by OccName
1221   = vcat (map ppr_sig (sortLe le_sig ids))
1222   where
1223     le_sig id1 id2 = getOccName id1 <= getOccName id2
1224     ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
1225
1226 ppr_rules :: [IdCoreRule] -> SDoc
1227 ppr_rules [] = empty
1228 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1229                       nest 4 (pprIdRules rs),
1230                       ptext SLIT("#-}")]
1231
1232 ppr_gen_tycons []  = empty
1233 ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"),
1234                            nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]
1235 \end{code}