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         mkExportEnv, getModuleContents, tcRnStmt, tcRnThing, tcRnExpr,
  10 #endif
  11         tcRnModule,
  12         tcTopSrcDecls,
  13         tcRnExtCore
  14     ) where
  15
  16 #include "HsVersions.h"
  17
  18 #ifdef GHCI
  19 import {-# SOURCE #-} TcSplice ( tcSpliceDecls )
  20 #endif
  21
  22 import CmdLineOpts      ( DynFlag(..), opt_PprStyle_Debug, dopt )
  23 import DriverState      ( v_MainModIs, v_MainFunIs )
  24 import HsSyn
  25 import RdrHsSyn         ( findSplice )
  26
  27 import PrelNames        ( runIOName, rootMainName, mAIN_Name,
  28                           main_RDR_Unqual )
  29 import RdrName          ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv,
  30                           plusGlobalRdrEnv )
  31 import TcHsSyn          ( zonkTopDecls )
  32 import TcExpr           ( tcInferRho )
  33 import TcRnMonad
  34 import TcType           ( tidyTopType )
  35 import Inst             ( showLIE )
  36 import TcBinds          ( tcTopBinds )
  37 import TcDefaults       ( tcDefaults )
  38 import TcEnv            ( tcExtendGlobalValEnv, tcLookupGlobal )
  39 import TcRules          ( tcRules )
  40 import TcForeign        ( tcForeignImports, tcForeignExports )
  41 import TcInstDcls       ( tcInstDecls1, tcInstDecls2 )
  42 import TcIface          ( tcExtCoreBindings )
  43 import TcSimplify       ( tcSimplifyTop )
  44 import TcTyClsDecls     ( tcTyAndClassDecls )
  45 import LoadIface        ( loadOrphanModules )
  46 import RnNames          ( importsFromLocalDecls, rnImports, exportsFromAvail,
  47                           reportUnusedNames )
  48 import RnEnv            ( lookupSrcOcc_maybe )
  49 import RnSource         ( rnSrcDecls, rnTyClDecls, checkModDeprec )
  50 import PprCore          ( pprIdRules, pprCoreBindings )
  51 import CoreSyn          ( IdCoreRule, bindersOfBinds )
  52 import ErrUtils         ( mkDumpDoc, showPass )
  53 import Id               ( mkExportedLocalId, isLocalId, idName, idType )
  54 import Var              ( Var )
  55 import Module           ( mkHomeModule, mkModuleName, moduleName, moduleEnvElts )
  56 import OccName          ( mkVarOcc )
  57 import Name             ( Name, isExternalName, getSrcLoc, getOccName )
  58 import NameSet
  59 import TyCon            ( tyConHasGenerics )
  60 import SrcLoc           ( srcLocSpan, Located(..), noLoc )
  61 import Outputable
  62 import HscTypes         ( ModGuts(..), HscEnv(..),
  63                           GhciMode(..), noDependencies,
  64                           Deprecs( NoDeprecs ), plusDeprecs,
  65                           GenAvailInfo(Avail), availsToNameSet, availName,
  66                           ForeignStubs(NoStubs), TypeEnv, typeEnvTyCons,
  67                           extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons,
  68                           emptyFixityEnv
  69                         )
  70 #ifdef GHCI
  71 import HsSyn            ( HsStmtContext(..),
  72                           Stmt(..),
  73                           collectStmtsBinders, mkSimpleMatch, placeHolderType )
  74 import RdrName          ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..),
  75                           Provenance(..), ImportSpec(..),
  76                           lookupLocalRdrEnv, extendLocalRdrEnv )
  77 import RnSource         ( addTcgDUs )
  78 import TcHsSyn          ( mkHsLet, zonkTopLExpr, zonkTopBndrs )
  79 import TcExpr           ( tcCheckRho )
  80 import TcMType          ( zonkTcType )
  81 import TcMatches        ( tcStmtsAndThen, TcStmtCtxt(..) )
  82 import TcSimplify       ( tcSimplifyInteractive, tcSimplifyInfer )
  83 import TcType           ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType )
  84 import TcEnv            ( tcLookupTyCon, tcLookupId )
  85 import TyCon            ( DataConDetails(..) )
  86 import Inst             ( tcStdSyntaxName )
  87 import RnExpr           ( rnStmts, rnLExpr )
  88 import RnNames          ( exportsToAvails )
  89 import LoadIface        ( loadSrcInterface )
  90 import IfaceSyn         ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceExtName(..),
  91                           tyThingToIfaceDecl )
  92 import RnEnv            ( lookupOccRn, dataTcOccs, lookupFixityRn )
  93 import Id               ( Id, isImplicitId )
  94 import MkId             ( unsafeCoerceId )
  95 import TysWiredIn       ( mkListTy, unitTy )
  96 import IdInfo           ( GlobalIdDetails(..) )
  97 import SrcLoc           ( interactiveSrcLoc, unLoc )
  98 import Var              ( setGlobalIdDetails )
  99 import Name             ( nameOccName, nameModuleName )
 100 import NameEnv          ( delListFromNameEnv )
 101 import PrelNames        ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, returnIOName )
 102 import Module           ( ModuleName, lookupModuleEnvByName )
 103 import HscTypes         ( InteractiveContext(..),
 104                           HomeModInfo(..), typeEnvElts,
 105                           TyThing(..), availNames, icPrintUnqual,
 106                           ModIface(..), ModDetails(..) )
 107 import BasicTypes       ( RecFlag(..), Fixity )
 108 import Bag              ( unitBag )
 109 import Panic            ( ghcError, GhcException(..) )
 110 #endif
 111
 112 import FastString       ( mkFastString )
 113 import Util             ( sortLt )
 114 import Bag              ( unionBags, snocBag )
 115
 116 import Maybe            ( isJust )
 117 \end{code}
 118
 119
 120
 121 %************************************************************************
 122 %*                                                                      *
 123         Typecheck and rename a module
 124 %*                                                                      *
 125 %************************************************************************
 126
 127
 128 \begin{code}
 129 tcRnModule :: HscEnv
 130            -> Located (HsModule RdrName)
 131            -> IO (Maybe TcGblEnv)
 132
 133 tcRnModule hsc_env (L loc (HsModule maybe_mod exports
 134                                 import_decls local_decls mod_deprec))
 135  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 136
 137    let { this_mod = case maybe_mod of
 138                         Nothing  -> mkHomeModule mAIN_Name
 139                                         -- 'module M where' is omitted
 140                         Just (L _ mod) -> mod } ;
 141                                         -- The normal case
 142
 143    initTc hsc_env this_mod $
 144    addSrcSpan loc $
 145    do {         -- Deal with imports; sets tcg_rdr_env, tcg_imports
 146         (rdr_env, imports) <- rnImports import_decls ;
 147         updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env,
 148                                    tcg_imports = tcg_imports gbl `plusImportAvails` imports })
 149                      $ do {
 150         traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ;
 151                 -- Fail if there are any errors so far
 152                 -- The error printing (if needed) takes advantage
 153                 -- of the tcg_env we have now set
 154         failIfErrsM ;
 155
 156                 -- Load any orphan-module interfaces, so that
 157                 -- their rules and instance decls will be found
 158         loadOrphanModules (imp_orphs imports) ;
 159
 160         traceRn (text "rn1a") ;
 161                 -- Rename and type check the declarations
 162         tcg_env <- tcRnSrcDecls local_decls ;
 163         setGblEnv tcg_env               $ do {
 164
 165         traceRn (text "rn3") ;
 166
 167                 -- Process the export list
 168         export_avails <- exportsFromAvail (isJust maybe_mod) exports ;
 169
 170                 -- Get any supporting decls for the exports that have not already
 171                 -- been sucked in for the declarations in the body of the module.
 172                 -- (This can happen if something is imported only to be re-exported.)
 173                 --
 174                 -- Importing these supporting declarations is required
 175                 --      *only* to gether usage information
 176                 --      (see comments with MkIface.mkImportInfo for why)
 177                 -- We don't need the results, but sucking them in may side-effect
 178                 -- the ExternalPackageState, apart from recording usage
 179         mappM (tcLookupGlobal . availName) export_avails ;
 180
 181                 -- Check whether the entire module is deprecated
 182                 -- This happens only once per module
 183         let { mod_deprecs = checkModDeprec mod_deprec } ;
 184
 185                 -- Add exports and deprecations to envt
 186         let { export_fvs = availsToNameSet export_avails ;
 187               final_env  = tcg_env { tcg_exports = export_avails,
 188                                      tcg_dus = tcg_dus tcg_env `plusDU` usesOnly export_fvs,
 189                                      tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs`
 190                                                    mod_deprecs }
 191                 -- A module deprecation over-rides the earlier ones
 192              } ;
 193
 194                 -- Report unused names
 195         reportUnusedNames final_env ;
 196
 197                 -- Dump output and return
 198         tcDump final_env ;
 199         return final_env
 200     }}}}
 201 \end{code}
 202
 203
 204 %************************************************************************
 205 %*                                                                      *
 206                 The interactive interface
 207 %*                                                                      *
 208 %************************************************************************
 209
 210 \begin{code}
 211 #ifdef GHCI
 212 tcRnStmt :: HscEnv
 213          -> InteractiveContext
 214          -> LStmt RdrName
 215          -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id))
 216                 -- The returned [Name] is the same as the input except for
 217                 -- ExprStmt, in which case the returned [Name] is [itName]
 218                 --
 219                 -- The returned TypecheckedHsExpr is of type IO [ () ],
 220                 -- a list of the bound values, coerced to ().
 221
 222 tcRnStmt hsc_env ictxt rdr_stmt
 223   = initTc hsc_env iNTERACTIVE $
 224     setInteractiveContext ictxt $ do {
 225
 226     -- Rename; use CmdLineMode because tcRnStmt is only used interactively
 227     ([rn_stmt], fvs) <- rnStmts DoExpr [rdr_stmt] ;
 228     traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ;
 229     failIfErrsM ;
 230
 231     -- The real work is done here
 232     (bound_ids, tc_expr) <- tcUserStmt rn_stmt ;
 233
 234     traceTc (text "tcs 1") ;
 235     let {       -- Make all the bound ids "global" ids, now that
 236                 -- they're notionally top-level bindings.  This is
 237                 -- important: otherwise when we come to compile an expression
 238                 -- using these ids later, the byte code generator will consider
 239                 -- the occurrences to be free rather than global.
 240         global_ids     = map globaliseId bound_ids ;
 241         globaliseId id = setGlobalIdDetails id VanillaGlobal ;
 242
 243                 -- Update the interactive context
 244         rn_env   = ic_rn_local_env ictxt ;
 245         type_env = ic_type_env ictxt ;
 246
 247         bound_names = map idName global_ids ;
 248         new_rn_env  = extendLocalRdrEnv rn_env bound_names ;
 249
 250                 -- Remove any shadowed bindings from the type_env;
 251                 -- they are inaccessible but might, I suppose, cause
 252                 -- a space leak if we leave them there
 253         shadowed = [ n | name <- bound_names,
 254                          let rdr_name = mkRdrUnqual (nameOccName name),
 255                          Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ;
 256
 257         filtered_type_env = delListFromNameEnv type_env shadowed ;
 258         new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ;
 259
 260         new_ic = ictxt { ic_rn_local_env = new_rn_env,
 261                          ic_type_env     = new_type_env }
 262     } ;
 263
 264     dumpOptTcRn Opt_D_dump_tc
 265         (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids,
 266                text "Typechecked expr" <+> ppr tc_expr]) ;
 267
 268     returnM (new_ic, bound_names, tc_expr)
 269     }
 270 \end{code}
 271
 272
 273 Here is the grand plan, implemented in tcUserStmt
 274
 275         What you type                   The IO [HValue] that hscStmt returns
 276         -------------                   ------------------------------------
 277         let pat = expr          ==>     let pat = expr in return [coerce HVal x, coerce HVal y, ...]
 278                                         bindings: [x,y,...]
 279
 280         pat <- expr             ==>     expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...]
 281                                         bindings: [x,y,...]
 282
 283         expr (of IO type)       ==>     expr >>= \ v -> return [coerce HVal v]
 284           [NB: result not printed]      bindings: [it]
 285
 286         expr (of non-IO type,   ==>     let v = expr in print v >> return [coerce HVal v]
 287           result showable)              bindings: [it]
 288
 289         expr (of non-IO type,
 290           result not showable)  ==>     error
 291
 292
 293 \begin{code}
 294 ---------------------------
 295 tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id)
 296 tcUserStmt (L _ (ExprStmt expr _))
 297   = newUnique           `thenM` \ uniq ->
 298     let
 299         fresh_it = itName uniq
 300         the_bind = noLoc $ FunBind (noLoc fresh_it) False
 301                         [ mkSimpleMatch [] expr placeHolderType ]
 302     in
 303     tryTcLIE_ (do {     -- Try this if the other fails
 304                 traceTc (text "tcs 1b") ;
 305                 tc_stmts [
 306                     nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive],
 307                     nlExprStmt (nlHsApp (nlHsVar printName)
 308                                               (nlHsVar fresh_it))
 309                 ] })
 310           (do {         -- Try this first
 311                 traceTc (text "tcs 1a") ;
 312                 tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] })
 313
 314 tcUserStmt stmt = tc_stmts [stmt]
 315
 316 ---------------------------
 317 tc_stmts stmts
 318  = do { ioTyCon <- tcLookupTyCon ioTyConName ;
 319         let {
 320             ret_ty    = mkListTy unitTy ;
 321             io_ret_ty = mkTyConApp ioTyCon [ret_ty] ;
 322
 323             names = map unLoc (collectStmtsBinders stmts) ;
 324
 325             stmt_ctxt = SC { sc_what = DoExpr,
 326                              sc_rhs  = check_rhs,
 327                              sc_body = check_body,
 328                              sc_ty   = ret_ty } ;
 329
 330             check_rhs rhs rhs_ty = tcCheckRho rhs  (mkTyConApp ioTyCon [rhs_ty]) ;
 331             check_body body      = tcCheckRho body io_ret_ty ;
 332
 333                 -- mk_return builds the expression
 334                 --      returnIO @ [()] [coerce () x, ..,  coerce () z]
 335                 --
 336                 -- Despite the inconvenience of building the type applications etc,
 337                 -- this *has* to be done in type-annotated post-typecheck form
 338                 -- because we are going to return a list of *polymorphic* values
 339                 -- coerced to type (). If we built a *source* stmt
 340                 --      return [coerce x, ..., coerce z]
 341                 -- then the type checker would instantiate x..z, and we wouldn't
 342                 -- get their *polymorphic* values.  (And we'd get ambiguity errs
 343                 -- if they were overloaded, since they aren't applied to anything.)
 344             mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty])
 345                                            (noLoc $ ExplicitList unitTy (map mk_item ids)) ;
 346             mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy])
 347                                (nlHsVar id) ;
 348
 349             io_ty = mkTyConApp ioTyCon []
 350          } ;
 351
 352         -- OK, we're ready to typecheck the stmts
 353         traceTc (text "tcs 2") ;
 354         ((ids, tc_expr), lie) <- getLIE $ do {
 355             (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt stmts   $
 356                         do {
 357                             -- Look up the names right in the middle,
 358                             -- where they will all be in scope
 359                             ids <- mappM tcLookupId names ;
 360                             ret_id <- tcLookupId returnIOName ;         -- return @ IO
 361                             return (ids, [nlResultStmt (mk_return ret_id ids)]) } ;
 362
 363             io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ;
 364             return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty))
 365         } ;
 366
 367         -- Simplify the context right here, so that we fail
 368         -- if there aren't enough instances.  Notably, when we see
 369         --              e
 370         -- we use recoverTc_ to try     it <- e
 371         -- and then                     let it = e
 372         -- It's the simplify step that rejects the first.
 373         traceTc (text "tcs 3") ;
 374         const_binds <- tcSimplifyInteractive lie ;
 375
 376         -- Build result expression and zonk it
 377         let { expr = mkHsLet const_binds tc_expr } ;
 378         zonked_expr <- zonkTopLExpr expr ;
 379         zonked_ids  <- zonkTopBndrs ids ;
 380
 381         return (zonked_ids, zonked_expr)
 382         }
 383   where
 384     combine stmt (ids, stmts) = (ids, stmt:stmts)
 385 \end{code}
 386
 387
 388 tcRnExpr just finds the type of an expression
 389
 390 \begin{code}
 391 tcRnExpr :: HscEnv
 392          -> InteractiveContext
 393          -> LHsExpr RdrName
 394          -> IO (Maybe Type)
 395 tcRnExpr hsc_env ictxt rdr_expr
 396   = initTc hsc_env iNTERACTIVE $
 397     setInteractiveContext ictxt $ do {
 398
 399     (rn_expr, fvs) <- rnLExpr rdr_expr ;
 400     failIfErrsM ;
 401
 402         -- Now typecheck the expression;
 403         -- it might have a rank-2 type (e.g. :t runST)
 404     ((tc_expr, res_ty), lie)       <- getLIE (tcInferRho rn_expr) ;
 405     ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie)  ;
 406     tcSimplifyInteractive lie_top ;
 407
 408     let { all_expr_ty = mkForAllTys qtvs                $
 409                         mkFunTys (map idType dict_ids)  $
 410                         res_ty } ;
 411     zonkTcType all_expr_ty
 412     }
 413   where
 414     smpl_doc = ptext SLIT("main expression")
 415 \end{code}
 416
 417
 418 \begin{code}
 419 tcRnThing :: HscEnv
 420           -> InteractiveContext
 421           -> RdrName
 422           -> IO (Maybe [(IfaceDecl, Fixity)])
 423 -- Look up a RdrName and return all the TyThings it might be
 424 -- A capitalised RdrName is given to us in the DataName namespace,
 425 -- but we want to treat it as *both* a data constructor
 426 -- *and* as a type or class constructor;
 427 -- hence the call to dataTcOccs, and we return up to two results
 428 tcRnThing hsc_env ictxt rdr_name
 429   = initTc hsc_env iNTERACTIVE $
 430     setInteractiveContext ictxt $ do {
 431
 432         -- If the identifier is a constructor (begins with an
 433         -- upper-case letter), then we need to consider both
 434         -- constructor and type class identifiers.
 435     let { rdr_names = dataTcOccs rdr_name } ;
 436
 437         -- results :: [(Messages, Maybe Name)]
 438     results <- mapM (tryTc . lookupOccRn) rdr_names ;
 439
 440         -- The successful lookups will be (Just name)
 441     let { (warns_s, good_names) = unzip [ (msgs, name)
 442                                         | (msgs, Just name) <- results] ;
 443           errs_s = [msgs | (msgs, Nothing) <- results] } ;
 444
 445         -- Fail if nothing good happened, else add warnings
 446     if null good_names then
 447                 -- No lookup succeeded, so
 448                 -- pick the first error message and report it
 449                 -- ToDo: If one of the errors is "could be Foo.X or Baz.X",
 450                 --       while the other is "X is not in scope",
 451                 --       we definitely want the former; but we might pick the latter
 452         do { addMessages (head errs_s) ; failM }
 453       else                      -- Add deprecation warnings
 454         mapM_ addMessages warns_s ;
 455
 456         -- And lookup up the entities
 457     mapM do_one good_names
 458     }
 459   where
 460     do_one name = do { thing <- tcLookupGlobal name
 461                      ; fixity <- lookupFixityRn name
 462                      ; return (toIfaceDecl ictxt thing, fixity) }
 463
 464 toIfaceDecl :: InteractiveContext -> TyThing -> IfaceDecl
 465 toIfaceDecl ictxt thing
 466   = tyThingToIfaceDecl True {- Discard IdInfo -} ext_nm thing
 467   where
 468     unqual = icPrintUnqual ictxt
 469     ext_nm n | unqual n  = LocalTop (nameOccName n)     -- What a hack
 470              | otherwise = ExtPkg (nameModuleName n) (nameOccName n)
 471 \end{code}
 472
 473
 474 \begin{code}
 475 setInteractiveContext :: InteractiveContext -> TcRn a -> TcRn a
 476 setInteractiveContext icxt thing_inside
 477   = traceTc (text "setIC" <+> ppr (ic_type_env icxt))   `thenM_`
 478     (updGblEnv (\env -> env {tcg_rdr_env  = ic_rn_gbl_env icxt,
 479                              tcg_type_env = ic_type_env   icxt}) $
 480      updLclEnv (\env -> env {tcl_rdr = ic_rn_local_env icxt})   $
 481                thing_inside)
 482 #endif /* GHCI */
 483 \end{code}
 484
 485 %************************************************************************
 486 %*                                                                      *
 487         Type-checking external-core modules
 488 %*                                                                      *
 489 %************************************************************************
 490
 491 \begin{code}
 492 tcRnExtCore :: HscEnv
 493             -> HsExtCore RdrName
 494             -> IO (Maybe ModGuts)
 495         -- Nothing => some error occurred
 496
 497 tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds)
 498         -- The decls are IfaceDecls; all names are original names
 499  = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ;
 500
 501    initTc hsc_env this_mod $ do {
 502
 503    let { ldecls  = map noLoc decls } ;
 504
 505         -- Deal with the type declarations; first bring their stuff
 506         -- into scope, then rname them, then type check them
 507    (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ;
 508
 509    updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
 510                             tcg_imports = imports `plusImportAvails` tcg_imports gbl })
 511                   $ do {
 512
 513    rn_decls <- rnTyClDecls ldecls ;
 514    failIfErrsM ;
 515
 516         -- Dump trace of renaming part
 517    rnDump (ppr rn_decls) ;
 518
 519         -- Typecheck them all together so that
 520         -- any mutually recursive types are done right
 521    tcg_env <- checkNoErrs (tcTyAndClassDecls rn_decls) ;
 522         -- Make the new type env available to stuff slurped from interface files
 523
 524    setGblEnv tcg_env $ do {
 525
 526         -- Now the core bindings
 527    core_binds <- initIfaceExtCore (tcExtCoreBindings this_mod src_binds) ;
 528
 529         -- Wrap up
 530    let {
 531         bndrs      = bindersOfBinds core_binds ;
 532         my_exports = map (Avail . idName) bndrs ;
 533                 -- ToDo: export the data types also?
 534
 535         final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ;
 536
 537         mod_guts = ModGuts {    mg_module   = this_mod,
 538                                 mg_usages   = [],               -- ToDo: compute usage
 539                                 mg_dir_imps = [],               -- ??
 540                                 mg_deps     = noDependencies,   -- ??
 541                                 mg_exports  = my_exports,
 542                                 mg_types    = final_type_env,
 543                                 mg_insts    = tcg_insts tcg_env,
 544                                 mg_rules    = [],
 545                                 mg_binds    = core_binds,
 546
 547                                 -- Stubs
 548                                 mg_rdr_env  = emptyGlobalRdrEnv,
 549                                 mg_fix_env  = emptyFixityEnv,
 550                                 mg_deprecs  = NoDeprecs,
 551                                 mg_foreign  = NoStubs
 552                     } } ;
 553
 554    tcCoreDump mod_guts ;
 555
 556    return mod_guts
 557    }}}}
 558
 559 mkFakeGroup decls -- Rather clumsy; lots of unused fields
 560   = HsGroup {   hs_tyclds = decls,      -- This is the one we want
 561                 hs_valds = [], hs_fords = [],
 562                 hs_instds = [], hs_fixds = [], hs_depds = [],
 563                 hs_ruleds = [], hs_defds = [] }
 564 \end{code}
 565
 566
 567 %************************************************************************
 568 %*                                                                      *
 569         Type-checking the top level of a module
 570 %*                                                                      *
 571 %************************************************************************
 572
 573 \begin{code}
 574 tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv
 575         -- Returns the variables free in the decls
 576         -- Reason: solely to report unused imports and bindings
 577 tcRnSrcDecls decls
 578  = do {         -- Do all the declarations
 579         (tc_envs, lie) <- getLIE (tc_rn_src_decls decls) ;
 580
 581              -- tcSimplifyTop deals with constant or ambiguous InstIds.
 582              -- How could there be ambiguous ones?  They can only arise if a
 583              -- top-level decl falls under the monomorphism
 584              -- restriction, and no subsequent decl instantiates its
 585              -- type.  (Usually, ambiguous type variables are resolved
 586              -- during the generalisation step.)
 587         traceTc (text "Tc8") ;
 588         inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ;
 589                 -- Setting the global env exposes the instances to tcSimplifyTop
 590                 -- Setting the local env exposes the local Ids to tcSimplifyTop,
 591                 -- so that we get better error messages (monomorphism restriction)
 592
 593             -- Backsubstitution.  This must be done last.
 594             -- Even tcSimplifyTop may do some unification.
 595         traceTc (text "Tc9") ;
 596         let { (tcg_env, _) = tc_envs ;
 597               TcGblEnv { tcg_type_env = type_env, tcg_binds = binds,
 598                          tcg_rules = rules, tcg_fords = fords } = tcg_env } ;
 599
 600         (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds)
 601                                                            rules fords ;
 602
 603         let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ;
 604
 605         -- Make the new type env available to stuff slurped from interface files
 606         writeMutVar (tcg_type_env_var tcg_env) final_type_env ;
 607
 608         return (tcg_env { tcg_type_env = final_type_env,
 609                           tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' })
 610    }
 611
 612 tc_rn_src_decls :: [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv)
 613 -- Loops around dealing with each top level inter-splice group
 614 -- in turn, until it's dealt with the entire module
 615 tc_rn_src_decls ds
 616  = do { let { (first_group, group_tail) = findSplice ds } ;
 617                 -- If ds is [] we get ([], Nothing)
 618
 619         -- Type check the decls up to, but not including, the first splice
 620         tc_envs@(tcg_env,tcl_env) <- tcRnGroup first_group ;
 621
 622         -- Bale out if errors; for example, error recovery when checking
 623         -- the RHS of 'main' can mean that 'main' is not in the envt for
 624         -- the subsequent checkMain test
 625         failIfErrsM ;
 626
 627         setEnvs tc_envs $
 628
 629         -- If there is no splice, we're nearly done
 630         case group_tail of {
 631            Nothing -> do {      -- Last thing: check for `main'
 632                            tcg_env <- checkMain ;
 633                            return (tcg_env, tcl_env)
 634                       } ;
 635
 636         -- If there's a splice, we must carry on
 637            Just (SpliceDecl splice_expr, rest_ds) -> do {
 638 #ifndef GHCI
 639         failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler")
 640 #else
 641
 642         -- Rename the splice expression, and get its supporting decls
 643         (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ;
 644         failIfErrsM ;   -- Don't typecheck if renaming failed
 645
 646         -- Execute the splice
 647         spliced_decls <- tcSpliceDecls rn_splice_expr ;
 648
 649         -- Glue them on the front of the remaining decls and loop
 650         setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $
 651         tc_rn_src_decls (spliced_decls ++ rest_ds)
 652 #endif /* GHCI */
 653     }}}
 654 \end{code}
 655
 656
 657 %************************************************************************
 658 %*                                                                      *
 659         Type-checking the top level of a module
 660 %*                                                                      *
 661 %************************************************************************
 662
 663 tcRnGroup takes a bunch of top-level source-code declarations, and
 664  * renames them
 665  * gets supporting declarations from interface files
 666  * typechecks them
 667  * zonks them
 668  * and augments the TcGblEnv with the results
 669
 670 In Template Haskell it may be called repeatedly for each group of
 671 declarations.  It expects there to be an incoming TcGblEnv in the
 672 monad; it augments it and returns the new TcGblEnv.
 673
 674 \begin{code}
 675 tcRnGroup :: HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv)
 676         -- Returns the variables free in the decls, for unused-binding reporting
 677 tcRnGroup decls
 678  = do {         -- Rename the declarations
 679         (tcg_env, rn_decls) <- rnTopSrcDecls decls ;
 680         setGblEnv tcg_env $ do {
 681
 682                 -- Typecheck the declarations
 683         tcTopSrcDecls rn_decls
 684   }}
 685
 686 ------------------------------------------------
 687 rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name)
 688 rnTopSrcDecls group
 689  = do {         -- Bring top level binders into scope
 690         (rdr_env, imports) <- importsFromLocalDecls group ;
 691         updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl,
 692                                  tcg_imports = imports `plusImportAvails` tcg_imports gbl })
 693                   $ do {
 694
 695         traceRn (ptext SLIT("rnTopSrcDecls") <+> ppr rdr_env) ;
 696         failIfErrsM ;   -- No point in continuing if (say) we have duplicate declarations
 697
 698                 -- Rename the source decls
 699         (tcg_env, rn_decls) <- rnSrcDecls group ;
 700         failIfErrsM ;
 701
 702                 -- Dump trace of renaming part
 703         rnDump (ppr rn_decls) ;
 704
 705         return (tcg_env, rn_decls)
 706    }}
 707
 708 ------------------------------------------------
 709 tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv)
 710 tcTopSrcDecls
 711         (HsGroup { hs_tyclds = tycl_decls,
 712                    hs_instds = inst_decls,
 713                    hs_fords  = foreign_decls,
 714                    hs_defds  = default_decls,
 715                    hs_ruleds = rule_decls,
 716                    hs_valds  = val_binds })
 717  = do {         -- Type-check the type and class decls, and all imported decls
 718                 -- The latter come in via tycl_decls
 719         traceTc (text "Tc2") ;
 720
 721         tcg_env <- checkNoErrs (tcTyAndClassDecls tycl_decls) ;
 722         -- tcTyAndClassDecls recovers internally, but if anything gave rise to
 723         -- an error we'd better stop now, to avoid a cascade
 724
 725         -- Make these type and class decls available to stuff slurped from interface files
 726         writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ;
 727
 728
 729         setGblEnv tcg_env       $ do {
 730                 -- Source-language instances, including derivings,
 731                 -- and import the supporting declarations
 732         traceTc (text "Tc3") ;
 733         (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ;
 734         setGblEnv tcg_env       $ do {
 735
 736                 -- Foreign import declarations next.  No zonking necessary
 737                 -- here; we can tuck them straight into the global environment.
 738         traceTc (text "Tc4") ;
 739         (fi_ids, fi_decls) <- tcForeignImports foreign_decls ;
 740         tcExtendGlobalValEnv fi_ids     $ do {
 741
 742                 -- Default declarations
 743         traceTc (text "Tc4a") ;
 744         default_tys <- tcDefaults default_decls ;
 745         updGblEnv (\gbl -> gbl { tcg_default = default_tys }) $ do {
 746
 747                 -- Value declarations next
 748                 -- We also typecheck any extra binds that came out
 749                 -- of the "deriving" process (deriv_binds)
 750         traceTc (text "Tc5") ;
 751         (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ;
 752         setLclTypeEnv lcl_env   $ do {
 753
 754                 -- Second pass over class and instance declarations,
 755         traceTc (text "Tc6") ;
 756         (tcl_env, inst_binds) <- tcInstDecls2 tycl_decls inst_infos ;
 757         showLIE (text "after instDecls2") ;
 758
 759                 -- Foreign exports
 760                 -- They need to be zonked, so we return them
 761         traceTc (text "Tc7") ;
 762         (foe_binds, foe_decls) <- tcForeignExports foreign_decls ;
 763
 764                 -- Rules
 765         rules <- tcRules rule_decls ;
 766
 767                 -- Wrap up
 768         traceTc (text "Tc7a") ;
 769         tcg_env <- getGblEnv ;
 770         let { all_binds = tc_val_binds   `unionBags`
 771                           inst_binds     `unionBags`
 772                           foe_binds  ;
 773
 774                 -- Extend the GblEnv with the (as yet un-zonked)
 775                 -- bindings, rules, foreign decls
 776               tcg_env' = tcg_env {  tcg_binds = tcg_binds tcg_env `unionBags` all_binds,
 777                                     tcg_rules = tcg_rules tcg_env ++ rules,
 778                                     tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ;
 779         return (tcg_env', lcl_env)
 780     }}}}}}
 781 \end{code}
 782
 783
 784 %*********************************************************
 785 %*                                                       *
 786         mkGlobalContext: make up an interactive context
 787
 788         Used for initialising the lexical environment
 789         of the interactive read-eval-print loop
 790 %*                                                       *
 791 %*********************************************************
 792
 793 \begin{code}
 794 #ifdef GHCI
 795 mkExportEnv :: HscEnv -> [ModuleName]   -- Expose these modules' exports only
 796             -> IO GlobalRdrEnv
 797
 798 mkExportEnv hsc_env exports
 799   = do  { mb_envs <- initTc hsc_env iNTERACTIVE $
 800                      mappM getModuleExports exports
 801         ; case mb_envs of
 802              Just envs -> return (foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs)
 803              Nothing   -> return emptyGlobalRdrEnv
 804                              -- Some error; initTc will have printed it
 805     }
 806
 807 getModuleExports :: ModuleName -> TcM GlobalRdrEnv
 808 getModuleExports mod
 809   = do  { iface <- load_iface mod
 810         ; avails <- exportsToAvails (mi_exports iface)
 811         ; let { gres = [ GRE  { gre_name = name, gre_prov = vanillaProv mod,
 812                                 gre_deprec = mi_dep_fn iface name }
 813                         | avail <- avails, name <- availNames avail ] }
 814         ; returnM (mkGlobalRdrEnv gres) }
 815
 816 vanillaProv :: ModuleName -> Provenance
 817 -- We're building a GlobalRdrEnv as if the user imported
 818 -- all the specified modules into the global interactive module
 819 vanillaProv mod = Imported [ImportSpec mod mod False
 820                              (srcLocSpan interactiveSrcLoc)] False
 821 \end{code}
 822
 823 \begin{code}
 824 getModuleContents
 825   :: HscEnv
 826   -> InteractiveContext
 827   -> ModuleName                 -- Module to inspect
 828   -> Bool                       -- Grab just the exports, or the whole toplev
 829   -> IO (Maybe [IfaceDecl])
 830
 831 getModuleContents hsc_env ictxt mod exports_only
 832  = initTc hsc_env iNTERACTIVE (get_mod_contents exports_only)
 833  where
 834    get_mod_contents exports_only
 835       | not exports_only        -- We want the whole top-level type env
 836                           -- so it had better be a home module
 837       = do { hpt <- getHpt
 838            ; case lookupModuleEnvByName hpt mod of
 839                Just mod_info -> return (map (toIfaceDecl ictxt) $
 840                                         filter wantToSee $
 841                                         typeEnvElts $
 842                                         md_types (hm_details mod_info))
 843                Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod)))
 844                           -- This is a system error; the module should be in the HPT
 845            }
 846
 847       | otherwise               -- Want the exports only
 848       = do { iface <- load_iface mod
 849            ; avails <- exportsToAvails (mi_exports iface)
 850            ; mappM get_decl avails
 851         }
 852
 853    get_decl avail
 854         = do { thing <- tcLookupGlobal (availName avail)
 855              ; return (filter_decl (availOccs avail) (toIfaceDecl ictxt thing)) }
 856
 857 ---------------------
 858 filter_decl occs decl@(IfaceClass {ifSigs = sigs})
 859   = decl { ifSigs = filter (keep_sig occs) sigs }
 860 filter_decl occs decl@(IfaceData {ifCons = DataCons cons})
 861   = decl { ifCons = DataCons (filter (keep_con occs) cons) }
 862 filter_decl occs decl
 863   = decl
 864
 865 keep_sig occs (IfaceClassOp occ _ _)       = occ `elem` occs
 866 keep_con occs (IfaceConDecl occ _ _ _ _ _) = occ `elem` occs
 867
 868 availOccs avail = map nameOccName (availNames avail)
 869
 870 wantToSee (AnId id)    = not (isImplicitId id)
 871 wantToSee (ADataCon _) = False  -- They'll come via their TyCon
 872 wantToSee _            = True
 873
 874 ---------------------
 875 load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
 876                where
 877                  doc = ptext SLIT("context for compiling statements")
 878
 879 ---------------------
 880 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
 881                   <+> quotes (ppr mod)
 882 #endif
 883 \end{code}
 884
 885 %************************************************************************
 886 %*                                                                      *
 887         Checking for 'main'
 888 %*                                                                      *
 889 %************************************************************************
 890
 891 \begin{code}
 892 checkMain
 893   = do { ghci_mode <- getGhciMode ;
 894          tcg_env   <- getGblEnv ;
 895
 896          mb_main_mod <- readMutVar v_MainModIs ;
 897          mb_main_fn  <- readMutVar v_MainFunIs ;
 898          let { main_mod = case mb_main_mod of {
 899                                 Just mod -> mkModuleName mod ;
 900                                 Nothing  -> mAIN_Name } ;
 901                main_fn  = case mb_main_fn of {
 902                                 Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
 903                                 Nothing -> main_RDR_Unqual } } ;
 904
 905          check_main ghci_mode tcg_env main_mod main_fn
 906     }
 907
 908
 909 check_main ghci_mode tcg_env main_mod main_fn
 910      -- If we are in module Main, check that 'main' is defined.
 911      -- It may be imported from another module!
 912      --
 913      -- ToDo: We have to return the main_name separately, because it's a
 914      -- bona fide 'use', and should be recorded as such, but the others
 915      -- aren't
 916      --
 917      -- Blimey: a whole page of code to do this...
 918  | mod_name /= main_mod
 919  = return tcg_env
 920
 921  | otherwise
 922  = addErrCtxt mainCtxt                  $
 923    do   { mb_main <- lookupSrcOcc_maybe main_fn
 924                 -- Check that 'main' is in scope
 925                 -- It might be imported from another module!
 926         ; case mb_main of {
 927              Nothing -> do { complain_no_main
 928                            ; return tcg_env } ;
 929              Just main_name -> do
 930         { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) }
 931                         -- :Main.main :: IO () = runIO main
 932
 933         ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $
 934                              tcInferRho rhs
 935
 936         ; let { root_main_id = mkExportedLocalId rootMainName ty ;
 937                 main_bind    = noLoc (VarBind root_main_id main_expr) }
 938
 939         ; return (tcg_env { tcg_binds = tcg_binds tcg_env
 940                                         `snocBag` main_bind,
 941                             tcg_dus   = tcg_dus tcg_env
 942                                         `plusDU` usesOnly (unitFV main_name)
 943                  })
 944     }}}
 945   where
 946     mod_name = moduleName (tcg_mod tcg_env)
 947
 948     complain_no_main | ghci_mode == Interactive = return ()
 949                      | otherwise                = failWithTc noMainMsg
 950         -- In interactive mode, don't worry about the absence of 'main'
 951         -- In other modes, fail altogether, so that we don't go on
 952         -- and complain a second time when processing the export list.
 953
 954     mainCtxt  = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
 955     noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
 956                 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
 957 \end{code}
 958
 959
 960 %************************************************************************
 961 %*                                                                      *
 962                 Degugging output
 963 %*                                                                      *
 964 %************************************************************************
 965
 966 \begin{code}
 967 rnDump :: SDoc -> TcRn ()
 968 -- Dump, with a banner, if -ddump-rn
 969 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
 970
 971 tcDump :: TcGblEnv -> TcRn ()
 972 tcDump env
 973  = do { dflags <- getDOpts ;
 974
 975         -- Dump short output if -ddump-types or -ddump-tc
 976         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
 977             (dumpTcRn short_dump) ;
 978
 979         -- Dump bindings if -ddump-tc
 980         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
 981    }
 982   where
 983     short_dump = pprTcGblEnv env
 984     full_dump  = ppr (tcg_binds env)
 985         -- NB: foreign x-d's have undefined's in their types;
 986         --     hence can't show the tc_fords
 987
 988 tcCoreDump mod_guts
 989  = do { dflags <- getDOpts ;
 990         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
 991             (dumpTcRn (pprModGuts mod_guts)) ;
 992
 993         -- Dump bindings if -ddump-tc
 994         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
 995   where
 996     full_dump = pprCoreBindings (mg_binds mod_guts)
 997
 998 -- It's unpleasant having both pprModGuts and pprModDetails here
 999 pprTcGblEnv :: TcGblEnv -> SDoc
1000 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1001                         tcg_insts    = dfun_ids,
1002                         tcg_rules    = rules,
1003                         tcg_imports  = imports })
1004   = vcat [ ppr_types dfun_ids type_env
1005          , ppr_insts dfun_ids
1006          , vcat (map ppr rules)
1007          , ppr_gen_tycons (typeEnvTyCons type_env)
1008          , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports))
1009          , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1010
1011 pprModGuts :: ModGuts -> SDoc
1012 pprModGuts (ModGuts { mg_types = type_env,
1013                       mg_rules = rules })
1014   = vcat [ ppr_types [] type_env,
1015            ppr_rules rules ]
1016
1017
1018 ppr_types :: [Var] -> TypeEnv -> SDoc
1019 ppr_types dfun_ids type_env
1020   = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1021   where
1022     ids = [id | id <- typeEnvIds type_env, want_sig id]
1023     want_sig id | opt_PprStyle_Debug = True
1024                 | otherwise          = isLocalId id &&
1025                                        isExternalName (idName id) &&
1026                                        not (id `elem` dfun_ids)
1027         -- isLocalId ignores data constructors, records selectors etc.
1028         -- The isExternalName ignores local dictionary and method bindings
1029         -- that the type checker has invented.  Top-level user-defined things
1030         -- have External names.
1031
1032 ppr_insts :: [Var] -> SDoc
1033 ppr_insts []       = empty
1034 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1035
1036 ppr_sigs :: [Var] -> SDoc
1037 ppr_sigs ids
1038         -- Print type signatures; sort by OccName
1039   = vcat (map ppr_sig (sortLt lt_sig ids))
1040   where
1041     lt_sig id1 id2 = getOccName id1 < getOccName id2
1042     ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
1043
1044 ppr_rules :: [IdCoreRule] -> SDoc
1045 ppr_rules [] = empty
1046 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1047                       nest 4 (pprIdRules rs),
1048                       ptext SLIT("#-}")]
1049
1050 ppr_gen_tycons []  = empty
1051 ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"),
1052                            nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]
1053 \end{code}