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                 -- The latter come in via tycl_decls
 750         traceTc (text "Tc2") ;
 751         tcg_env <- tcTyClDecls tycl_decls ;
 752         setGblEnv tcg_env       $ do {
 753
 754                 -- Source-language instances, including derivings,
 755                 -- and import the supporting declarations
 756         traceTc (text "Tc3") ;
 757         (tcg_env, inst_infos, deriv_binds, fvs) <- tcInstDecls1 tycl_decls inst_decls ;
 758         setGblEnv tcg_env       $ do {
 759         tcg_env <- importSupportingDecls fvs ;
 760         setGblEnv tcg_env       $ do {
 761
 762                 -- Foreign import declarations next.  No zonking necessary
 763                 -- here; we can tuck them straight into the global environment.
 764         traceTc (text "Tc4") ;
 765         (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
 766         tcExtendGlobalValEnv fi_ids                  $
 767         updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls })
 768                   $ do {
 769
 770                 -- Default declarations
 771         traceTc (text "Tc4a") ;
 772         default_tys <- tcDefaults default_decls ;
 773         updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
 774
 775                 -- Value declarations next
 776                 -- We also typecheck any extra binds that came out
 777                 -- of the "deriving" process
 778         traceTc (text "Tc5") ;
 779         (tc_val_binds, lcl_env) <- tcTopBinds (val_binds `ThenBinds` deriv_binds) ;
 780         setLclTypeEnv lcl_env   $ do {
 781
 782                 -- Second pass over class and instance declarations,
 783                 -- plus rules and foreign exports, to generate bindings
 784         traceTc (text "Tc6") ;
 785         (cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ;
 786         tcExtendGlobalValEnv dm_ids     $ do {
 787         inst_binds <- tcInstDecls2 inst_infos ;
 788         showLIE "after instDecls2" ;
 789
 790                 -- Foreign exports
 791                 -- They need to be zonked, so we return them
 792         traceTc (text "Tc7") ;
 793         (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
 794
 795                 -- Rules
 796                 -- Need to partition them because the source rules
 797                 -- must be zonked before adding them to tcg_rules
 798                 -- NB: built-in rules come in as IfaceRuleOut's, and
 799                 --     get added to tcg_rules right here by tcExtendRules
 800         rules <- tcRules rule_decls ;
 801         let { (src_rules, iface_rules) = partition isSrcRule rules } ;
 802         tcExtendRules iface_rules $ do {
 803
 804                 -- Wrap up
 805         tcg_env <- getGblEnv ;
 806         let { all_binds = tc_val_binds   `AndMonoBinds`
 807                           inst_binds     `AndMonoBinds`
 808                           cls_dm_binds   `AndMonoBinds`
 809                           foe_binds } ;
 810
 811         return (tcg_env, lcl_env, all_binds, src_rules, foe_decls)
 812      }}}}}}}}}
 813 \end{code}
 814
 815 \begin{code}
 816 tcTyClDecls :: [RenamedTyClDecl]
 817             -> TcM TcGblEnv
 818
 819 -- tcTyClDecls deals with
 820 --      type and class decls (some source, some imported)
 821 --      interface signatures (checked lazily)
 822 --
 823 -- It returns the TcGblEnv for this module, and side-effects the
 824 -- persistent compiler state to reflect the things imported from
 825 -- other modules
 826
 827 tcTyClDecls tycl_decls
 828   = checkNoErrs $
 829         -- tcTyAndClassDecls recovers internally, but if anything gave rise to
 830         -- an error we'd better stop now, to avoid a cascade
 831
 832     traceTc (text "TyCl1")              `thenM_`
 833     tcTyAndClassDecls tycl_decls        `thenM` \ tycl_things ->
 834     tcExtendGlobalEnv tycl_things       $
 835
 836     traceTc (text "TyCl2")              `thenM_`
 837     tcInterfaceSigs tycl_decls          `thenM` \ tcg_env ->
 838         -- Returns the extended environment
 839
 840     returnM tcg_env
 841 \end{code}
 842
 843
 844
 845 %************************************************************************
 846 %*                                                                      *
 847         Load the old interface file for this module (unless
 848         we have it aleady), and check whether it is up to date
 849
 850 %*                                                                      *
 851 %************************************************************************
 852
 853 \begin{code}
 854 checkOldIface :: HscEnv
 855               -> PersistentCompilerState
 856               -> Module
 857               -> FilePath               -- Where the interface file is
 858               -> Bool                   -- Source unchanged
 859               -> Maybe ModIface         -- Old interface from compilation manager, if any
 860               -> IO (PersistentCompilerState, Maybe (RecompileRequired, Maybe ModIface))
 861                                 -- Nothing <=> errors happened
 862
 863 checkOldIface hsc_env pcs mod iface_path source_unchanged maybe_iface
 864   = do { showPass (hsc_dflags hsc_env)
 865                   ("Checking old interface for " ++ moduleUserString mod) ;
 866
 867          initTc hsc_env pcs mod
 868                 (check_old_iface iface_path source_unchanged maybe_iface)
 869      }
 870
 871 check_old_iface iface_path source_unchanged maybe_iface
 872  =      -- CHECK WHETHER THE SOURCE HAS CHANGED
 873     ifM (not source_unchanged)
 874         (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
 875                                                 `thenM_`
 876
 877      -- If the source has changed and we're in interactive mode, avoid reading
 878      -- an interface; just return the one we might have been supplied with.
 879     getGhciMode                                 `thenM` \ ghci_mode ->
 880     if (ghci_mode == Interactive) && not source_unchanged then
 881          returnM (outOfDate, maybe_iface)
 882     else
 883
 884     case maybe_iface of
 885        Just old_iface -> -- Use the one we already have
 886                          checkVersions source_unchanged old_iface       `thenM` \ recomp ->
 887                          returnM (recomp, Just old_iface)
 888
 889        Nothing          -- Try and read it from a file
 890           -> getModule                                  `thenM` \ this_mod ->
 891              readIface this_mod iface_path False        `thenM` \ read_result ->
 892              case read_result of
 893                Left err -> -- Old interface file not found, or garbled; give up
 894                            traceHiDiffs (
 895                                 text "Cannot read old interface file:"
 896                                    $$ nest 4 (text (showException err))) `thenM_`
 897                            returnM (outOfDate, Nothing)
 898
 899                Right parsed_iface ->
 900                          initRn (InterfaceMode this_mod)
 901                                 (loadOldIface parsed_iface)     `thenM` \ m_iface ->
 902                          checkVersions source_unchanged m_iface `thenM` \ recomp ->
 903                          returnM (recomp, Just m_iface)
 904 \end{code}
 905
 906
 907 %************************************************************************
 908 %*                                                                      *
 909         Type-check and rename supporting declarations
 910         This is used to deal with the free vars of a splice,
 911         or derived code: slurp in the necessary declarations,
 912         typecheck them, and add them to the EPS
 913 %*                                                                      *
 914 %************************************************************************
 915
 916 \begin{code}
 917 importSupportingDecls :: FreeVars -> TcM TcGblEnv
 918 -- Completely deal with the supporting imports needed
 919 -- by the specified free-var set
 920 importSupportingDecls fvs
 921  = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ;
 922         decls <- slurpImpDecls fvs ;
 923         traceRn (text "...namely:" <+> vcat (map ppr decls)) ;
 924         typecheckIfaceDecls (mkGroup decls) }
 925
 926 typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv
 927   -- The decls are all interface-file declarations
 928   -- Usually they are all from other modules, but when we are reading
 929   -- this module's interface from a file, it's possible that some of
 930   -- them are for the module being compiled.
 931   -- That is why the tcExtendX functions need to do partitioning.
 932   --
 933   -- If all the decls are from other modules, the returned TcGblEnv
 934   -- will have an empty tc_genv, but its tc_inst_env
 935   -- cache may have been augmented.
 936 typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls,
 937                                hs_instds = inst_decls,
 938                                hs_ruleds = rule_decls })
 939  = do {         -- Typecheck the type, class, and interface-sig decls
 940         tcg_env <- tcTyClDecls tycl_decls ;
 941         setGblEnv tcg_env               $ do {
 942
 943         -- Typecheck the instance decls, and rules
 944         -- Note that imported dictionary functions are already
 945         -- in scope from the preceding tcTyClDecls
 946         tcIfaceInstDecls inst_decls     `thenM` \ dfuns ->
 947         tcExtendInstEnv dfuns           $
 948         tcRules rule_decls              `thenM` \ rules ->
 949         tcExtendRules rules             $
 950
 951         getGblEnv               -- Return the environment
 952    }}
 953 \end{code}
 954
 955
 956
 957 %*********************************************************
 958 %*                                                       *
 959         mkGlobalContext: make up an interactive context
 960
 961         Used for initialising the lexical environment
 962         of the interactive read-eval-print loop
 963 %*                                                       *
 964 %*********************************************************
 965
 966 \begin{code}
 967 #ifdef GHCI
 968 mkGlobalContext
 969         :: HscEnv -> PersistentCompilerState
 970         -> [Module]     -- Expose these modules' top-level scope
 971         -> [Module]     -- Expose these modules' exports only
 972         -> IO (PersistentCompilerState, Maybe GlobalRdrEnv)
 973
 974 mkGlobalContext hsc_env pcs toplevs exports
 975   = initTc hsc_env pcs iNTERACTIVE $ do {
 976
 977     toplev_envs <- mappM getTopLevScope   toplevs ;
 978     export_envs <- mappM getModuleExports exports ;
 979     returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv
 980                    (toplev_envs ++ export_envs))
 981     }
 982
 983 getTopLevScope :: Module -> TcRn m GlobalRdrEnv
 984 getTopLevScope mod
 985   = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
 986          case mi_globals iface of
 987                 Nothing  -> panic "getTopLevScope"
 988                 Just env -> returnM env }
 989
 990 getModuleExports :: Module -> TcRn m GlobalRdrEnv
 991 getModuleExports mod
 992   = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
 993          returnM (foldl add emptyGlobalRdrEnv (mi_exports iface)) }
 994   where
 995     prov_fn n = NonLocalDef ImplicitImport
 996     add env (mod,avails)
 997         = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs)
 998
 999 contextDoc = text "context for compiling statements"
1000 \end{code}
1001
1002 \begin{code}
1003 getModuleContents
1004   :: HscEnv
1005   -> PersistentCompilerState    -- IN: persistent compiler state
1006   -> Module                     -- module to inspect
1007   -> Bool                       -- grab just the exports, or the whole toplev
1008   -> IO (PersistentCompilerState, Maybe [TyThing])
1009
1010 getModuleContents hsc_env pcs mod exports_only
1011  = initTc hsc_env pcs iNTERACTIVE $ do {
1012
1013         -- Load the interface if necessary (a home module will certainly
1014         -- alraedy be loaded, but a package module might not be)
1015         iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1016
1017         let { export_names = availsToNameSet export_avails ;
1018               export_avails = [ avail | (mn, avails) <- mi_exports iface,
1019                                         avail <- avails ] } ;
1020
1021         all_names <- if exports_only then
1022                         return export_names
1023                      else case mi_globals iface of {
1024                            Just rdr_env ->
1025                                 return (get_locals rdr_env) ;
1026
1027                            Nothing -> do { addErr (noRdrEnvErr mod) ;
1028                                            return export_names } } ;
1029                                 -- Invariant; we only have (not exports_only)
1030                                 -- for a home module so it must already be in the HIT
1031                                 -- So the Nothing case is a bug
1032
1033         env <- importSupportingDecls all_names ;
1034         setGblEnv env (mappM tcLookupGlobal (nameSetToList all_names))
1035     }
1036   where
1037         -- Grab all the things from the global env that are locally def'd
1038     get_locals rdr_env = mkNameSet [ gre_name gre
1039                                    | elts <- rdrEnvElts rdr_env,
1040                                      gre <- elts,
1041                                      isLocalGRE gre ]
1042         -- Make a set because a name is often in the envt in
1043         -- both qualified and unqualified forms
1044
1045 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
1046                   <+> quotes (ppr mod)
1047 #endif
1048 \end{code}
1049
1050 %************************************************************************
1051 %*                                                                      *
1052         Checking for 'main'
1053 %*                                                                      *
1054 %************************************************************************
1055
1056 \begin{code}
1057 checkMain
1058   = do { ghci_mode <- getGhciMode ;
1059          tcg_env   <- getGblEnv ;
1060          check_main ghci_mode tcg_env
1061     }
1062
1063 check_main ghci_mode tcg_env
1064      -- If we are in module Main, check that 'main' is defined.
1065      -- It may be imported from another module, in which case
1066      -- we have to drag in its.
1067      --
1068      -- Also form the definition
1069      --         $main = runIO main
1070      -- so we need to slurp in runIO too.
1071      --
1072      -- ToDo: We have to return the main_name separately, because it's a
1073      -- bona fide 'use', and should be recorded as such, but the others
1074      -- aren't
1075      --
1076      -- Blimey: a whole page of code to do this...
1077
1078  | mod_name /= mAIN_Name
1079  = return (tcg_env, emptyFVs)
1080
1081         -- Check that 'main' is in scope
1082         -- It might be imported from another module!
1083         --
1084         -- We use a guard for this (rather than letting lookupSrcName fail)
1085         -- because it's not an error in ghci)
1086  | not (main_RDR_Unqual `elemRdrEnv` rdr_env)
1087  = do { complain_no_main; return (tcg_env, emptyFVs) }
1088
1089  | otherwise
1090  = do { main_name <- lookupSrcName main_RDR_Unqual ;
1091
1092         tcg_env <- importSupportingDecls (unitFV runIOName) ;
1093         setGblEnv tcg_env $ do {
1094
1095         -- $main :: IO () = runIO main
1096         let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ;
1097
1098         (main_bind, top_lie) <- getLIE (
1099                 addSrcLoc (getSrcLoc main_name) $
1100                 addErrCtxt mainCtxt             $ do {
1101                 (main_expr, ty) <- tcExpr_id rhs ;
1102                 let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) } ;
1103                 return (VarMonoBind dollar_main_id main_expr)
1104             }) ;
1105
1106         inst_binds <- tcSimplifyTop top_lie ;
1107
1108         (ids, binds') <- zonkTopBinds (main_bind `andMonoBinds` inst_binds) ;
1109
1110         let { tcg_env' = tcg_env {
1111                 tcg_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) ids,
1112                 tcg_binds = tcg_binds tcg_env `andMonoBinds` binds' } } ;
1113
1114         return (tcg_env', unitFV main_name)
1115     }}
1116   where
1117     mod_name = moduleName (tcg_mod tcg_env)
1118     rdr_env  = tcg_rdr_env tcg_env
1119
1120     complain_no_main | ghci_mode == Interactive = return ()
1121                      | otherwise                = failWithTc noMainMsg
1122         -- In interactive mode, don't worry about the absence of 'main'
1123         -- In other modes, fail altogether, so that we don't go on
1124         -- and complain a second time when processing the export list.
1125
1126     mainCtxt  = ptext SLIT("When checking the type of 'main'")
1127     noMainMsg = ptext SLIT("No 'main' defined in module Main")
1128 \end{code}
1129
1130
1131 %************************************************************************
1132 %*                                                                      *
1133                 Degugging output
1134 %*                                                                      *
1135 %************************************************************************
1136
1137 \begin{code}
1138 rnDump :: SDoc -> TcRn m ()
1139 -- Dump, with a banner, if -ddump-rn
1140 rnDump doc = dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc)
1141
1142 tcDump :: TcGblEnv -> TcRn m ()
1143 tcDump env
1144  = do { dflags <- getDOpts ;
1145
1146         -- Dump short output if -ddump-types or -ddump-tc
1147         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1148             (dumpTcRn short_dump) ;
1149
1150         -- Dump bindings if -ddump-tc
1151         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1152    }
1153   where
1154     short_dump = pprTcGblEnv env
1155     full_dump  = ppr (tcg_binds env)
1156         -- NB: foreign x-d's have undefined's in their types;
1157         --     hence can't show the tc_fords
1158
1159 tcCoreDump mod_guts
1160  = do { dflags <- getDOpts ;
1161         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1162             (dumpTcRn (pprModGuts mod_guts)) ;
1163
1164         -- Dump bindings if -ddump-tc
1165         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1166   where
1167     full_dump = pprCoreBindings (mg_binds mod_guts)
1168
1169 -- It's unpleasant having both pprModGuts and pprModDetails here
1170 pprTcGblEnv :: TcGblEnv -> SDoc
1171 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1172                         tcg_insts    = dfun_ids,
1173                         tcg_rules    = rules,
1174                         tcg_imports  = imports })
1175   = vcat [ ppr_types dfun_ids type_env
1176          , ppr_insts dfun_ids
1177          , vcat (map ppr rules)
1178          , ppr_gen_tycons (typeEnvTyCons type_env)
1179          , ppr (moduleEnvElts (imp_dep_mods imports))
1180          , ppr (imp_dep_pkgs imports)]
1181
1182 pprModGuts :: ModGuts -> SDoc
1183 pprModGuts (ModGuts { mg_types = type_env,
1184                       mg_rules = rules })
1185   = vcat [ ppr_types [] type_env,
1186            ppr_rules rules ]
1187
1188
1189 ppr_types :: [Var] -> TypeEnv -> SDoc
1190 ppr_types dfun_ids type_env
1191   = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1192   where
1193     ids = [id | id <- typeEnvIds type_env, want_sig id]
1194     want_sig id | opt_PprStyle_Debug = True
1195                 | otherwise          = isLocalId id &&
1196                                        isExternalName (idName id) &&
1197                                        not (id `elem` dfun_ids)
1198         -- isLocalId ignores data constructors, records selectors etc.
1199         -- The isExternalName ignores local dictionary and method bindings
1200         -- that the type checker has invented.  Top-level user-defined things
1201         -- have External names.
1202
1203 ppr_insts :: [Var] -> SDoc
1204 ppr_insts []       = empty
1205 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1206
1207 ppr_sigs :: [Var] -> SDoc
1208 ppr_sigs ids
1209         -- Print type signatures
1210         -- Convert to HsType so that we get source-language style printing
1211         -- And sort by RdrName
1212   = vcat $ map ppr_sig $ sortLt lt_sig $
1213     [ (getRdrName id, toHsType (idType id))
1214     | id <- ids ]
1215   where
1216     lt_sig (n1,_) (n2,_) = n1 < n2
1217     ppr_sig (n,t)        = ppr n <+> dcolon <+> ppr t
1218
1219
1220 ppr_rules :: [IdCoreRule] -> SDoc
1221 ppr_rules [] = empty
1222 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1223                       nest 4 (pprIdRules rs),
1224                       ptext SLIT("#-}")]
1225
1226 ppr_gen_tycons []  = empty
1227 ppr_gen_tycons tcs = vcat [ptext SLIT("{-# Generic type constructor details"),
1228                            vcat (map ppr_gen_tycon tcs),
1229                            ptext SLIT("#-}")
1230                      ]
1231
1232 -- x&y are now Id's, not CoreExpr's
1233 ppr_gen_tycon tycon
1234   | Just ep <- tyConGenInfo tycon
1235   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
1236
1237   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
1238
1239 ppr_ep (EP from to)
1240   = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
1241            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
1242            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
1243     ]
1244   where
1245     (_,from_tau) = tcSplitForAllTys (idType from)
1246 \end{code}