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