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