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