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