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