ghc/compiler/typecheck/TcRnDriver.lhs

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