ghc/compiler/typecheck/TcRnDriver.lhs

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