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