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