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