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