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