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