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         mkGlobalContext, getModuleContents, tcRnStmt, tcRnThing, tcRnExpr,
  10 #endif
  11         tcRnModule, checkOldIface,
  12         importSupportingDecls, tcTopSrcDecls,
  13         tcRnIface, tcRnExtCore
  14     ) where
  15
  16 #include "HsVersions.h"
  17
  18 #ifdef GHCI
  19 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
  20 import                DsMeta   ( templateHaskellNames )
  21 #endif
  22
  23 import CmdLineOpts      ( DynFlag(..), opt_PprStyle_Debug, dopt )
  24 import DriverState      ( v_MainModIs, v_MainFunIs )
  25 import DriverUtil       ( split_longest_prefix )
  26 import HsSyn            ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..),
  27                           Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..),
  28                           HsGroup(..), SpliceDecl(..),
  29                           mkSimpleMatch, placeHolderType, toHsType, andMonoBinds,
  30                           isSrcRule, collectStmtsBinders
  31                         )
  32 import RdrHsSyn         ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr,
  33                           emptyGroup, mkGroup, findSplice, addImpDecls, main_RDR_Unqual )
  34
  35 import PrelNames        ( iNTERACTIVE, ioTyConName, printName,
  36                           returnIOName, bindIOName, failIOName, thenIOName, runIOName,
  37                           dollarMainName, itName, mAIN_Name, unsafeCoerceName
  38                         )
  39 import MkId             ( unsafeCoerceId )
  40 import RdrName          ( RdrName, getRdrName, mkRdrUnqual,
  41                           lookupRdrEnv, elemRdrEnv )
  42
  43 import RnHsSyn          ( RenamedStmt, RenamedTyClDecl,
  44                           ruleDeclFVs, instDeclFVs, tyClDeclFVs )
  45 import TcHsSyn          ( TypecheckedHsExpr, TypecheckedRuleDecl,
  46                           zonkTopDecls, mkHsLet,
  47                           zonkTopExpr, zonkTopBndrs
  48                         )
  49
  50 import TcExpr           ( tcInferRho, tcCheckRho )
  51 import TcRnMonad
  52 import TcMType          ( newTyVarTy, zonkTcType )
  53 import TcType           ( Type, liftedTypeKind,
  54                           tyVarsOfType, tcFunResultTy, tidyTopType,
  55                           mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys
  56                         )
  57 import TcMatches        ( tcStmtsAndThen, TcStmtCtxt(..) )
  58 import Inst             ( showLIE )
  59 import TcBinds          ( tcTopBinds )
  60 import TcClassDcl       ( tcClassDecls2 )
  61 import TcDefaults       ( tcDefaults )
  62 import TcEnv            ( tcExtendGlobalValEnv,
  63                           tcExtendInstEnv, tcExtendRules,
  64                           tcLookupTyCon, tcLookupGlobal,
  65                           tcLookupId
  66                         )
  67 import TcRules          ( tcRules )
  68 import TcForeign        ( tcForeignImports, tcForeignExports )
  69 import TcIfaceSig       ( tcInterfaceSigs, tcCoreBinds )
  70 import TcInstDcls       ( tcInstDecls1, tcIfaceInstDecls, tcInstDecls2 )
  71 import TcSimplify       ( tcSimplifyTop, tcSimplifyInfer )
  72 import TcTyClsDecls     ( tcTyAndClassDecls )
  73
  74 import RnNames          ( importsFromLocalDecls, rnImports, exportsFromAvail,
  75                           reportUnusedNames )
  76 import RnIfaces         ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate )
  77 import RnHiFiles        ( readIface, loadOldIface )
  78 import RnEnv            ( lookupSrcName, lookupOccRn, plusGlobalRdrEnv,
  79                           ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs )
  80 import RnExpr           ( rnStmts, rnExpr )
  81 import RnSource         ( rnSrcDecls, checkModDeprec, rnStats )
  82
  83 import CoreUnfold       ( unfoldingTemplate )
  84 import CoreSyn          ( IdCoreRule, Bind(..) )
  85 import PprCore          ( pprIdRules, pprCoreBindings )
  86 import TysWiredIn       ( mkListTy, unitTy )
  87 import ErrUtils         ( mkDumpDoc, showPass, pprBagOfErrors )
  88 import Id               ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported )
  89 import IdInfo           ( GlobalIdDetails(..) )
  90 import Var              ( Var, setGlobalIdDetails )
  91 import Module           ( Module, ModuleName, mkHomeModule, mkModuleName, moduleName, moduleUserString, moduleEnvElts )
  92 import OccName          ( mkVarOcc )
  93 import Name             ( Name, isExternalName, getSrcLoc, nameOccName )
  94 import NameEnv          ( delListFromNameEnv )
  95 import NameSet
  96 import TyCon            ( tyConGenInfo )
  97 import BasicTypes       ( EP(..), RecFlag(..) )
  98 import SrcLoc           ( noSrcLoc )
  99 import Outputable
 100 import HscTypes         ( PersistentCompilerState(..), InteractiveContext(..),
 101                           ModIface, ModDetails(..), ModGuts(..),
 102                           HscEnv(..),
 103                           ModIface(..), ModDetails(..), IfaceDecls(..),
 104                           GhciMode(..), noDependencies,
 105                           Deprecations(..), plusDeprecs,
 106                           emptyGlobalRdrEnv,
 107                           GenAvailInfo(Avail), availsToNameSet,
 108                           ForeignStubs(..),
 109                           TypeEnv, TyThing, typeEnvTyCons,
 110                           extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
 111                           extendLocalRdrEnv, emptyFixityEnv
 112                         )
 113 #ifdef GHCI
 114 import RdrName          ( rdrEnvElts )
 115 import RnHiFiles        ( loadInterface )
 116 import RnEnv            ( mkGlobalRdrEnv )
 117 import HscTypes         ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(..),
 118                           isLocalGRE )
 119 #endif
 120
 121 import DATA_IOREF       ( readIORef )
 122 import FastString       ( mkFastString )
 123 import Panic            ( showException )
 124 import List             ( partition )
 125 import Util             ( sortLt )
 126 \end{code}
 127
 128
 129
 130 %************************************************************************
 131 %*                                                                      *
 132         Typecheck and rename a module
 133 %*                                                                      *
 134 %************************************************************************
 135
 136
 137 \begin{code}
 138 tcRnModule :: HscEnv -> PersistentCompilerState
 139            -> RdrNameHsModule
 140            -> IO (PersistentCompilerState, Maybe TcGblEnv)
 141
 142 tcRnModule hsc_env pcs
 143            (HsModule maybe_mod exports import_decls local_decls mod_deprec loc)
 144  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 145
 146    let { this_mod = case maybe_mod of
 147                         Nothing  -> mkHomeModule mAIN_Name      -- 'module M where' is omitted
 148                         Just mod -> mod } ;                     -- The normal case
 149
 150    initTc hsc_env pcs this_mod $ addSrcLoc loc $
 151    do {         -- Deal with imports; sets tcg_rdr_env, tcg_imports
 152         (rdr_env, imports) <- rnImports import_decls ;
 153         updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
 154                                    tcg_imports = tcg_imports gbl `plusImportAvails` imports })
 155                      $ do {
 156         traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
 157                 -- Fail if there are any errors so far
 158                 -- The error printing (if needed) takes advantage
 159                 -- of the tcg_env we have now set
 160         failIfErrsM ;
 161
 162         traceRn (text "rn1a") ;
 163                 -- Rename and type check the declarations
 164         (tcg_env, src_dus) <- tcRnSrcDecls local_decls ;
 165         setGblEnv tcg_env               $ do {
 166
 167         traceRn (text "rn3") ;
 168                 -- Check whether the entire module is deprecated
 169                 -- This happens only once per module
 170                 -- Returns the full new deprecations; a module deprecation
 171                 --      over-rides the earlier ones
 172         let { mod_deprecs = checkModDeprec mod_deprec } ;
 173         updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` mod_deprecs })
 174                   $ do {
 175
 176                 -- Process the export list
 177         export_avails <- exportsFromAvail maybe_mod exports ;
 178         updGblEnv (\gbl -> gbl { tcg_exports = export_avails })
 179                   $  do {
 180
 181                 -- Get any supporting decls for the exports that have not already
 182                 -- been sucked in for the declarations in the body of the module.
 183                 -- (This can happen if something is imported only to be re-exported.)
 184                 --
 185                 -- Importing these supporting declarations is required
 186                 --      *only* to gether usage information
 187                 --      (see comments with MkIface.mkImportInfo for why)
 188                 -- For OneShot compilation we could just throw away the decls
 189                 -- but for Batch or Interactive we must put them in the type
 190                 -- envt because they've been removed from the holding pen
 191         let { export_fvs = availsToNameSet export_avails } ;
 192         tcg_env <- importSupportingDecls export_fvs ;
 193         setGblEnv tcg_env $ do {
 194
 195                 -- Report unused names
 196         let { all_dus = src_dus `plusDU` usesOnly export_fvs } ;
 197         reportUnusedNames tcg_env all_dus ;
 198
 199                 -- Dump output and return
 200         tcDump tcg_env ;
 201         return tcg_env
 202     }}}}}}}
 203 \end{code}
 204
 205
 206 %*********************************************************
 207 %*                                                       *
 208 \subsection{Closing up the interface decls}
 209 %*                                                       *
 210 %*********************************************************
 211
 212 Suppose we discover we don't need to recompile.   Then we start from the
 213 IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need.
 214
 215 \begin{code}
 216 tcRnIface :: HscEnv
 217           -> PersistentCompilerState
 218           -> ModIface   -- Get the decls from here
 219           -> IO (PersistentCompilerState, Maybe ModDetails)
 220                                 -- Nothing <=> errors happened
 221 tcRnIface hsc_env pcs
 222             (ModIface {mi_module = mod, mi_decls = iface_decls})
 223   = initTc hsc_env pcs mod $ do {
 224
 225         -- Get the supporting decls, and typecheck them all together
 226         -- so that any mutually recursive types are done right
 227     extra_decls <- slurpImpDecls needed ;
 228     env <- typecheckIfaceDecls (group `addImpDecls` extra_decls) ;
 229
 230     returnM (ModDetails { md_types = tcg_type_env env,
 231                           md_insts = tcg_insts env,
 232                           md_rules = hsCoreRules (tcg_rules env)
 233                   -- All the rules from an interface are of the IfaceRuleOut form
 234                  }) }
 235   where
 236         rule_decls = dcl_rules iface_decls
 237         inst_decls = dcl_insts iface_decls
 238         tycl_decls = dcl_tycl  iface_decls
 239         group = emptyGroup { hs_ruleds = rule_decls,
 240                              hs_instds = inst_decls,
 241                              hs_tyclds = tycl_decls }
 242         needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets`
 243                  unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets`
 244                  unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets`
 245                  ubiquitousNames
 246                         -- Data type decls with record selectors,
 247                         -- which may appear in the decls, need unpackCString
 248                         -- and friends. It's easier to just grab them right now.
 249
 250 hsCoreRules :: [TypecheckedRuleDecl] -> [IdCoreRule]
 251 -- All post-typechecking Iface rules have the form IfaceRuleOut
 252 hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules]
 253 \end{code}
 254
 255
 256 %************************************************************************
 257 %*                                                                      *
 258                 The interactive interface
 259 %*                                                                      *
 260 %************************************************************************
 261
 262 \begin{code}
 263 #ifdef GHCI
 264 tcRnStmt :: HscEnv -> PersistentCompilerState
 265          -> InteractiveContext
 266          -> RdrNameStmt
 267          -> IO (PersistentCompilerState,
 268                 Maybe (InteractiveContext, [Name], TypecheckedHsExpr))
 269                 -- The returned [Name] is the same as the input except for
 270                 -- ExprStmt, in which case the returned [Name] is [itName]
 271                 --
 272                 -- The returned TypecheckedHsExpr is of type IO [ () ],
 273                 -- a list of the bound values, coerced to ().
 274
 275 tcRnStmt hsc_env pcs ictxt rdr_stmt
 276   = initTc hsc_env pcs iNTERACTIVE $
 277     setInteractiveContext ictxt $ do {
 278
 279     -- Rename; use CmdLineMode because tcRnStmt is only used interactively
 280     ([rn_stmt], fvs) <- initRnInteractive ictxt
 281                                         (rnStmts DoExpr [rdr_stmt]) ;
 282     traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
 283     failIfErrsM ;
 284
 285     -- Suck in the supporting declarations and typecheck them
 286     tcg_env <- importSupportingDecls (fvs `plusFV` implicitStmtFVs fvs) ;
 287         -- NB: an earlier version deleted (rdrEnvElts local_env) from
 288         --     the fvs.  But (a) that isn't necessary, because previously
 289         --     bound things in the local_env will be in the TypeEnv, and
 290         --     the renamer doesn't re-slurp such things, and
 291         -- (b) it's WRONG to delete them. Consider in GHCi:
 292         --        Mod> let x = e :: T
 293         --        Mod> let y = x + 3
 294         --     We need to pass 'x' among the fvs to slurpImpDecls, so that
 295         --     the latter can see that T is a gate, and hence import the Num T
 296         --     instance decl.  (See the InTypEnv case in RnIfaces.slurpSourceRefs.)
 297     setGblEnv tcg_env $ do {
 298
 299     -- The real work is done here
 300     ((bound_ids, tc_expr), lie) <- getLIE (tcUserStmt rn_stmt) ;
 301
 302     traceTc (text "tcs 1") ;
 303     let {       -- Make all the bound ids "global" ids, now that
 304                 -- they're notionally top-level bindings.  This is
 305                 -- important: otherwise when we come to compile an expression
 306                 -- using these ids later, the byte code generator will consider
 307                 -- the occurrences to be free rather than global.
 308         global_ids     = map globaliseId bound_ids ;
 309         globaliseId id = setGlobalIdDetails id VanillaGlobal ;
 310
 311                 -- Update the interactive context
 312         rn_env   = ic_rn_local_env ictxt ;
 313         type_env = ic_type_env ictxt ;
 314
 315         bound_names = map idName global_ids ;
 316         new_rn_env  = extendLocalRdrEnv rn_env bound_names ;
 317
 318                 -- Remove any shadowed bindings from the type_env;
 319                 -- they are inaccessible but might, I suppose, cause
 320                 -- a space leak if we leave them there
 321         shadowed = [ n | name <- bound_names,
 322                          let rdr_name = mkRdrUnqual (nameOccName name),
 323                          Just n <- [lookupRdrEnv rn_env rdr_name] ] ;
 324
 325         filtered_type_env = delListFromNameEnv type_env shadowed ;
 326         new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
 327
 328         new_ic = ictxt { ic_rn_local_env = new_rn_env,
 329                          ic_type_env     = new_type_env }
 330     } ;
 331
 332     dumpOptTcRn Opt_D_dump_tc
 333         (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
 334                text "Typechecked expr" <+> ppr tc_expr]) ;
 335
 336     returnM (new_ic, bound_names, tc_expr)
 337     }}
 338 \end{code}
 339
 340
 341 Here is the grand plan, implemented in tcUserStmt
 342
 343         What you type                   The IO [HValue] that hscStmt returns
 344         -------------                   ------------------------------------
 345         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 346                                         bindings: [x,y,...]
 347
 348         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 349                                         bindings: [x,y,...]
 350
 351         expr (of IO type)       ==>     expr >>= \ v -> return [coerce HVal v]
 352           [NB: result not printed]      bindings: [it]
 353
 354         expr (of non-IO type,   ==>     let v = expr in print v >> return [coerce HVal v]
 355           result showable)              bindings: [it]
 356
 357         expr (of non-IO type,
 358           result not showable)  ==>     error
 359
 360
 361 \begin{code}
 362 ---------------------------
 363 tcUserStmt :: RenamedStmt -> TcM ([Id], TypecheckedHsExpr)
 364 tcUserStmt (ExprStmt expr _ loc)
 365   = newUnique           `thenM` \ uniq ->
 366     let
 367         fresh_it = itName uniq
 368         the_bind = FunMonoBind fresh_it False
 369                         [ mkSimpleMatch [] expr placeHolderType loc ] loc
 370     in
 371     tryTcLIE_ (do {     -- Try this if the other fails
 372                 traceTc (text "tcs 1b") ;
 373                 tc_stmts [
 374                     LetStmt (MonoBind the_bind [] NonRecursive),
 375                     ExprStmt (HsApp (HsVar printName) (HsVar fresh_it))
 376                              placeHolderType loc] })
 377           (do {         -- Try this first
 378                 traceTc (text "tcs 1a") ;
 379                 tc_stmts [BindStmt (VarPat fresh_it) expr loc] })
 380
 381 tcUserStmt stmt = tc_stmts [stmt]
 382
 383 ---------------------------
 384 tc_stmts stmts
 385  = do { ioTyCon <- tcLookupTyCon ioTyConName ;
 386         let {
 387             ret_ty = mkListTy unitTy ;
 388             names  = collectStmtsBinders stmts ;
 389
 390             stmt_ctxt = SC { sc_what = DoExpr,
 391                              sc_rhs  = check_rhs,
 392                              sc_body = check_body,
 393                              sc_ty   = ret_ty } ;
 394
 395             check_rhs rhs rhs_ty = tcCheckRho rhs  (mkTyConApp ioTyCon [rhs_ty]) ;
 396             check_body body      = tcCheckRho body (mkTyConApp ioTyCon [ret_ty]) ;
 397
 398                 -- ret_expr is the expression
 399                 --      returnIO [coerce () x, ..,  coerce () z]
 400             ret_stmt = ResultStmt ret_expr noSrcLoc ;
 401             ret_expr = HsApp (HsVar returnIOName)
 402                              (ExplicitList placeHolderType (map mk_item names)) ;
 403             mk_item name = HsApp (HsVar unsafeCoerceName) (HsVar name) ;
 404
 405             all_stmts = stmts ++ [ret_stmt]
 406          } ;
 407
 408         -- OK, we're ready to typecheck the stmts
 409         traceTc (text "tcs 2") ;
 410         ((ids, tc_stmts), lie) <-
 411                 getLIE                                          $
 412                 tcStmtsAndThen combine stmt_ctxt all_stmts      $
 413                 do {
 414                     -- Look up the names right in the middle,
 415                     -- where they will all be in scope
 416                     ids <- mappM tcLookupId names ;
 417                     return (ids, [])
 418                 } ;
 419
 420         -- Simplify the context right here, so that we fail
 421         -- if there aren't enough instances.  Notably, when we see
 422         --              e
 423         -- we use recoverTc_ to try     it <- e
 424         -- and then                     let it = e
 425         -- It's the simplify step that rejects the first.
 426         traceTc (text "tcs 3") ;
 427         const_binds <- tcSimplifyTop lie ;
 428
 429         -- Build result expression and zonk it
 430         io_ids <- mappM mk_rebound
 431                         [returnIOName, failIOName, bindIOName, thenIOName] ;
 432         let { expr = mkHsLet const_binds $
 433                      HsDo DoExpr tc_stmts io_ids
 434                           (mkTyConApp ioTyCon [ret_ty]) noSrcLoc } ;
 435         zonked_expr <- zonkTopExpr expr ;
 436         zonked_ids  <- zonkTopBndrs ids ;
 437
 438         return (zonked_ids, zonked_expr)
 439         }
 440   where
 441     combine stmt (ids, stmts) = (ids, stmt:stmts)
 442     mk_rebound n = do { id <- tcLookupId n; return (n, HsVar id) }
 443         -- A bit hackoid
 444 \end{code}
 445
 446
 447 tcRnExpr just finds the type of an expression
 448
 449 \begin{code}
 450 tcRnExpr :: HscEnv -> PersistentCompilerState
 451          -> InteractiveContext
 452          -> RdrNameHsExpr
 453          -> IO (PersistentCompilerState, Maybe Type)
 454 tcRnExpr hsc_env pcs ictxt rdr_expr
 455   = initTc hsc_env pcs iNTERACTIVE $
 456     setInteractiveContext ictxt $ do {
 457
 458     (rn_expr, fvs) <- initRnInteractive ictxt (rnExpr rdr_expr) ;
 459     failIfErrsM ;
 460
 461         -- Suck in the supporting declarations and typecheck them
 462     tcg_env <- importSupportingDecls (fvs `plusFV` ubiquitousNames) ;
 463     setGblEnv tcg_env $ do {
 464
 465         -- Now typecheck the expression;
 466         -- it might have a rank-2 type (e.g. :t runST)
 467     ((tc_expr, res_ty), lie)       <- getLIE (tcInferRho rn_expr) ;
 468     ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie)  ;
 469     tcSimplifyTop lie_top ;
 470
 471     let { all_expr_ty = mkForAllTys qtvs                $
 472                         mkFunTys (map idType dict_ids)  $
 473                         res_ty } ;
 474     zonkTcType all_expr_ty
 475     }}
 476   where
 477     smpl_doc = ptext SLIT("main expression")
 478 \end{code}
 479
 480
 481 \begin{code}
 482 tcRnThing :: HscEnv -> PersistentCompilerState
 483           -> InteractiveContext
 484           -> RdrName
 485           -> IO (PersistentCompilerState, Maybe [TyThing])
 486 -- Look up a RdrName and return all the TyThings it might be
 487 -- We treat a capitalised RdrName as both a data constructor
 488 -- and as a type or class constructor; hence we return up to two results
 489 tcRnThing hsc_env pcs ictxt rdr_name
 490   = initTc hsc_env pcs iNTERACTIVE $
 491     setInteractiveContext ictxt $ do {
 492
 493         -- If the identifier is a constructor (begins with an
 494         -- upper-case letter), then we need to consider both
 495         -- constructor and type class identifiers.
 496     let { rdr_names = dataTcOccs rdr_name } ;
 497
 498         -- results :: [(Messages, Maybe Name)]
 499     results <- initRnInteractive ictxt
 500                             (mapM (tryTc . lookupOccRn) rdr_names) ;
 501
 502         -- The successful lookups will be (Just name)
 503     let { (warns_s, good_names) = unzip [ (msgs, name)
 504                                         | (msgs, Just name) <- results] ;
 505           errs_s = [msgs | (msgs, Nothing) <- results] } ;
 506
 507         -- Fail if nothing good happened, else add warnings
 508     if null good_names then     -- Fail
 509         do { addMessages (head errs_s) ; failM }
 510       else                      -- Add deprecation warnings
 511         mapM_ addMessages warns_s ;
 512
 513         -- Slurp in the supporting declarations
 514     tcg_env <- importSupportingDecls (mkFVs good_names) ;
 515     setGblEnv tcg_env $ do {
 516
 517         -- And lookup up the entities
 518     mapM tcLookupGlobal good_names
 519     }}
 520 \end{code}
 521
 522
 523 \begin{code}
 524 setInteractiveContext :: InteractiveContext -> TcRn m a -> TcRn m a
 525 setInteractiveContext icxt thing_inside
 526   = traceTc (text "setIC" <+> ppr (ic_type_env icxt))   `thenM_`
 527     updGblEnv (\ env -> env { tcg_rdr_env  = ic_rn_gbl_env icxt,
 528                               tcg_type_env = ic_type_env   icxt })
 529               thing_inside
 530
 531 initRnInteractive :: InteractiveContext -> RnM a -> TcM a
 532 -- Set the local RdrEnv from the interactive context
 533 initRnInteractive ictxt rn_thing
 534   = initRn CmdLineMode $
 535     setLocalRdrEnv (ic_rn_local_env ictxt) $
 536     rn_thing
 537 #endif
 538 \end{code}
 539
 540 %************************************************************************
 541 %*                                                                      *
 542         Type-checking external-core modules
 543 %*                                                                      *
 544 %************************************************************************
 545
 546 \begin{code}
 547 tcRnExtCore :: HscEnv -> PersistentCompilerState
 548             -> RdrNameHsModule
 549             -> IO (PersistentCompilerState, Maybe ModGuts)
 550         -- Nothing => some error occurred
 551
 552 tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc)
 553         -- For external core, the module name is syntactically reqd
 554         -- Rename the (Core) module.  It's a bit like an interface
 555         -- file: all names are original names
 556  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 557
 558    initTc hsc_env pcs this_mod $ addSrcLoc loc $ do {
 559
 560         -- Rename the source, only in interface mode.
 561         -- rnSrcDecls handles fixity decls etc too, which won't occur
 562         -- but that doesn't matter
 563    let { local_group = mkGroup decls } ;
 564    (_, rn_decls, dus) <- initRn (InterfaceMode this_mod)
 565                                       (rnSrcDecls local_group) ;
 566    failIfErrsM ;
 567
 568         -- Get the supporting decls
 569    rn_imp_decls <- slurpImpDecls (duUses dus) ;
 570    let { rn_decls = rn_decls `addImpDecls` rn_imp_decls } ;
 571
 572         -- Dump trace of renaming part
 573    rnDump (ppr rn_decls) ;
 574    rnStats rn_imp_decls ;
 575
 576         -- Typecheck them all together so that
 577         -- any mutually recursive types are done right
 578    tcg_env <- typecheckIfaceDecls rn_decls ;
 579    setGblEnv tcg_env $ do {
 580
 581         -- Now the core bindings
 582    core_prs <- tcCoreBinds (hs_coreds rn_decls) ;
 583    tcExtendGlobalValEnv (map fst core_prs) $ do {
 584
 585         -- Wrap up
 586    let {
 587         bndrs      = map fst core_prs ;
 588         my_exports = map (Avail . idName) bndrs ;
 589                 -- ToDo: export the data types also?
 590
 591         final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
 592
 593         mod_guts = ModGuts {    mg_module   = this_mod,
 594                                 mg_usages   = [],               -- ToDo: compute usage
 595                                 mg_dir_imps = [],               -- ??
 596                                 mg_deps     = noDependencies,   -- ??
 597                                 mg_exports  = my_exports,
 598                                 mg_types    = final_type_env,
 599                                 mg_insts    = tcg_insts tcg_env,
 600                                 mg_rules    = hsCoreRules (tcg_rules tcg_env),
 601                                 mg_binds    = [Rec core_prs],
 602
 603                                 -- Stubs
 604                                 mg_rdr_env  = emptyGlobalRdrEnv,
 605                                 mg_fix_env  = emptyFixityEnv,
 606                                 mg_deprecs  = NoDeprecs,
 607                                 mg_foreign  = NoStubs
 608                     } } ;
 609
 610    tcCoreDump mod_guts ;
 611
 612    return mod_guts
 613    }}}}
 614 \end{code}
 615
 616
 617 %************************************************************************
 618 %*                                                                      *
 619         Type-checking the top level of a module
 620 %*                                                                      *
 621 %************************************************************************
 622
 623 \begin{code}
 624 tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, DefUses)
 625         -- Returns the variables free in the decls
 626         -- Reason: solely to report unused imports and bindings
 627 tcRnSrcDecls decls
 628  = do {         -- Do all the declarations
 629         ((tc_envs, dus), lie) <- getLIE (tc_rn_src_decls decls) ;
 630
 631              -- tcSimplifyTop deals with constant or ambiguous InstIds.
 632              -- How could there be ambiguous ones?  They can only arise if a
 633              -- top-level decl falls under the monomorphism
 634              -- restriction, and no subsequent decl instantiates its
 635              -- type.  (Usually, ambiguous type variables are resolved
 636              -- during the generalisation step.)
 637         traceTc (text "Tc8") ;
 638         setEnvs tc_envs         $ do {
 639                 -- Setting the global env exposes the instances to tcSimplifyTop
 640                 -- Setting the local env exposes the local Ids, so that
 641                 -- we get better error messages (monomorphism restriction)
 642         inst_binds <- tcSimplifyTop lie ;
 643
 644             -- Backsubstitution.  This must be done last.
 645             -- Even tcSimplifyTop may do some unification.
 646         traceTc (text "Tc9") ;
 647         let { (tcg_env, _) = tc_envs ;
 648               TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
 649                          tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
 650
 651         (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
 652                                                            rules fords ;
 653
 654         return (tcg_env { tcg_type_env = extendTypeEnvWithIds type_env bind_ids,
 655                           tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' },
 656                 dus)
 657     }}
 658
 659 tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), DefUses)
 660
 661 tc_rn_src_decls ds
 662  = do { let { (first_group, group_tail) = findSplice ds } ;
 663                 -- If ds is [] we get ([], Nothing)
 664
 665         -- Type check the decls up to, but not including, the first splice
 666         (tc_envs@(_,tcl_env), src_dus1) <- tcRnGroup first_group ;
 667
 668         -- Bale out if errors; for example, error recovery when checking
 669         -- the RHS of 'main' can mean that 'main' is not in the envt for
 670         -- the subsequent checkMain test
 671         failIfErrsM ;
 672
 673         setEnvs tc_envs $
 674
 675         -- If there is no splice, we're nearly done
 676         case group_tail of {
 677            Nothing -> do {      -- Last thing: check for `main'
 678                            (tcg_env, main_fvs) <- checkMain ;
 679                            return ((tcg_env, tcl_env),
 680                                     src_dus1 `plusDU` usesOnly main_fvs)
 681                       } ;
 682
 683         -- If there's a splice, we must carry on
 684            Just (SpliceDecl splice_expr splice_loc, rest_ds) -> do {
 685 #ifndef GHCI
 686         failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
 687 #else
 688
 689         -- Rename the splice expression, and get its supporting decls
 690         (rn_splice_expr, splice_fvs) <- initRn SourceMode $
 691                                         addSrcLoc splice_loc $
 692                                         rnExpr splice_expr ;
 693         tcg_env <- importSupportingDecls (splice_fvs `plusFV` templateHaskellNames) ;
 694         setGblEnv tcg_env $ do {
 695
 696         -- Execute the splice
 697         spliced_decls <- tcSpliceDecls rn_splice_expr ;
 698
 699         -- Glue them on the front of the remaining decls and loop
 700         (tc_envs, src_dus2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ;
 701
 702         return (tc_envs, src_dus1 `plusDU` usesOnly splice_fvs `plusDU` src_dus2)
 703     }
 704 #endif /* GHCI */
 705     }}}
 706 \end{code}
 707
 708
 709 %************************************************************************
 710 %*                                                                      *
 711         Type-checking the top level of a module
 712 %*                                                                      *
 713 %************************************************************************
 714
 715 tcRnGroup takes a bunch of top-level source-code declarations, and
 716  * renames them
 717  * gets supporting declarations from interface files
 718  * typechecks them
 719  * zonks them
 720  * and augments the TcGblEnv with the results
 721
 722 In Template Haskell it may be called repeatedly for each group of
 723 declarations.  It expects there to be an incoming TcGblEnv in the
 724 monad; it augments it and returns the new TcGblEnv.
 725
 726 \begin{code}
 727 tcRnGroup :: HsGroup RdrName -> TcM ((TcGblEnv, TcLclEnv), DefUses)
 728         -- Returns the variables free in the decls, for unused-binding reporting
 729 tcRnGroup decls
 730  = do {         -- Rename the declarations
 731         (tcg_env, rn_decls, src_dus) <- rnTopSrcDecls decls ;
 732         setGblEnv tcg_env $ do {
 733
 734                 -- Typecheck the declarations
 735         tc_envs <- tcTopSrcDecls rn_decls ;
 736
 737         return (tc_envs, src_dus)
 738   }}
 739
 740 ------------------------------------------------
 741 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, DefUses)
 742 rnTopSrcDecls group
 743  = do {         -- Bring top level binders into scope
 744         (rdr_env, imports) <- importsFromLocalDecls group ;
 745         updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv`
 746                                                   tcg_rdr_env gbl,
 747                                  tcg_imports = imports `plusImportAvails`
 748                                                   tcg_imports gbl })
 749                      $ do {
 750
 751         failIfErrsM ;   -- No point in continuing if (say) we have duplicate declarations
 752
 753                 -- Rename the source decls
 754         (tcg_env, rn_src_decls, src_dus) <- initRn SourceMode (rnSrcDecls group) ;
 755         setGblEnv tcg_env $ do {
 756
 757         failIfErrsM ;
 758
 759                 -- Import consquential imports
 760         let { src_fvs = duUses src_dus } ;
 761         rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ;
 762         let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ;
 763
 764                 -- Dump trace of renaming part
 765         rnDump (ppr rn_decls) ;
 766         rnStats rn_imp_decls ;
 767
 768         return (tcg_env, rn_decls, src_dus)
 769   }}}
 770
 771 ------------------------------------------------
 772 tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
 773 tcTopSrcDecls
 774         (HsGroup { hs_tyclds = tycl_decls,
 775                    hs_instds = inst_decls,
 776                    hs_fords  = foreign_decls,
 777                    hs_defds  = default_decls,
 778                    hs_ruleds = rule_decls,
 779                    hs_valds  = val_binds })
 780  = do {         -- Type-check the type and class decls, and all imported decls
 781                 -- The latter come in via tycl_decls
 782         traceTc (text "Tc2") ;
 783         tcg_env <- tcTyClDecls tycl_decls ;
 784         setGblEnv tcg_env       $ do {
 785
 786                 -- Source-language instances, including derivings,
 787                 -- and import the supporting declarations
 788         traceTc (text "Tc3") ;
 789         (tcg_env, inst_infos, deriv_binds, fvs) <- tcInstDecls1 tycl_decls inst_decls ;
 790         setGblEnv tcg_env       $ do {
 791         tcg_env <- importSupportingDecls fvs ;
 792         setGblEnv tcg_env       $ do {
 793
 794                 -- Foreign import declarations next.  No zonking necessary
 795                 -- here; we can tuck them straight into the global environment.
 796         traceTc (text "Tc4") ;
 797         (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
 798         tcExtendGlobalValEnv fi_ids                  $
 799         updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls })
 800                   $ do {
 801
 802                 -- Default declarations
 803         traceTc (text "Tc4a") ;
 804         default_tys <- tcDefaults default_decls ;
 805         updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
 806
 807                 -- Value declarations next
 808                 -- We also typecheck any extra binds that came out
 809                 -- of the "deriving" process
 810         traceTc (text "Tc5") ;
 811         (tc_val_binds, lcl_env) <- tcTopBinds (val_binds `ThenBinds` deriv_binds) ;
 812         setLclTypeEnv lcl_env   $ do {
 813
 814                 -- Second pass over class and instance declarations,
 815                 -- plus rules and foreign exports, to generate bindings
 816         traceTc (text "Tc6") ;
 817         (cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ;
 818         tcExtendGlobalValEnv dm_ids     $ do {
 819         inst_binds <- tcInstDecls2 inst_infos ;
 820         showLIE (text "after instDecls2") ;
 821
 822                 -- Foreign exports
 823                 -- They need to be zonked, so we return them
 824         traceTc (text "Tc7") ;
 825         (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
 826
 827                 -- Rules
 828                 -- Need to partition them because the source rules
 829                 -- must be zonked before adding them to tcg_rules
 830                 -- NB: built-in rules come in as IfaceRuleOut's, and
 831                 --     get added to tcg_rules right here by tcExtendRules
 832         rules <- tcRules rule_decls ;
 833         let { (src_rules, iface_rules) = partition isSrcRule rules } ;
 834         tcExtendRules iface_rules $ do {
 835
 836                 -- Wrap up
 837         tcg_env <- getGblEnv ;
 838         let { all_binds = tc_val_binds   `AndMonoBinds`
 839                           inst_binds     `AndMonoBinds`
 840                           cls_dm_binds   `AndMonoBinds`
 841                           foe_binds  ;
 842
 843                 -- Extend the GblEnv with the (as yet un-zonked)
 844                 -- bindings, rules, foreign decls
 845               tcg_env' = tcg_env {  tcg_binds = tcg_binds tcg_env `andMonoBinds` all_binds,
 846                                     tcg_rules = tcg_rules tcg_env ++ src_rules,
 847                                     tcg_fords = tcg_fords tcg_env ++ foe_decls } } ;
 848
 849         return (tcg_env', lcl_env)
 850      }}}}}}}}}
 851 \end{code}
 852
 853 \begin{code}
 854 tcTyClDecls :: [RenamedTyClDecl]
 855             -> TcM TcGblEnv
 856
 857 -- tcTyClDecls deals with
 858 --      type and class decls (some source, some imported)
 859 --      interface signatures (checked lazily)
 860 --
 861 -- It returns the TcGblEnv for this module, and side-effects the
 862 -- persistent compiler state to reflect the things imported from
 863 -- other modules
 864
 865 tcTyClDecls tycl_decls
 866   = checkNoErrs $
 867         -- tcTyAndClassDecls recovers internally, but if anything gave rise to
 868         -- an error we'd better stop now, to avoid a cascade
 869
 870     traceTc (text "TyCl1")              `thenM_`
 871     tcTyAndClassDecls tycl_decls        `thenM` \ tcg_env ->
 872         -- Returns the extended environment
 873     setGblEnv tcg_env                   $
 874
 875     traceTc (text "TyCl2")              `thenM_`
 876     tcInterfaceSigs tycl_decls          `thenM` \ tcg_env ->
 877         -- Returns the extended environment
 878
 879     returnM tcg_env
 880 \end{code}
 881
 882
 883
 884 %************************************************************************
 885 %*                                                                      *
 886         Load the old interface file for this module (unless
 887         we have it aleady), and check whether it is up to date
 888
 889 %*                                                                      *
 890 %************************************************************************
 891
 892 \begin{code}
 893 checkOldIface :: HscEnv
 894               -> PersistentCompilerState
 895               -> Module
 896               -> FilePath               -- Where the interface file is
 897               -> Bool                   -- Source unchanged
 898               -> Maybe ModIface         -- Old interface from compilation manager, if any
 899               -> IO (PersistentCompilerState, Maybe (RecompileRequired, Maybe ModIface))
 900                                 -- Nothing <=> errors happened
 901
 902 checkOldIface hsc_env pcs mod iface_path source_unchanged maybe_iface
 903   = do { showPass (hsc_dflags hsc_env)
 904                   ("Checking old interface for " ++ moduleUserString mod) ;
 905
 906          initTc hsc_env pcs mod
 907                 (check_old_iface iface_path source_unchanged maybe_iface)
 908      }
 909
 910 check_old_iface iface_path source_unchanged maybe_iface
 911  =      -- CHECK WHETHER THE SOURCE HAS CHANGED
 912     ifM (not source_unchanged)
 913         (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
 914                                                 `thenM_`
 915
 916      -- If the source has changed and we're in interactive mode, avoid reading
 917      -- an interface; just return the one we might have been supplied with.
 918     getGhciMode                                 `thenM` \ ghci_mode ->
 919     if (ghci_mode == Interactive) && not source_unchanged then
 920          returnM (outOfDate, maybe_iface)
 921     else
 922
 923     case maybe_iface of {
 924        Just old_iface -> -- Use the one we already have
 925                          checkVersions source_unchanged old_iface       `thenM` \ recomp ->
 926                          returnM (recomp, Just old_iface)
 927
 928     ;  Nothing ->
 929
 930         -- Try and read the old interface for the current module
 931         -- from the .hi file left from the last time we compiled it
 932     getModule                                   `thenM` \ this_mod ->
 933     readIface this_mod iface_path False `thenM` \ read_result ->
 934     case read_result of {
 935        Left err ->      -- Old interface file not found, or garbled; give up
 936                    traceHiDiffs (text "FYI: cannot read old interface file:"
 937                                  $$ nest 4 (text (showException err)))  `thenM_`
 938                    returnM (outOfDate, Nothing)
 939
 940     ;  Right parsed_iface ->
 941
 942         -- We found the file and parsed it; now load it
 943     tryTc (initRn (InterfaceMode this_mod)
 944                   (loadOldIface parsed_iface))  `thenM` \ ((_,errs), mb_iface) ->
 945     case mb_iface of {
 946         Nothing ->      -- Something went wrong in loading.  The main likely thing
 947                         -- is that the usages mentioned B.f, where B.hi and B.hs no
 948                         -- longer exist.  Then newGlobalName2 fails with an error message
 949                         -- This isn't an error; we just don't have an old iface file to
 950                         -- look at.  Spit out a traceHiDiffs for info though.
 951                    traceHiDiffs (text "FYI: loading old interface file failed"
 952                                    $$ nest 4 (docToSDoc (pprBagOfErrors errs))) `thenM_`
 953                    return (outOfDate, Nothing)
 954
 955     ;   Just iface ->
 956
 957         -- At last, we have got the old iface; check its versions
 958     checkVersions source_unchanged iface        `thenM` \ recomp ->
 959     returnM (recomp, Just iface)
 960     }}}
 961 \end{code}
 962
 963
 964 %************************************************************************
 965 %*                                                                      *
 966         Type-check and rename supporting declarations
 967         This is used to deal with the free vars of a splice,
 968         or derived code: slurp in the necessary declarations,
 969         typecheck them, and add them to the EPS
 970 %*                                                                      *
 971 %************************************************************************
 972
 973 \begin{code}
 974 importSupportingDecls :: FreeVars -> TcM TcGblEnv
 975 -- Completely deal with the supporting imports needed
 976 -- by the specified free-var set
 977 importSupportingDecls fvs
 978  = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ;
 979         decls <- slurpImpDecls fvs ;
 980         traceRn (text "...namely:" <+> vcat (map ppr decls)) ;
 981         typecheckIfaceDecls (mkGroup decls) }
 982
 983 typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv
 984   -- The decls are all interface-file declarations
 985   -- Usually they are all from other modules, but when we are reading
 986   -- this module's interface from a file, it's possible that some of
 987   -- them are for the module being compiled.
 988   -- That is why the tcExtendX functions need to do partitioning.
 989   --
 990   -- If all the decls are from other modules, the returned TcGblEnv
 991   -- will have an empty tc_genv, but its tc_inst_env
 992   -- cache may have been augmented.
 993 typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls,
 994                                hs_instds = inst_decls,
 995                                hs_ruleds = rule_decls })
 996  = do {         -- Typecheck the type, class, and interface-sig decls
 997         tcg_env <- tcTyClDecls tycl_decls ;
 998         setGblEnv tcg_env               $ do {
 999
1000         -- Typecheck the instance decls, and rules
1001         -- Note that imported dictionary functions are already
1002         -- in scope from the preceding tcTyClDecls
1003         tcIfaceInstDecls inst_decls     `thenM` \ dfuns ->
1004         tcExtendInstEnv dfuns           $
1005         tcRules rule_decls              `thenM` \ rules ->
1006         tcExtendRules rules             $
1007
1008         getGblEnv               -- Return the environment
1009    }}
1010 \end{code}
1011
1012
1013
1014 %*********************************************************
1015 %*                                                       *
1016         mkGlobalContext: make up an interactive context
1017
1018         Used for initialising the lexical environment
1019         of the interactive read-eval-print loop
1020 %*                                                       *
1021 %*********************************************************
1022
1023 \begin{code}
1024 #ifdef GHCI
1025 mkGlobalContext
1026         :: HscEnv -> PersistentCompilerState
1027         -> [Module]     -- Expose these modules' top-level scope
1028         -> [Module]     -- Expose these modules' exports only
1029         -> IO (PersistentCompilerState, Maybe GlobalRdrEnv)
1030
1031 mkGlobalContext hsc_env pcs toplevs exports
1032   = initTc hsc_env pcs iNTERACTIVE $ do {
1033
1034     toplev_envs <- mappM getTopLevScope   toplevs ;
1035     export_envs <- mappM getModuleExports exports ;
1036     returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv
1037                    (toplev_envs ++ export_envs))
1038     }
1039
1040 getTopLevScope :: Module -> TcRn m GlobalRdrEnv
1041 getTopLevScope mod
1042   = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1043          case mi_globals iface of
1044                 Nothing  -> panic "getTopLevScope"
1045                 Just env -> returnM env }
1046
1047 getModuleExports :: Module -> TcRn m GlobalRdrEnv
1048 getModuleExports mod
1049   = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1050          returnM (foldl add emptyGlobalRdrEnv (mi_exports iface)) }
1051   where
1052     prov_fn n = NonLocalDef ImplicitImport
1053     add env (mod,avails)
1054         = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs)
1055
1056 contextDoc = text "context for compiling statements"
1057 \end{code}
1058
1059 \begin{code}
1060 getModuleContents
1061   :: HscEnv
1062   -> PersistentCompilerState    -- IN: persistent compiler state
1063   -> Module                     -- module to inspect
1064   -> Bool                       -- grab just the exports, or the whole toplev
1065   -> IO (PersistentCompilerState, Maybe [TyThing])
1066
1067 getModuleContents hsc_env pcs mod exports_only
1068  = initTc hsc_env pcs iNTERACTIVE $ do {
1069
1070         -- Load the interface if necessary (a home module will certainly
1071         -- alraedy be loaded, but a package module might not be)
1072         iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1073
1074         let { export_names = availsToNameSet export_avails ;
1075               export_avails = [ avail | (mn, avails) <- mi_exports iface,
1076                                         avail <- avails ] } ;
1077
1078         all_names <- if exports_only then
1079                         return export_names
1080                      else case mi_globals iface of {
1081                            Just rdr_env ->
1082                                 return (get_locals rdr_env) ;
1083
1084                            Nothing -> do { addErr (noRdrEnvErr mod) ;
1085                                            return export_names } } ;
1086                                 -- Invariant; we only have (not exports_only)
1087                                 -- for a home module so it must already be in the HIT
1088                                 -- So the Nothing case is a bug
1089
1090         env <- importSupportingDecls all_names ;
1091         setGblEnv env (mappM tcLookupGlobal (nameSetToList all_names))
1092     }
1093   where
1094         -- Grab all the things from the global env that are locally def'd
1095     get_locals rdr_env = mkNameSet [ gre_name gre
1096                                    | elts <- rdrEnvElts rdr_env,
1097                                      gre <- elts,
1098                                      isLocalGRE gre ]
1099         -- Make a set because a name is often in the envt in
1100         -- both qualified and unqualified forms
1101
1102 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
1103                   <+> quotes (ppr mod)
1104 #endif
1105 \end{code}
1106
1107 %************************************************************************
1108 %*                                                                      *
1109         Checking for 'main'
1110 %*                                                                      *
1111 %************************************************************************
1112
1113 \begin{code}
1114 checkMain
1115   = do { ghci_mode <- getGhciMode ;
1116          tcg_env   <- getGblEnv ;
1117
1118          mb_main_mod <- readMutVar v_MainModIs ;
1119          mb_main_fn  <- readMutVar v_MainFunIs ;
1120          let { main_mod = case mb_main_mod of {
1121                                 Just mod -> mkModuleName mod ;
1122                                 Nothing  -> mAIN_Name } ;
1123                 main_fn  = case mb_main_fn of {
1124                                 Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
1125                                 Nothing -> main_RDR_Unqual } } ;
1126
1127          check_main ghci_mode tcg_env main_mod main_fn
1128     }
1129
1130
1131 check_main ghci_mode tcg_env main_mod main_fn
1132      -- If we are in module Main, check that 'main' is defined.
1133      -- It may be imported from another module, in which case
1134      -- we have to drag in its.
1135      --
1136      -- Also form the definition
1137      --         $main = runIO main
1138      -- so we need to slurp in runIO too.
1139      --
1140      -- ToDo: We have to return the main_name separately, because it's a
1141      -- bona fide 'use', and should be recorded as such, but the others
1142      -- aren't
1143      --
1144      -- Blimey: a whole page of code to do this...
1145
1146  | mod_name /= main_mod
1147  = return (tcg_env, emptyFVs)
1148
1149         -- Check that 'main' is in scope
1150         -- It might be imported from another module!
1151         --
1152         -- We use a guard for this (rather than letting lookupSrcName fail)
1153         -- because it's not an error in ghci)
1154  | not (main_fn `elemRdrEnv` rdr_env)
1155  = do { complain_no_main; return (tcg_env, emptyFVs) }
1156
1157  | otherwise    -- OK, so the appropriate 'main' is in scope
1158                 --
1159  = do { main_name <- lookupSrcName main_fn ;
1160
1161         tcg_env <- importSupportingDecls (unitFV runIOName) ;
1162
1163         addSrcLoc (getSrcLoc main_name) $
1164         addErrCtxt mainCtxt             $
1165         setGblEnv tcg_env               $ do {
1166
1167         -- $main :: IO () = runIO main
1168         let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ;
1169         (main_expr, ty) <- tcInferRho rhs ;
1170
1171         let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) ;
1172               main_bind      = VarMonoBind dollar_main_id main_expr ;
1173               tcg_env'       = tcg_env { tcg_binds = tcg_binds tcg_env
1174                                                      `andMonoBinds` main_bind } } ;
1175
1176         return (tcg_env', unitFV main_name)
1177     }}
1178   where
1179     mod_name = moduleName (tcg_mod tcg_env)
1180     rdr_env  = tcg_rdr_env tcg_env
1181
1182     complain_no_main | ghci_mode == Interactive = return ()
1183                      | otherwise                = failWithTc noMainMsg
1184         -- In interactive mode, don't worry about the absence of 'main'
1185         -- In other modes, fail altogether, so that we don't go on
1186         -- and complain a second time when processing the export list.
1187
1188     mainCtxt  = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
1189     noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
1190                 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
1191 \end{code}
1192
1193
1194 %************************************************************************
1195 %*                                                                      *
1196                 Degugging output
1197 %*                                                                      *
1198 %************************************************************************
1199
1200 \begin{code}
1201 rnDump :: SDoc -> TcRn m ()
1202 -- Dump, with a banner, if -ddump-rn
1203 rnDump doc = dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc)
1204
1205 tcDump :: TcGblEnv -> TcRn m ()
1206 tcDump env
1207  = do { dflags <- getDOpts ;
1208
1209         -- Dump short output if -ddump-types or -ddump-tc
1210         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1211             (dumpTcRn short_dump) ;
1212
1213         -- Dump bindings if -ddump-tc
1214         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1215    }
1216   where
1217     short_dump = pprTcGblEnv env
1218     full_dump  = ppr (tcg_binds env)
1219         -- NB: foreign x-d's have undefined's in their types;
1220         --     hence can't show the tc_fords
1221
1222 tcCoreDump mod_guts
1223  = do { dflags <- getDOpts ;
1224         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1225             (dumpTcRn (pprModGuts mod_guts)) ;
1226
1227         -- Dump bindings if -ddump-tc
1228         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1229   where
1230     full_dump = pprCoreBindings (mg_binds mod_guts)
1231
1232 -- It's unpleasant having both pprModGuts and pprModDetails here
1233 pprTcGblEnv :: TcGblEnv -> SDoc
1234 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1235                         tcg_insts    = dfun_ids,
1236                         tcg_rules    = rules,
1237                         tcg_imports  = imports })
1238   = vcat [ ppr_types dfun_ids type_env
1239          , ppr_insts dfun_ids
1240          , vcat (map ppr rules)
1241          , ppr_gen_tycons (typeEnvTyCons type_env)
1242          , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports))
1243          , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1244
1245 pprModGuts :: ModGuts -> SDoc
1246 pprModGuts (ModGuts { mg_types = type_env,
1247                       mg_rules = rules })
1248   = vcat [ ppr_types [] type_env,
1249            ppr_rules rules ]
1250
1251
1252 ppr_types :: [Var] -> TypeEnv -> SDoc
1253 ppr_types dfun_ids type_env
1254   = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1255   where
1256     ids = [id | id <- typeEnvIds type_env, want_sig id]
1257     want_sig id | opt_PprStyle_Debug = True
1258                 | otherwise          = isLocalId id &&
1259                                        isExternalName (idName id) &&
1260                                        not (id `elem` dfun_ids)
1261         -- isLocalId ignores data constructors, records selectors etc.
1262         -- The isExternalName ignores local dictionary and method bindings
1263         -- that the type checker has invented.  Top-level user-defined things
1264         -- have External names.
1265
1266 ppr_insts :: [Var] -> SDoc
1267 ppr_insts []       = empty
1268 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1269
1270 ppr_sigs :: [Var] -> SDoc
1271 ppr_sigs ids
1272         -- Print type signatures
1273         -- Convert to HsType so that we get source-language style printing
1274         -- And sort by RdrName
1275   = vcat $ map ppr_sig $ sortLt lt_sig $
1276     [ (getRdrName id, toHsType (tidyTopType (idType id)))
1277     | id <- ids ]
1278   where
1279     lt_sig (n1,_) (n2,_) = n1 < n2
1280     ppr_sig (n,t)        = ppr n <+> dcolon <+> ppr t
1281
1282
1283 ppr_rules :: [IdCoreRule] -> SDoc
1284 ppr_rules [] = empty
1285 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1286                       nest 4 (pprIdRules rs),
1287                       ptext SLIT("#-}")]
1288
1289 ppr_gen_tycons []  = empty
1290 ppr_gen_tycons tcs = vcat [ptext SLIT("Generic type constructor details:"),
1291                            nest 2 (vcat (map ppr_gen_tycon tcs))
1292                      ]
1293
1294 -- x&y are now Id's, not CoreExpr's
1295 ppr_gen_tycon tycon
1296   | Just ep <- tyConGenInfo tycon
1297   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
1298
1299   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
1300
1301 ppr_ep (EP from to)
1302   = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
1303            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
1304            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
1305     ]
1306   where
1307     (_,from_tau) = tcSplitForAllTys (idType from)
1308 \end{code}