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