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