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), lie) <- getLIE (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_stmts), lie) <-
 413                 getLIE                                          $
 414                 tcStmtsAndThen combine stmt_ctxt all_stmts      $
 415                 do {
 416                     -- Look up the names right in the middle,
 417                     -- where they will all be in scope
 418                     ids <- mappM tcLookupId names ;
 419                     return (ids, [])
 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         io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
 433         let { expr = mkHsLet const_binds $
 434                      HsDo DoExpr tc_stmts io_ids
 435                           (mkTyConApp ioTyCon [ret_ty]) noSrcLoc } ;
 436         zonked_expr <- zonkTopExpr expr ;
 437         zonked_ids  <- zonkTopBndrs ids ;
 438
 439         return (zonked_ids, zonked_expr)
 440         }
 441   where
 442     combine stmt (ids, stmts) = (ids, stmt:stmts)
 443 \end{code}
 444
 445
 446 tcRnExpr just finds the type of an expression
 447
 448 \begin{code}
 449 tcRnExpr :: HscEnv -> PersistentCompilerState
 450          -> InteractiveContext
 451          -> RdrNameHsExpr
 452          -> IO (PersistentCompilerState, Maybe Type)
 453 tcRnExpr hsc_env pcs ictxt rdr_expr
 454   = initTc hsc_env pcs iNTERACTIVE $
 455     setInteractiveContext ictxt $ do {
 456
 457     (rn_expr, fvs) <- initRnInteractive ictxt (rnExpr rdr_expr) ;
 458     failIfErrsM ;
 459
 460         -- Suck in the supporting declarations and typecheck them
 461     tcg_env <- importSupportingDecls (fvs `plusFV` ubiquitousNames) ;
 462     setGblEnv tcg_env $ do {
 463
 464         -- Now typecheck the expression;
 465         -- it might have a rank-2 type (e.g. :t runST)
 466     ((tc_expr, res_ty), lie)       <- getLIE (tcInferRho rn_expr) ;
 467     ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie)  ;
 468     tcSimplifyTop lie_top ;
 469
 470     let { all_expr_ty = mkForAllTys qtvs                $
 471                         mkFunTys (map idType dict_ids)  $
 472                         res_ty } ;
 473     zonkTcType all_expr_ty
 474     }}
 475   where
 476     smpl_doc = ptext SLIT("main expression")
 477 \end{code}
 478
 479
 480 \begin{code}
 481 tcRnThing :: HscEnv -> PersistentCompilerState
 482           -> InteractiveContext
 483           -> RdrName
 484           -> IO (PersistentCompilerState, Maybe [TyThing])
 485 -- Look up a RdrName and return all the TyThings it might be
 486 -- We treat a capitalised RdrName as both a data constructor
 487 -- and as a type or class constructor; hence we return up to two results
 488 tcRnThing hsc_env pcs ictxt rdr_name
 489   = initTc hsc_env pcs iNTERACTIVE $
 490     setInteractiveContext ictxt $ do {
 491
 492         -- If the identifier is a constructor (begins with an
 493         -- upper-case letter), then we need to consider both
 494         -- constructor and type class identifiers.
 495     let { rdr_names = dataTcOccs rdr_name } ;
 496
 497         -- results :: [(Messages, Maybe Name)]
 498     results <- initRnInteractive ictxt
 499                             (mapM (tryTc . lookupOccRn) rdr_names) ;
 500
 501         -- The successful lookups will be (Just name)
 502     let { (warns_s, good_names) = unzip [ (msgs, name)
 503                                         | (msgs, Just name) <- results] ;
 504           errs_s = [msgs | (msgs, Nothing) <- results] } ;
 505
 506         -- Fail if nothing good happened, else add warnings
 507     if null good_names then     -- Fail
 508         do { addMessages (head errs_s) ; failM }
 509       else                      -- Add deprecation warnings
 510         mapM_ addMessages warns_s ;
 511
 512         -- Slurp in the supporting declarations
 513     tcg_env <- importSupportingDecls (mkFVs good_names) ;
 514     setGblEnv tcg_env $ do {
 515
 516         -- And lookup up the entities
 517     mapM tcLookupGlobal good_names
 518     }}
 519 \end{code}
 520
 521
 522 \begin{code}
 523 setInteractiveContext :: InteractiveContext -> TcRn m a -> TcRn m a
 524 setInteractiveContext icxt thing_inside
 525   = traceTc (text "setIC" <+> ppr (ic_type_env icxt))   `thenM_`
 526     updGblEnv (\ env -> env { tcg_rdr_env  = ic_rn_gbl_env icxt,
 527                               tcg_type_env = ic_type_env   icxt })
 528               thing_inside
 529
 530 initRnInteractive :: InteractiveContext -> RnM a -> TcM a
 531 -- Set the local RdrEnv from the interactive context
 532 initRnInteractive ictxt rn_thing
 533   = initRn CmdLineMode $
 534     setLocalRdrEnv (ic_rn_local_env ictxt) $
 535     rn_thing
 536 #endif
 537 \end{code}
 538
 539 %************************************************************************
 540 %*                                                                      *
 541         Type-checking external-core modules
 542 %*                                                                      *
 543 %************************************************************************
 544
 545 \begin{code}
 546 tcRnExtCore :: HscEnv -> PersistentCompilerState
 547             -> RdrNameHsModule
 548             -> IO (PersistentCompilerState, Maybe ModGuts)
 549         -- Nothing => some error occurred
 550
 551 tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc)
 552         -- For external core, the module name is syntactically reqd
 553         -- Rename the (Core) module.  It's a bit like an interface
 554         -- file: all names are original names
 555  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 556
 557    initTc hsc_env pcs this_mod $ addSrcLoc loc $ do {
 558
 559         -- Rename the source, only in interface mode.
 560         -- rnSrcDecls handles fixity decls etc too, which won't occur
 561         -- but that doesn't matter
 562    let { local_group = mkGroup decls } ;
 563    (_, rn_decls, dus) <- initRn (InterfaceMode this_mod)
 564                                       (rnSrcDecls local_group) ;
 565    failIfErrsM ;
 566
 567         -- Get the supporting decls
 568    rn_imp_decls <- slurpImpDecls (duUses dus) ;
 569    let { rn_decls = rn_decls `addImpDecls` rn_imp_decls } ;
 570
 571         -- Dump trace of renaming part
 572    rnDump (ppr rn_decls) ;
 573    rnStats rn_imp_decls ;
 574
 575         -- Typecheck them all together so that
 576         -- any mutually recursive types are done right
 577    tcg_env <- typecheckIfaceDecls rn_decls ;
 578    setGblEnv tcg_env $ do {
 579
 580         -- Now the core bindings
 581    core_prs <- tcCoreBinds (hs_coreds rn_decls) ;
 582    tcExtendGlobalValEnv (map fst core_prs) $ do {
 583
 584         -- Wrap up
 585    let {
 586         bndrs      = map fst core_prs ;
 587         my_exports = map (Avail . idName) bndrs ;
 588                 -- ToDo: export the data types also?
 589
 590         final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
 591
 592         mod_guts = ModGuts {    mg_module   = this_mod,
 593                                 mg_usages   = [],               -- ToDo: compute usage
 594                                 mg_dir_imps = [],               -- ??
 595                                 mg_deps     = noDependencies,   -- ??
 596                                 mg_exports  = my_exports,
 597                                 mg_types    = final_type_env,
 598                                 mg_insts    = tcg_insts tcg_env,
 599                                 mg_rules    = hsCoreRules (tcg_rules tcg_env),
 600                                 mg_binds    = [Rec core_prs],
 601
 602                                 -- Stubs
 603                                 mg_rdr_env  = emptyGlobalRdrEnv,
 604                                 mg_fix_env  = emptyFixityEnv,
 605                                 mg_deprecs  = NoDeprecs,
 606                                 mg_foreign  = NoStubs
 607                     } } ;
 608
 609    tcCoreDump mod_guts ;
 610
 611    return mod_guts
 612    }}}}
 613 \end{code}
 614
 615
 616 %************************************************************************
 617 %*                                                                      *
 618         Type-checking the top level of a module
 619 %*                                                                      *
 620 %************************************************************************
 621
 622 \begin{code}
 623 tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, DefUses)
 624         -- Returns the variables free in the decls
 625         -- Reason: solely to report unused imports and bindings
 626 tcRnSrcDecls decls
 627  = do {         -- Do all the declarations
 628         ((tc_envs, dus), lie) <- getLIE (tc_rn_src_decls decls) ;
 629
 630              -- tcSimplifyTop deals with constant or ambiguous InstIds.
 631              -- How could there be ambiguous ones?  They can only arise if a
 632              -- top-level decl falls under the monomorphism
 633              -- restriction, and no subsequent decl instantiates its
 634              -- type.  (Usually, ambiguous type variables are resolved
 635              -- during the generalisation step.)
 636         traceTc (text "Tc8") ;
 637         setEnvs tc_envs         $ do {
 638                 -- Setting the global env exposes the instances to tcSimplifyTop
 639                 -- Setting the local env exposes the local Ids, so that
 640                 -- we get better error messages (monomorphism restriction)
 641         inst_binds <- tcSimplifyTop lie ;
 642
 643             -- Backsubstitution.  This must be done last.
 644             -- Even tcSimplifyTop may do some unification.
 645         traceTc (text "Tc9") ;
 646         let { (tcg_env, _) = tc_envs ;
 647               TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
 648                          tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
 649
 650         (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds)
 651                                                            rules fords ;
 652
 653         return (tcg_env { tcg_type_env = extendTypeEnvWithIds type_env bind_ids,
 654                           tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' },
 655                 dus)
 656     }}
 657
 658 tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), DefUses)
 659
 660 tc_rn_src_decls ds
 661  = do { let { (first_group, group_tail) = findSplice ds } ;
 662                 -- If ds is [] we get ([], Nothing)
 663
 664         -- Type check the decls up to, but not including, the first splice
 665         (tc_envs@(_,tcl_env), src_dus1) <- tcRnGroup first_group ;
 666
 667         -- Bale out if errors; for example, error recovery when checking
 668         -- the RHS of 'main' can mean that 'main' is not in the envt for
 669         -- the subsequent checkMain test
 670         failIfErrsM ;
 671
 672         setEnvs tc_envs $
 673
 674         -- If there is no splice, we're nearly done
 675         case group_tail of {
 676            Nothing -> do {      -- Last thing: check for `main'
 677                            (tcg_env, main_fvs) <- checkMain ;
 678                            return ((tcg_env, tcl_env),
 679                                     src_dus1 `plusDU` usesOnly main_fvs)
 680                       } ;
 681
 682         -- If there's a splice, we must carry on
 683            Just (SpliceDecl splice_expr splice_loc, rest_ds) -> do {
 684 #ifndef GHCI
 685         failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
 686 #else
 687
 688         -- Rename the splice expression, and get its supporting decls
 689         (rn_splice_expr, splice_fvs) <- initRn SourceMode $
 690                                         addSrcLoc splice_loc $
 691                                         rnExpr splice_expr ;
 692         tcg_env <- importSupportingDecls (splice_fvs `plusFV` templateHaskellNames) ;
 693         setGblEnv tcg_env $ do {
 694
 695         -- Execute the splice
 696         spliced_decls <- tcSpliceDecls rn_splice_expr ;
 697
 698         -- Glue them on the front of the remaining decls and loop
 699         (tc_envs, src_dus2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ;
 700
 701         return (tc_envs, src_dus1 `plusDU` usesOnly splice_fvs `plusDU` src_dus2)
 702     }
 703 #endif /* GHCI */
 704     }}}
 705 \end{code}
 706
 707
 708 %************************************************************************
 709 %*                                                                      *
 710         Type-checking the top level of a module
 711 %*                                                                      *
 712 %************************************************************************
 713
 714 tcRnGroup takes a bunch of top-level source-code declarations, and
 715  * renames them
 716  * gets supporting declarations from interface files
 717  * typechecks them
 718  * zonks them
 719  * and augments the TcGblEnv with the results
 720
 721 In Template Haskell it may be called repeatedly for each group of
 722 declarations.  It expects there to be an incoming TcGblEnv in the
 723 monad; it augments it and returns the new TcGblEnv.
 724
 725 \begin{code}
 726 tcRnGroup :: HsGroup RdrName -> TcM ((TcGblEnv, TcLclEnv), DefUses)
 727         -- Returns the variables free in the decls, for unused-binding reporting
 728 tcRnGroup decls
 729  = do {         -- Rename the declarations
 730         (tcg_env, rn_decls, src_dus) <- rnTopSrcDecls decls ;
 731         setGblEnv tcg_env $ do {
 732
 733                 -- Typecheck the declarations
 734         tc_envs <- tcTopSrcDecls rn_decls ;
 735
 736         return (tc_envs, src_dus)
 737   }}
 738
 739 ------------------------------------------------
 740 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, DefUses)
 741 rnTopSrcDecls group
 742  = do {         -- Bring top level binders into scope
 743         (rdr_env, imports) <- importsFromLocalDecls group ;
 744         updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv`
 745                                                   tcg_rdr_env gbl,
 746                                  tcg_imports = imports `plusImportAvails`
 747                                                   tcg_imports gbl })
 748                      $ do {
 749
 750         failIfErrsM ;   -- No point in continuing if (say) we have duplicate declarations
 751
 752                 -- Rename the source decls
 753         (tcg_env, rn_src_decls, src_dus) <- initRn SourceMode (rnSrcDecls group) ;
 754         setGblEnv tcg_env $ do {
 755
 756         failIfErrsM ;
 757
 758                 -- Import consquential imports
 759         let { src_fvs = duUses src_dus } ;
 760         rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ;
 761         let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ;
 762
 763                 -- Dump trace of renaming part
 764         rnDump (ppr rn_decls) ;
 765         rnStats rn_imp_decls ;
 766
 767         return (tcg_env, rn_decls, src_dus)
 768   }}}
 769
 770 ------------------------------------------------
 771 tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
 772 tcTopSrcDecls
 773         (HsGroup { hs_tyclds = tycl_decls,
 774                    hs_instds = inst_decls,
 775                    hs_fords  = foreign_decls,
 776                    hs_defds  = default_decls,
 777                    hs_ruleds = rule_decls,
 778                    hs_valds  = val_binds })
 779  = do {         -- Type-check the type and class decls, and all imported decls
 780                 -- The latter come in via tycl_decls
 781         traceTc (text "Tc2") ;
 782         tcg_env <- tcTyClDecls tycl_decls ;
 783         setGblEnv tcg_env       $ do {
 784
 785                 -- Source-language instances, including derivings,
 786                 -- and import the supporting declarations
 787         traceTc (text "Tc3") ;
 788         (tcg_env, inst_infos, deriv_binds, fvs) <- tcInstDecls1 tycl_decls inst_decls ;
 789         setGblEnv tcg_env       $ do {
 790         tcg_env <- importSupportingDecls fvs ;
 791         setGblEnv tcg_env       $ do {
 792
 793                 -- Foreign import declarations next.  No zonking necessary
 794                 -- here; we can tuck them straight into the global environment.
 795         traceTc (text "Tc4") ;
 796         (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
 797         tcExtendGlobalValEnv fi_ids                  $
 798         updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls })
 799                   $ do {
 800
 801                 -- Default declarations
 802         traceTc (text "Tc4a") ;
 803         default_tys <- tcDefaults default_decls ;
 804         updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
 805
 806                 -- Value declarations next
 807                 -- We also typecheck any extra binds that came out
 808                 -- of the "deriving" process
 809         traceTc (text "Tc5") ;
 810         (tc_val_binds, lcl_env) <- tcTopBinds (val_binds `ThenBinds` deriv_binds) ;
 811         setLclTypeEnv lcl_env   $ do {
 812
 813                 -- Second pass over class and instance declarations,
 814                 -- plus rules and foreign exports, to generate bindings
 815         traceTc (text "Tc6") ;
 816         (cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ;
 817         tcExtendGlobalValEnv dm_ids     $ do {
 818         inst_binds <- tcInstDecls2 inst_infos ;
 819         showLIE (text "after instDecls2") ;
 820
 821                 -- Foreign exports
 822                 -- They need to be zonked, so we return them
 823         traceTc (text "Tc7") ;
 824         (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
 825
 826                 -- Rules
 827                 -- Need to partition them because the source rules
 828                 -- must be zonked before adding them to tcg_rules
 829                 -- NB: built-in rules come in as IfaceRuleOut's, and
 830                 --     get added to tcg_rules right here by tcExtendRules
 831         rules <- tcRules rule_decls ;
 832         let { (src_rules, iface_rules) = partition isSrcRule rules } ;
 833         tcExtendRules iface_rules $ do {
 834
 835                 -- Wrap up
 836         tcg_env <- getGblEnv ;
 837         let { all_binds = tc_val_binds   `AndMonoBinds`
 838                           inst_binds     `AndMonoBinds`
 839                           cls_dm_binds   `AndMonoBinds`
 840                           foe_binds  ;
 841
 842                 -- Extend the GblEnv with the (as yet un-zonked)
 843                 -- bindings, rules, foreign decls
 844               tcg_env' = tcg_env {  tcg_binds = tcg_binds tcg_env `andMonoBinds` all_binds,
 845                                     tcg_rules = tcg_rules tcg_env ++ src_rules,
 846                                     tcg_fords = tcg_fords tcg_env ++ foe_decls } } ;
 847
 848         return (tcg_env', lcl_env)
 849      }}}}}}}}}
 850 \end{code}
 851
 852 \begin{code}
 853 tcTyClDecls :: [RenamedTyClDecl]
 854             -> TcM TcGblEnv
 855
 856 -- tcTyClDecls deals with
 857 --      type and class decls (some source, some imported)
 858 --      interface signatures (checked lazily)
 859 --
 860 -- It returns the TcGblEnv for this module, and side-effects the
 861 -- persistent compiler state to reflect the things imported from
 862 -- other modules
 863
 864 tcTyClDecls tycl_decls
 865   = checkNoErrs $
 866         -- tcTyAndClassDecls recovers internally, but if anything gave rise to
 867         -- an error we'd better stop now, to avoid a cascade
 868
 869     traceTc (text "TyCl1")              `thenM_`
 870     tcTyAndClassDecls tycl_decls        `thenM` \ tcg_env ->
 871         -- Returns the extended environment
 872     setGblEnv tcg_env                   $
 873
 874     traceTc (text "TyCl2")              `thenM_`
 875     tcInterfaceSigs tycl_decls          `thenM` \ tcg_env ->
 876         -- Returns the extended environment
 877
 878     returnM tcg_env
 879 \end{code}
 880
 881
 882
 883 %************************************************************************
 884 %*                                                                      *
 885         Load the old interface file for this module (unless
 886         we have it aleady), and check whether it is up to date
 887
 888 %*                                                                      *
 889 %************************************************************************
 890
 891 \begin{code}
 892 checkOldIface :: HscEnv
 893               -> PersistentCompilerState
 894               -> Module
 895               -> FilePath               -- Where the interface file is
 896               -> Bool                   -- Source unchanged
 897               -> Maybe ModIface         -- Old interface from compilation manager, if any
 898               -> IO (PersistentCompilerState, Maybe (RecompileRequired, Maybe ModIface))
 899                                 -- Nothing <=> errors happened
 900
 901 checkOldIface hsc_env pcs mod iface_path source_unchanged maybe_iface
 902   = do { showPass (hsc_dflags hsc_env)
 903                   ("Checking old interface for " ++ moduleUserString mod) ;
 904
 905          initTc hsc_env pcs mod
 906                 (check_old_iface iface_path source_unchanged maybe_iface)
 907      }
 908
 909 check_old_iface iface_path source_unchanged maybe_iface
 910  =      -- CHECK WHETHER THE SOURCE HAS CHANGED
 911     ifM (not source_unchanged)
 912         (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off")))
 913                                                 `thenM_`
 914
 915      -- If the source has changed and we're in interactive mode, avoid reading
 916      -- an interface; just return the one we might have been supplied with.
 917     getGhciMode                                 `thenM` \ ghci_mode ->
 918     if (ghci_mode == Interactive) && not source_unchanged then
 919          returnM (outOfDate, maybe_iface)
 920     else
 921
 922     case maybe_iface of {
 923        Just old_iface -> -- Use the one we already have
 924                          checkVersions source_unchanged old_iface       `thenM` \ recomp ->
 925                          returnM (recomp, Just old_iface)
 926
 927     ;  Nothing ->
 928
 929         -- Try and read the old interface for the current module
 930         -- from the .hi file left from the last time we compiled it
 931     getModule                                   `thenM` \ this_mod ->
 932     readIface this_mod iface_path False `thenM` \ read_result ->
 933     case read_result of {
 934        Left err ->      -- Old interface file not found, or garbled; give up
 935                    traceHiDiffs (text "FYI: cannot read old interface file:"
 936                                  $$ nest 4 (text (showException err)))  `thenM_`
 937                    returnM (outOfDate, Nothing)
 938
 939     ;  Right parsed_iface ->
 940
 941         -- We found the file and parsed it; now load it
 942     tryTc (initRn (InterfaceMode this_mod)
 943                   (loadOldIface parsed_iface))  `thenM` \ ((_,errs), mb_iface) ->
 944     case mb_iface of {
 945         Nothing ->      -- Something went wrong in loading.  The main likely thing
 946                         -- is that the usages mentioned B.f, where B.hi and B.hs no
 947                         -- longer exist.  Then newGlobalName2 fails with an error message
 948                         -- This isn't an error; we just don't have an old iface file to
 949                         -- look at.  Spit out a traceHiDiffs for info though.
 950                    traceHiDiffs (text "FYI: loading old interface file failed"
 951                                    $$ nest 4 (docToSDoc (pprBagOfErrors errs))) `thenM_`
 952                    return (outOfDate, Nothing)
 953
 954     ;   Just iface ->
 955
 956         -- At last, we have got the old iface; check its versions
 957     checkVersions source_unchanged iface        `thenM` \ recomp ->
 958     returnM (recomp, Just iface)
 959     }}}
 960 \end{code}
 961
 962
 963 %************************************************************************
 964 %*                                                                      *
 965         Type-check and rename supporting declarations
 966         This is used to deal with the free vars of a splice,
 967         or derived code: slurp in the necessary declarations,
 968         typecheck them, and add them to the EPS
 969 %*                                                                      *
 970 %************************************************************************
 971
 972 \begin{code}
 973 importSupportingDecls :: FreeVars -> TcM TcGblEnv
 974 -- Completely deal with the supporting imports needed
 975 -- by the specified free-var set
 976 importSupportingDecls fvs
 977  = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ;
 978         decls <- slurpImpDecls fvs ;
 979         traceRn (text "...namely:" <+> vcat (map ppr decls)) ;
 980         typecheckIfaceDecls (mkGroup decls) }
 981
 982 typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv
 983   -- The decls are all interface-file declarations
 984   -- Usually they are all from other modules, but when we are reading
 985   -- this module's interface from a file, it's possible that some of
 986   -- them are for the module being compiled.
 987   -- That is why the tcExtendX functions need to do partitioning.
 988   --
 989   -- If all the decls are from other modules, the returned TcGblEnv
 990   -- will have an empty tc_genv, but its tc_inst_env
 991   -- cache may have been augmented.
 992 typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls,
 993                                hs_instds = inst_decls,
 994                                hs_ruleds = rule_decls })
 995  = do {         -- Typecheck the type, class, and interface-sig decls
 996         tcg_env <- tcTyClDecls tycl_decls ;
 997         setGblEnv tcg_env               $ do {
 998
 999         -- Typecheck the instance decls, and rules
1000         -- Note that imported dictionary functions are already
1001         -- in scope from the preceding tcTyClDecls
1002         tcIfaceInstDecls inst_decls     `thenM` \ dfuns ->
1003         tcExtendInstEnv dfuns           $
1004         tcRules rule_decls              `thenM` \ rules ->
1005         tcExtendRules rules             $
1006
1007         getGblEnv               -- Return the environment
1008    }}
1009 \end{code}
1010
1011
1012
1013 %*********************************************************
1014 %*                                                       *
1015         mkGlobalContext: make up an interactive context
1016
1017         Used for initialising the lexical environment
1018         of the interactive read-eval-print loop
1019 %*                                                       *
1020 %*********************************************************
1021
1022 \begin{code}
1023 #ifdef GHCI
1024 mkGlobalContext
1025         :: HscEnv -> PersistentCompilerState
1026         -> [Module]     -- Expose these modules' top-level scope
1027         -> [Module]     -- Expose these modules' exports only
1028         -> IO (PersistentCompilerState, Maybe GlobalRdrEnv)
1029
1030 mkGlobalContext hsc_env pcs toplevs exports
1031   = initTc hsc_env pcs iNTERACTIVE $ do {
1032
1033     toplev_envs <- mappM getTopLevScope   toplevs ;
1034     export_envs <- mappM getModuleExports exports ;
1035     returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv
1036                    (toplev_envs ++ export_envs))
1037     }
1038
1039 getTopLevScope :: Module -> TcRn m GlobalRdrEnv
1040 getTopLevScope mod
1041   = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1042          case mi_globals iface of
1043                 Nothing  -> panic "getTopLevScope"
1044                 Just env -> returnM env }
1045
1046 getModuleExports :: Module -> TcRn m GlobalRdrEnv
1047 getModuleExports mod
1048   = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1049          returnM (foldl add emptyGlobalRdrEnv (mi_exports iface)) }
1050   where
1051     prov_fn n = NonLocalDef ImplicitImport
1052     add env (mod,avails)
1053         = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs)
1054
1055 contextDoc = text "context for compiling statements"
1056 \end{code}
1057
1058 \begin{code}
1059 getModuleContents
1060   :: HscEnv
1061   -> PersistentCompilerState    -- IN: persistent compiler state
1062   -> Module                     -- module to inspect
1063   -> Bool                       -- grab just the exports, or the whole toplev
1064   -> IO (PersistentCompilerState, Maybe [TyThing])
1065
1066 getModuleContents hsc_env pcs mod exports_only
1067  = initTc hsc_env pcs iNTERACTIVE $ do {
1068
1069         -- Load the interface if necessary (a home module will certainly
1070         -- alraedy be loaded, but a package module might not be)
1071         iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ;
1072
1073         let { export_names = availsToNameSet export_avails ;
1074               export_avails = [ avail | (mn, avails) <- mi_exports iface,
1075                                         avail <- avails ] } ;
1076
1077         all_names <- if exports_only then
1078                         return export_names
1079                      else case mi_globals iface of {
1080                            Just rdr_env ->
1081                                 return (get_locals rdr_env) ;
1082
1083                            Nothing -> do { addErr (noRdrEnvErr mod) ;
1084                                            return export_names } } ;
1085                                 -- Invariant; we only have (not exports_only)
1086                                 -- for a home module so it must already be in the HIT
1087                                 -- So the Nothing case is a bug
1088
1089         env <- importSupportingDecls all_names ;
1090         setGblEnv env (mappM tcLookupGlobal (nameSetToList all_names))
1091     }
1092   where
1093         -- Grab all the things from the global env that are locally def'd
1094     get_locals rdr_env = mkNameSet [ gre_name gre
1095                                    | elts <- rdrEnvElts rdr_env,
1096                                      gre <- elts,
1097                                      isLocalGRE gre ]
1098         -- Make a set because a name is often in the envt in
1099         -- both qualified and unqualified forms
1100
1101 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
1102                   <+> quotes (ppr mod)
1103 #endif
1104 \end{code}
1105
1106 %************************************************************************
1107 %*                                                                      *
1108         Checking for 'main'
1109 %*                                                                      *
1110 %************************************************************************
1111
1112 \begin{code}
1113 checkMain
1114   = do { ghci_mode <- getGhciMode ;
1115          tcg_env   <- getGblEnv ;
1116
1117          mb_main_mod <- readMutVar v_MainModIs ;
1118          mb_main_fn  <- readMutVar v_MainFunIs ;
1119          let { main_mod = case mb_main_mod of {
1120                                 Just mod -> mkModuleName mod ;
1121                                 Nothing  -> mAIN_Name } ;
1122                 main_fn  = case mb_main_fn of {
1123                                 Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
1124                                 Nothing -> main_RDR_Unqual } } ;
1125
1126          check_main ghci_mode tcg_env main_mod main_fn
1127     }
1128
1129
1130 check_main ghci_mode tcg_env main_mod main_fn
1131      -- If we are in module Main, check that 'main' is defined.
1132      -- It may be imported from another module, in which case
1133      -- we have to drag in its.
1134      --
1135      -- Also form the definition
1136      --         $main = runIO main
1137      -- so we need to slurp in runIO too.
1138      --
1139      -- ToDo: We have to return the main_name separately, because it's a
1140      -- bona fide 'use', and should be recorded as such, but the others
1141      -- aren't
1142      --
1143      -- Blimey: a whole page of code to do this...
1144
1145  | mod_name /= main_mod
1146  = return (tcg_env, emptyFVs)
1147
1148         -- Check that 'main' is in scope
1149         -- It might be imported from another module!
1150         --
1151         -- We use a guard for this (rather than letting lookupSrcName fail)
1152         -- because it's not an error in ghci)
1153  | not (main_fn `elemRdrEnv` rdr_env)
1154  = do { complain_no_main; return (tcg_env, emptyFVs) }
1155
1156  | otherwise    -- OK, so the appropriate 'main' is in scope
1157                 --
1158  = do { main_name <- lookupSrcName main_fn ;
1159
1160         tcg_env <- importSupportingDecls (unitFV runIOName) ;
1161
1162         addSrcLoc (getSrcLoc main_name) $
1163         addErrCtxt mainCtxt             $
1164         setGblEnv tcg_env               $ do {
1165
1166         -- $main :: IO () = runIO main
1167         let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ;
1168         (main_expr, ty) <- tcInferRho rhs ;
1169
1170         let { dollar_main_id = setIdLocalExported (mkLocalId dollarMainName ty) ;
1171               main_bind      = VarMonoBind dollar_main_id main_expr ;
1172               tcg_env'       = tcg_env { tcg_binds = tcg_binds tcg_env
1173                                                      `andMonoBinds` main_bind } } ;
1174
1175         return (tcg_env', unitFV main_name)
1176     }}
1177   where
1178     mod_name = moduleName (tcg_mod tcg_env)
1179     rdr_env  = tcg_rdr_env tcg_env
1180
1181     complain_no_main | ghci_mode == Interactive = return ()
1182                      | otherwise                = failWithTc noMainMsg
1183         -- In interactive mode, don't worry about the absence of 'main'
1184         -- In other modes, fail altogether, so that we don't go on
1185         -- and complain a second time when processing the export list.
1186
1187     mainCtxt  = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
1188     noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
1189                 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
1190 \end{code}
1191
1192
1193 %************************************************************************
1194 %*                                                                      *
1195                 Degugging output
1196 %*                                                                      *
1197 %************************************************************************
1198
1199 \begin{code}
1200 rnDump :: SDoc -> TcRn m ()
1201 -- Dump, with a banner, if -ddump-rn
1202 rnDump doc = dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc)
1203
1204 tcDump :: TcGblEnv -> TcRn m ()
1205 tcDump env
1206  = do { dflags <- getDOpts ;
1207
1208         -- Dump short output if -ddump-types or -ddump-tc
1209         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1210             (dumpTcRn short_dump) ;
1211
1212         -- Dump bindings if -ddump-tc
1213         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
1214    }
1215   where
1216     short_dump = pprTcGblEnv env
1217     full_dump  = ppr (tcg_binds env)
1218         -- NB: foreign x-d's have undefined's in their types;
1219         --     hence can't show the tc_fords
1220
1221 tcCoreDump mod_guts
1222  = do { dflags <- getDOpts ;
1223         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
1224             (dumpTcRn (pprModGuts mod_guts)) ;
1225
1226         -- Dump bindings if -ddump-tc
1227         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
1228   where
1229     full_dump = pprCoreBindings (mg_binds mod_guts)
1230
1231 -- It's unpleasant having both pprModGuts and pprModDetails here
1232 pprTcGblEnv :: TcGblEnv -> SDoc
1233 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1234                         tcg_insts    = dfun_ids,
1235                         tcg_rules    = rules,
1236                         tcg_imports  = imports })
1237   = vcat [ ppr_types dfun_ids type_env
1238          , ppr_insts dfun_ids
1239          , vcat (map ppr rules)
1240          , ppr_gen_tycons (typeEnvTyCons type_env)
1241          , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports))
1242          , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1243
1244 pprModGuts :: ModGuts -> SDoc
1245 pprModGuts (ModGuts { mg_types = type_env,
1246                       mg_rules = rules })
1247   = vcat [ ppr_types [] type_env,
1248            ppr_rules rules ]
1249
1250
1251 ppr_types :: [Var] -> TypeEnv -> SDoc
1252 ppr_types dfun_ids type_env
1253   = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1254   where
1255     ids = [id | id <- typeEnvIds type_env, want_sig id]
1256     want_sig id | opt_PprStyle_Debug = True
1257                 | otherwise          = isLocalId id &&
1258                                        isExternalName (idName id) &&
1259                                        not (id `elem` dfun_ids)
1260         -- isLocalId ignores data constructors, records selectors etc.
1261         -- The isExternalName ignores local dictionary and method bindings
1262         -- that the type checker has invented.  Top-level user-defined things
1263         -- have External names.
1264
1265 ppr_insts :: [Var] -> SDoc
1266 ppr_insts []       = empty
1267 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1268
1269 ppr_sigs :: [Var] -> SDoc
1270 ppr_sigs ids
1271         -- Print type signatures
1272         -- Convert to HsType so that we get source-language style printing
1273         -- And sort by RdrName
1274   = vcat $ map ppr_sig $ sortLt lt_sig $
1275     [ (getRdrName id, toHsType (tidyTopType (idType id)))
1276     | id <- ids ]
1277   where
1278     lt_sig (n1,_) (n2,_) = n1 < n2
1279     ppr_sig (n,t)        = ppr n <+> dcolon <+> ppr t
1280
1281
1282 ppr_rules :: [IdCoreRule] -> SDoc
1283 ppr_rules [] = empty
1284 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1285                       nest 4 (pprIdRules rs),
1286                       ptext SLIT("#-}")]
1287
1288 ppr_gen_tycons []  = empty
1289 ppr_gen_tycons tcs = vcat [ptext SLIT("Generic type constructor details:"),
1290                            nest 2 (vcat (map ppr_gen_tycon tcs))
1291                      ]
1292
1293 -- x&y are now Id's, not CoreExpr's
1294 ppr_gen_tycon tycon
1295   | Just ep <- tyConGenInfo tycon
1296   = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep)
1297
1298   | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable")
1299
1300 ppr_ep (EP from to)
1301   = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau),
1302            ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)),
1303            ptext SLIT("To:")   <+> ppr (unfoldingTemplate (idUnfolding to))
1304     ]
1305   where
1306     (_,from_tau) = tcSplitForAllTys (idType from)
1307 \end{code}