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                         | avail <- avails, name <- availNames avail ] }
 813         ; returnM (mkGlobalRdrEnv gres) }
 814
 815 vanillaProv :: ModuleName -> Provenance
 816 -- We're building a GlobalRdrEnv as if the user imported
 817 -- all the specified modules into the global interactive module
 818 vanillaProv mod = Imported [ImportSpec mod mod False
 819                              (srcLocSpan interactiveSrcLoc)] False
 820 \end{code}
 821
 822 \begin{code}
 823 getModuleContents
 824   :: HscEnv
 825   -> InteractiveContext
 826   -> ModuleName                 -- Module to inspect
 827   -> Bool                       -- Grab just the exports, or the whole toplev
 828   -> IO (Maybe [IfaceDecl])
 829
 830 getModuleContents hsc_env ictxt mod exports_only
 831  = initTc hsc_env iNTERACTIVE (get_mod_contents exports_only)
 832  where
 833    get_mod_contents exports_only
 834       | not exports_only        -- We want the whole top-level type env
 835                           -- so it had better be a home module
 836       = do { hpt <- getHpt
 837            ; case lookupModuleEnvByName hpt mod of
 838                Just mod_info -> return (map (toIfaceDecl ictxt) $
 839                                         filter wantToSee $
 840                                         typeEnvElts $
 841                                         md_types (hm_details mod_info))
 842                Nothing -> ghcError (ProgramError (showSDoc (noRdrEnvErr mod)))
 843                           -- This is a system error; the module should be in the HPT
 844            }
 845
 846       | otherwise               -- Want the exports only
 847       = do { iface <- load_iface mod
 848            ; avails <- exportsToAvails (mi_exports iface)
 849            ; mappM get_decl avails
 850         }
 851
 852    get_decl avail
 853         = do { thing <- tcLookupGlobal (availName avail)
 854              ; return (filter_decl (availOccs avail) (toIfaceDecl ictxt thing)) }
 855
 856 ---------------------
 857 filter_decl occs decl@(IfaceClass {ifSigs = sigs})
 858   = decl { ifSigs = filter (keep_sig occs) sigs }
 859 filter_decl occs decl@(IfaceData {ifCons = DataCons cons})
 860   = decl { ifCons = DataCons (filter (keep_con occs) cons) }
 861 filter_decl occs decl
 862   = decl
 863
 864 keep_sig occs (IfaceClassOp occ _ _)       = occ `elem` occs
 865 keep_con occs (IfaceConDecl occ _ _ _ _ _) = occ `elem` occs
 866
 867 availOccs avail = map nameOccName (availNames avail)
 868
 869 wantToSee (AnId id)    = not (isImplicitId id)
 870 wantToSee (ADataCon _) = False  -- They'll come via their TyCon
 871 wantToSee _            = True
 872
 873 ---------------------
 874 load_iface mod = loadSrcInterface doc mod False {- Not boot iface -}
 875                where
 876                  doc = ptext SLIT("context for compiling statements")
 877
 878 ---------------------
 879 noRdrEnvErr mod = ptext SLIT("No top-level environment available for module")
 880                   <+> quotes (ppr mod)
 881 #endif
 882 \end{code}
 883
 884 %************************************************************************
 885 %*                                                                      *
 886         Checking for 'main'
 887 %*                                                                      *
 888 %************************************************************************
 889
 890 \begin{code}
 891 checkMain
 892   = do { ghci_mode <- getGhciMode ;
 893          tcg_env   <- getGblEnv ;
 894
 895          mb_main_mod <- readMutVar v_MainModIs ;
 896          mb_main_fn  <- readMutVar v_MainFunIs ;
 897          let { main_mod = case mb_main_mod of {
 898                                 Just mod -> mkModuleName mod ;
 899                                 Nothing  -> mAIN_Name } ;
 900                main_fn  = case mb_main_fn of {
 901                                 Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ;
 902                                 Nothing -> main_RDR_Unqual } } ;
 903
 904          check_main ghci_mode tcg_env main_mod main_fn
 905     }
 906
 907
 908 check_main ghci_mode tcg_env main_mod main_fn
 909      -- If we are in module Main, check that 'main' is defined.
 910      -- It may be imported from another module!
 911      --
 912      -- ToDo: We have to return the main_name separately, because it's a
 913      -- bona fide 'use', and should be recorded as such, but the others
 914      -- aren't
 915      --
 916      -- Blimey: a whole page of code to do this...
 917  | mod_name /= main_mod
 918  = return tcg_env
 919
 920  | otherwise
 921  = addErrCtxt mainCtxt                  $
 922    do   { mb_main <- lookupSrcOcc_maybe main_fn
 923                 -- Check that 'main' is in scope
 924                 -- It might be imported from another module!
 925         ; case mb_main of {
 926              Nothing -> do { complain_no_main
 927                            ; return tcg_env } ;
 928              Just main_name -> do
 929         { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) }
 930                         -- :Main.main :: IO () = runIO main
 931
 932         ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $
 933                              tcInferRho rhs
 934
 935         ; let { root_main_id = mkExportedLocalId rootMainName ty ;
 936                 main_bind    = noLoc (VarBind root_main_id main_expr) }
 937
 938         ; return (tcg_env { tcg_binds = tcg_binds tcg_env
 939                                         `snocBag` main_bind,
 940                             tcg_dus   = tcg_dus tcg_env
 941                                         `plusDU` usesOnly (unitFV main_name)
 942                  })
 943     }}}
 944   where
 945     mod_name = moduleName (tcg_mod tcg_env)
 946
 947     complain_no_main | ghci_mode == Interactive = return ()
 948                      | otherwise                = failWithTc noMainMsg
 949         -- In interactive mode, don't worry about the absence of 'main'
 950         -- In other modes, fail altogether, so that we don't go on
 951         -- and complain a second time when processing the export list.
 952
 953     mainCtxt  = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn)
 954     noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn)
 955                 <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod)
 956 \end{code}
 957
 958
 959 %************************************************************************
 960 %*                                                                      *
 961                 Degugging output
 962 %*                                                                      *
 963 %************************************************************************
 964
 965 \begin{code}
 966 rnDump :: SDoc -> TcRn ()
 967 -- Dump, with a banner, if -ddump-rn
 968 rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) }
 969
 970 tcDump :: TcGblEnv -> TcRn ()
 971 tcDump env
 972  = do { dflags <- getDOpts ;
 973
 974         -- Dump short output if -ddump-types or -ddump-tc
 975         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
 976             (dumpTcRn short_dump) ;
 977
 978         -- Dump bindings if -ddump-tc
 979         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
 980    }
 981   where
 982     short_dump = pprTcGblEnv env
 983     full_dump  = ppr (tcg_binds env)
 984         -- NB: foreign x-d's have undefined's in their types;
 985         --     hence can't show the tc_fords
 986
 987 tcCoreDump mod_guts
 988  = do { dflags <- getDOpts ;
 989         ifM (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
 990             (dumpTcRn (pprModGuts mod_guts)) ;
 991
 992         -- Dump bindings if -ddump-tc
 993         dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump) }
 994   where
 995     full_dump = pprCoreBindings (mg_binds mod_guts)
 996
 997 -- It's unpleasant having both pprModGuts and pprModDetails here
 998 pprTcGblEnv :: TcGblEnv -> SDoc
 999 pprTcGblEnv (TcGblEnv { tcg_type_env = type_env,
1000                         tcg_insts    = dfun_ids,
1001                         tcg_rules    = rules,
1002                         tcg_imports  = imports })
1003   = vcat [ ppr_types dfun_ids type_env
1004          , ppr_insts dfun_ids
1005          , vcat (map ppr rules)
1006          , ppr_gen_tycons (typeEnvTyCons type_env)
1007          , ptext SLIT("Dependent modules:") <+> ppr (moduleEnvElts (imp_dep_mods imports))
1008          , ptext SLIT("Dependent packages:") <+> ppr (imp_dep_pkgs imports)]
1009
1010 pprModGuts :: ModGuts -> SDoc
1011 pprModGuts (ModGuts { mg_types = type_env,
1012                       mg_rules = rules })
1013   = vcat [ ppr_types [] type_env,
1014            ppr_rules rules ]
1015
1016
1017 ppr_types :: [Var] -> TypeEnv -> SDoc
1018 ppr_types dfun_ids type_env
1019   = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids)
1020   where
1021     ids = [id | id <- typeEnvIds type_env, want_sig id]
1022     want_sig id | opt_PprStyle_Debug = True
1023                 | otherwise          = isLocalId id &&
1024                                        isExternalName (idName id) &&
1025                                        not (id `elem` dfun_ids)
1026         -- isLocalId ignores data constructors, records selectors etc.
1027         -- The isExternalName ignores local dictionary and method bindings
1028         -- that the type checker has invented.  Top-level user-defined things
1029         -- have External names.
1030
1031 ppr_insts :: [Var] -> SDoc
1032 ppr_insts []       = empty
1033 ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids)
1034
1035 ppr_sigs :: [Var] -> SDoc
1036 ppr_sigs ids
1037         -- Print type signatures; sort by OccName
1038   = vcat (map ppr_sig (sortLt lt_sig ids))
1039   where
1040     lt_sig id1 id2 = getOccName id1 < getOccName id2
1041     ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id))
1042
1043 ppr_rules :: [IdCoreRule] -> SDoc
1044 ppr_rules [] = empty
1045 ppr_rules rs = vcat [ptext SLIT("{-# RULES"),
1046                       nest 4 (pprIdRules rs),
1047                       ptext SLIT("#-}")]
1048
1049 ppr_gen_tycons []  = empty
1050 ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"),
1051                            nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))]
1052 \end{code}