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