ghc/compiler/typecheck/TcRnDriver.lhs

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