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