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