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