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