X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcRnDriver.lhs;h=a9c8f98d582242246bc5e33073ac3cda444f4eaf;hb=f1fdf769b432ca383b2033f5c973494905d225d1;hp=463ff1da7a2813584de519a9ec15c9e4579d6f94;hpb=f8031f577f9667ef1ab439b11fdd15fc39a79630;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 463ff1d..a9c8f98 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -6,120 +6,132 @@ \begin{code} module TcRnDriver ( #ifdef GHCI - mkGlobalContext, getModuleContents, tcRnStmt, tcRnThing, tcRnExpr, + tcRnStmt, tcRnExpr, tcRnType, + tcRnLookupRdrName, + tcRnLookupName, + tcRnGetInfo, + getModuleExports, #endif - tcRnModule, checkOldIface, - importSupportingDecls, tcTopSrcDecls, - tcRnIface, tcRnExtCore + tcRnModule, + tcTopSrcDecls, + tcRnExtCore ) where #include "HsVersions.h" +import IO #ifdef GHCI import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) -import DsMeta ( templateHaskellNames ) #endif -import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) -import DriverState ( v_MainModIs, v_MainFunIs ) -import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..), - Stmt(..), Pat(VarPat), HsStmtContext(..), RuleDecl(..), - HsGroup(..), SpliceDecl(..), - mkSimpleMatch, placeHolderType, toHsType, andMonoBinds, - isSrcRule, collectStmtsBinders - ) -import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, RdrNameStmt, RdrNameHsExpr, - emptyGroup, mkGroup, findSplice, addImpDecls, main_RDR_Unqual ) - -import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, - returnIOName, runIOName, - rootMainName, itName, mAIN_Name, unsafeCoerceName - ) -import RdrName ( RdrName, getRdrName, mkRdrUnqual, - lookupRdrEnv, elemRdrEnv ) - -import RnHsSyn ( RenamedStmt, RenamedTyClDecl, - ruleDeclFVs, instDeclFVs, tyClDeclFVs ) -import TcHsSyn ( TypecheckedHsExpr, TypecheckedRuleDecl, - zonkTopDecls, mkHsLet, - zonkTopExpr, zonkTopBndrs - ) - -import TcExpr ( tcInferRho, tcCheckRho ) +import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) ) +import StaticFlags ( opt_PprStyle_Debug ) +import Packages ( checkForPackageConflicts, mkHomeModules ) +import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, + SpliceDecl(..), HsBind(..), LHsBinds, + emptyRdrGroup, emptyRnGroup, appendGroups, plusHsValBinds, + nlHsApp, nlHsVar, pprLHsBinds ) +import RdrHsSyn ( findSplice ) + +import PrelNames ( runMainIOName, rootMainKey, rOOT_MAIN, mAIN, + main_RDR_Unqual ) +import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv ) +import TcHsSyn ( zonkTopDecls ) +import TcExpr ( tcInferRho ) import TcRnMonad -import TcType ( Type, - tyVarsOfType, tcFunResultTy, tidyTopType, - mkForAllTys, mkFunTys, mkTyConApp, tcSplitForAllTys - ) -import Inst ( showLIE, tcStdSyntaxName ) -import TcBinds ( tcTopBinds ) -import TcClassDcl ( tcClassDecls2 ) +import TcType ( tidyTopType, tcEqType, mkTyVarTys, substTyWith ) +import Inst ( showLIE ) +import InstEnv ( extendInstEnvList, Instance, pprInstances, instanceDFunId ) +import TcBinds ( tcTopBinds, tcHsBootSigs ) import TcDefaults ( tcDefaults ) -import TcEnv ( tcExtendGlobalValEnv, - tcExtendInstEnv, tcExtendRules, - tcLookupTyCon, tcLookupGlobal, - tcLookupId - ) +import TcEnv ( tcExtendGlobalValEnv, iDFunId ) import TcRules ( tcRules ) import TcForeign ( tcForeignImports, tcForeignExports ) -import TcIfaceSig ( tcInterfaceSigs, tcCoreBinds ) -import TcInstDcls ( tcInstDecls1, tcIfaceInstDecls, tcInstDecls2 ) -import TcSimplify ( tcSimplifyTop, tcSimplifyInteractive, tcSimplifyInfer ) +import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) +import TcIface ( tcExtCoreBindings, tcHiBootIface ) +import TcSimplify ( tcSimplifyTop ) import TcTyClsDecls ( tcTyAndClassDecls ) - -import RnNames ( importsFromLocalDecls, rnImports, exportsFromAvail, - reportUnusedNames ) -import RnIfaces ( slurpImpDecls, checkVersions, RecompileRequired, outOfDate ) -import RnHiFiles ( readIface, loadOldIface ) -import RnEnv ( lookupSrcName, lookupOccRn, plusGlobalRdrEnv, - ubiquitousNames, implicitModuleFVs, implicitStmtFVs, dataTcOccs ) -import RnSource ( rnSrcDecls, checkModDeprec, rnStats ) - -import CoreUnfold ( unfoldingTemplate ) -import CoreSyn ( IdCoreRule, Bind(..) ) -import PprCore ( pprIdRules, pprCoreBindings ) -import ErrUtils ( mkDumpDoc, showPass, pprBagOfErrors ) -import Id ( Id, mkLocalId, isLocalId, idName, idType, idUnfolding, setIdLocalExported ) -import Var ( Var, setGlobalIdDetails ) -import Module ( Module, mkHomeModule, mkModuleName, moduleName, moduleUserString, moduleEnvElts ) -import OccName ( mkVarOcc ) -import Name ( Name, isExternalName, getSrcLoc, nameOccName ) +import LoadIface ( loadOrphanModules ) +import RnNames ( importsFromLocalDecls, rnImports, rnExports, + mkRdrEnvAndImports, mkExportNameSet, + reportUnusedNames, reportDeprecations ) +import RnEnv ( lookupSrcOcc_maybe ) +import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec ) +import PprCore ( pprRules, pprCoreBindings ) +import CoreSyn ( CoreRule, bindersOfBinds ) +import DataCon ( dataConWrapId ) +import ErrUtils ( Messages, mkDumpDoc, showPass ) +import Id ( Id, mkExportedLocalId, isLocalId, idName, idType ) +import Var ( Var ) +import Module ( Module, ModuleEnv, moduleEnvElts, elemModuleEnv ) +import OccName ( mkVarOccFS ) +import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName, + mkExternalName ) import NameSet -import TyCon ( tyConGenInfo ) -import BasicTypes ( EP(..), RecFlag(..) ) -import Outputable -import HscTypes ( PersistentCompilerState(..), InteractiveContext(..), - ModIface, ModDetails(..), ModGuts(..), - HscEnv(..), - ModIface(..), ModDetails(..), IfaceDecls(..), - GhciMode(..), noDependencies, - Deprecations(..), plusDeprecs, - emptyGlobalRdrEnv, - GenAvailInfo(Avail), availsToNameSet, - ForeignStubs(..), - TypeEnv, TyThing, typeEnvTyCons, - extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, - extendLocalRdrEnv, emptyFixityEnv +import TyCon ( tyConHasGenerics, isSynTyCon, synTyConDefn, tyConKind ) +import SrcLoc ( srcLocSpan, Located(..), noLoc ) +import DriverPhases ( HscSource(..), isHsBoot ) +import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails, + HscEnv(..), ExternalPackageState(..), + IsBootInterface, noDependencies, + Deprecs( NoDeprecs ), plusDeprecs, + ForeignStubs(NoStubs), TyThing(..), + TypeEnv, lookupTypeEnv, hptInstances, + extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts, + emptyFixityEnv ) +import Outputable + #ifdef GHCI -import TcMType ( zonkTcType ) -import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) ) -import RdrName ( rdrEnvElts ) -import RnExpr ( rnStmts, rnExpr ) -import RnHiFiles ( loadInterface ) -import RnEnv ( mkGlobalRdrEnv ) +import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), + HsLocalBinds(..), HsValBinds(..), + LStmt, LHsExpr, LHsType, mkMatch, emptyLocalBinds, + collectLStmtsBinders, collectLStmtBinders, nlVarPat, + mkFunBind, placeHolderType, noSyntaxExpr ) +import RdrName ( GlobalRdrElt(..), globalRdrEnvElts, + unQualOK, lookupLocalRdrEnv, extendLocalRdrEnv ) +import RnSource ( addTcgDUs ) +import TcHsSyn ( mkHsDictLet, zonkTopLExpr, zonkTopBndrs ) +import TcHsType ( kcHsType ) +import TcMType ( zonkTcType, zonkQuantifiedTyVar ) +import TcMatches ( tcStmts, tcDoStmt ) +import TcSimplify ( tcSimplifyInteractive, tcSimplifyInfer ) +import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, isTauTy, + isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType, isUnitTy ) +import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal ) +import RnTypes ( rnLHsType ) +import Inst ( tcGetInstEnvs ) +import InstEnv ( classInstances, instEnvElts ) +import RnExpr ( rnStmts, rnLExpr ) +import LoadIface ( loadSrcInterface, loadSysInterface ) +import IfaceEnv ( ifaceExportNames ) +import Module ( moduleSetElts, mkModuleSet ) +import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) +import Id ( setIdType ) +import MkId ( unsafeCoerceId ) +import TyCon ( tyConName ) import TysWiredIn ( mkListTy, unitTy ) import IdInfo ( GlobalIdDetails(..) ) -import SrcLoc ( noSrcLoc ) +import Kind ( Kind ) +import Var ( globaliseId ) +import Name ( nameOccName, nameModule, isBuiltInSyntax ) +import OccName ( isTcOcc ) import NameEnv ( delListFromNameEnv ) -import HscTypes ( GlobalRdrElt(..), GlobalRdrEnv, ImportReason(..), Provenance(..), - isLocalGRE ) +import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName, + bindIOName, thenIOName, returnIOName ) +import HscTypes ( InteractiveContext(..), + ModIface(..), icPrintUnqual, + Dependencies(..) ) +import BasicTypes ( Fixity, RecFlag(..) ) +import SrcLoc ( unLoc ) #endif import FastString ( mkFastString ) -import Panic ( showException ) -import List ( partition ) -import Util ( sortLt ) +import Maybes ( MaybeErr(..) ) +import Util ( sortLe ) +import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags ) + +import Maybe ( isJust ) \end{code} @@ -132,406 +144,139 @@ import Util ( sortLt ) \begin{code} -tcRnModule :: HscEnv -> PersistentCompilerState - -> RdrNameHsModule - -> IO (PersistentCompilerState, Maybe TcGblEnv) - -tcRnModule hsc_env pcs - (HsModule maybe_mod exports import_decls local_decls mod_deprec loc) +tcRnModule :: HscEnv + -> HscSource + -> Bool -- True <=> save renamed syntax + -> Located (HsModule RdrName) + -> IO (Messages, Maybe TcGblEnv) + +tcRnModule hsc_env hsc_src save_rn_syntax + (L loc (HsModule maybe_mod export_ies + import_decls local_decls mod_deprec)) = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; let { this_mod = case maybe_mod of - Nothing -> mkHomeModule mAIN_Name -- 'module M where' is omitted - Just mod -> mod } ; -- The normal case + Nothing -> mAIN -- 'module M where' is omitted + Just (L _ mod) -> mod } ; -- The normal case - initTc hsc_env pcs this_mod $ addSrcLoc loc $ - do { -- Deal with imports; sets tcg_rdr_env, tcg_imports - (rdr_env, imports) <- rnImports import_decls ; - updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env, - tcg_imports = tcg_imports gbl `plusImportAvails` imports }) - $ do { + initTc hsc_env hsc_src this_mod $ + setSrcSpan loc $ + do { + -- Deal with imports; + rn_imports <- rnImports import_decls ; + (rdr_env, imports) <- mkRdrEnvAndImports rn_imports ; + + let { dep_mods :: ModuleEnv (Module, IsBootInterface) + ; dep_mods = imp_dep_mods imports + + -- We want instance declarations from all home-package + -- modules below this one, including boot modules, except + -- ourselves. The 'except ourselves' is so that we don't + -- get the instances from this module's hs-boot file + ; want_instances :: Module -> Bool + ; want_instances mod = mod `elemModuleEnv` dep_mods + && mod /= this_mod + ; home_insts = hptInstances hsc_env want_instances + } ; + + -- Record boot-file info in the EPS, so that it's + -- visible to loadHiBootInterface in tcRnSrcDecls, + -- and any other incrementally-performed imports + updateEps_ (\eps -> eps { eps_is_boot = dep_mods }) ; + + checkConflicts imports this_mod $ do { + + -- Update the gbl env + updGblEnv ( \ gbl -> + gbl { tcg_rdr_env = rdr_env, + tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, + tcg_imports = tcg_imports gbl `plusImportAvails` imports, + tcg_rn_imports = if save_rn_syntax then + Just rn_imports + else + Nothing, + tcg_rn_decls = if save_rn_syntax then + Just emptyRnGroup + else + Nothing }) + $ do { + traceRn (text "rn1" <+> ppr (imp_dep_mods imports)) ; -- Fail if there are any errors so far -- The error printing (if needed) takes advantage -- of the tcg_env we have now set failIfErrsM ; + -- Load any orphan-module interfaces, so that + -- their rules and instance decls will be found + loadOrphanModules (imp_orphs imports) ; + traceRn (text "rn1a") ; -- Rename and type check the declarations - (tcg_env, src_dus) <- tcRnSrcDecls local_decls ; + tcg_env <- if isHsBoot hsc_src then + tcRnHsBootDecls local_decls + else + tcRnSrcDecls local_decls ; setGblEnv tcg_env $ do { traceRn (text "rn3") ; + + -- Report the use of any deprecated things + -- We do this before processsing the export list so + -- that we don't bleat about re-exporting a deprecated + -- thing (especially via 'module Foo' export item) + -- Only uses in the body of the module are complained about + reportDeprecations tcg_env ; + + -- Process the export list + rn_exports <- rnExports export_ies ; + exports <- mkExportNameSet (isJust maybe_mod) rn_exports ; + -- Check whether the entire module is deprecated -- This happens only once per module - -- Returns the full new deprecations; a module deprecation - -- over-rides the earlier ones let { mod_deprecs = checkModDeprec mod_deprec } ; - updGblEnv (\gbl -> gbl { tcg_deprecs = tcg_deprecs gbl `plusDeprecs` mod_deprecs }) - $ do { - -- Process the export list - export_avails <- exportsFromAvail maybe_mod exports ; - updGblEnv (\gbl -> gbl { tcg_exports = export_avails }) - $ do { - - -- Get any supporting decls for the exports that have not already - -- been sucked in for the declarations in the body of the module. - -- (This can happen if something is imported only to be re-exported.) - -- - -- Importing these supporting declarations is required - -- *only* to gether usage information - -- (see comments with MkIface.mkImportInfo for why) - -- For OneShot compilation we could just throw away the decls - -- but for Batch or Interactive we must put them in the type - -- envt because they've been removed from the holding pen - let { export_fvs = availsToNameSet export_avails } ; - tcg_env <- importSupportingDecls export_fvs ; - setGblEnv tcg_env $ do { + -- Add exports and deprecations to envt + let { final_env = tcg_env { tcg_exports = exports, + tcg_rn_exports = if save_rn_syntax then + rn_exports + else Nothing, + tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports, + tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs` + mod_deprecs } + -- A module deprecation over-rides the earlier ones + } ; -- Report unused names - let { all_dus = src_dus `plusDU` usesOnly export_fvs } ; - reportUnusedNames tcg_env all_dus ; + reportUnusedNames export_ies final_env ; -- Dump output and return - tcDump tcg_env ; - return tcg_env - }}}}}}} -\end{code} - - -%********************************************************* -%* * -\subsection{Closing up the interface decls} -%* * -%********************************************************* - -Suppose we discover we don't need to recompile. Then we start from the -IfaceDecls in the ModIface, and fluff them up by sucking in all the decls they need. - -\begin{code} -tcRnIface :: HscEnv - -> PersistentCompilerState - -> ModIface -- Get the decls from here - -> IO (PersistentCompilerState, Maybe ModDetails) - -- Nothing <=> errors happened -tcRnIface hsc_env pcs - (ModIface {mi_module = mod, mi_decls = iface_decls}) - = initTc hsc_env pcs mod $ do { - - -- Get the supporting decls, and typecheck them all together - -- so that any mutually recursive types are done right - extra_decls <- slurpImpDecls needed ; - env <- typecheckIfaceDecls (group `addImpDecls` extra_decls) ; - - returnM (ModDetails { md_types = tcg_type_env env, - md_insts = tcg_insts env, - md_rules = hsCoreRules (tcg_rules env) - -- All the rules from an interface are of the IfaceRuleOut form - }) } - where - rule_decls = dcl_rules iface_decls - inst_decls = dcl_insts iface_decls - tycl_decls = dcl_tycl iface_decls - group = emptyGroup { hs_ruleds = rule_decls, - hs_instds = inst_decls, - hs_tyclds = tycl_decls } - needed = unionManyNameSets (map ruleDeclFVs rule_decls) `unionNameSets` - unionManyNameSets (map instDeclFVs inst_decls) `unionNameSets` - unionManyNameSets (map tyClDeclFVs tycl_decls) `unionNameSets` - ubiquitousNames - -- Data type decls with record selectors, - -- which may appear in the decls, need unpackCString - -- and friends. It's easier to just grab them right now. - -hsCoreRules :: [TypecheckedRuleDecl] -> [IdCoreRule] --- All post-typechecking Iface rules have the form IfaceRuleOut -hsCoreRules rules = [(id,rule) | IfaceRuleOut id rule <- rules] -\end{code} - - -%************************************************************************ -%* * - The interactive interface -%* * -%************************************************************************ - -\begin{code} -#ifdef GHCI -tcRnStmt :: HscEnv -> PersistentCompilerState - -> InteractiveContext - -> RdrNameStmt - -> IO (PersistentCompilerState, - Maybe (InteractiveContext, [Name], TypecheckedHsExpr)) - -- The returned [Name] is the same as the input except for - -- ExprStmt, in which case the returned [Name] is [itName] - -- - -- The returned TypecheckedHsExpr is of type IO [ () ], - -- a list of the bound values, coerced to (). - -tcRnStmt hsc_env pcs ictxt rdr_stmt - = initTc hsc_env pcs iNTERACTIVE $ - setInteractiveContext ictxt $ do { - - -- Rename; use CmdLineMode because tcRnStmt is only used interactively - ([rn_stmt], fvs) <- initRnInteractive ictxt - (rnStmts DoExpr [rdr_stmt]) ; - traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; - failIfErrsM ; - - -- Suck in the supporting declarations and typecheck them - tcg_env <- importSupportingDecls (fvs `plusFV` implicitStmtFVs fvs) ; - -- NB: an earlier version deleted (rdrEnvElts local_env) from - -- the fvs. But (a) that isn't necessary, because previously - -- bound things in the local_env will be in the TypeEnv, and - -- the renamer doesn't re-slurp such things, and - -- (b) it's WRONG to delete them. Consider in GHCi: - -- Mod> let x = e :: T - -- Mod> let y = x + 3 - -- We need to pass 'x' among the fvs to slurpImpDecls, so that - -- the latter can see that T is a gate, and hence import the Num T - -- instance decl. (See the InTypEnv case in RnIfaces.slurpSourceRefs.) - setGblEnv tcg_env $ do { - - -- The real work is done here - (bound_ids, tc_expr) <- tcUserStmt rn_stmt ; - - traceTc (text "tcs 1") ; - let { -- Make all the bound ids "global" ids, now that - -- they're notionally top-level bindings. This is - -- important: otherwise when we come to compile an expression - -- using these ids later, the byte code generator will consider - -- the occurrences to be free rather than global. - global_ids = map globaliseId bound_ids ; - globaliseId id = setGlobalIdDetails id VanillaGlobal ; - - -- Update the interactive context - rn_env = ic_rn_local_env ictxt ; - type_env = ic_type_env ictxt ; - - bound_names = map idName global_ids ; - new_rn_env = extendLocalRdrEnv rn_env bound_names ; - - -- Remove any shadowed bindings from the type_env; - -- they are inaccessible but might, I suppose, cause - -- a space leak if we leave them there - shadowed = [ n | name <- bound_names, - let rdr_name = mkRdrUnqual (nameOccName name), - Just n <- [lookupRdrEnv rn_env rdr_name] ] ; - - filtered_type_env = delListFromNameEnv type_env shadowed ; - new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ; - - new_ic = ictxt { ic_rn_local_env = new_rn_env, - ic_type_env = new_type_env } - } ; - - dumpOptTcRn Opt_D_dump_tc - (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, - text "Typechecked expr" <+> ppr tc_expr]) ; - - returnM (new_ic, bound_names, tc_expr) - }} -\end{code} - - -Here is the grand plan, implemented in tcUserStmt - - What you type The IO [HValue] that hscStmt returns - ------------- ------------------------------------ - let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] - - pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] - bindings: [x,y,...] - - expr (of IO type) ==> expr >>= \ v -> return [coerce HVal v] - [NB: result not printed] bindings: [it] - - expr (of non-IO type, ==> let v = expr in print v >> return [coerce HVal v] - result showable) bindings: [it] - - expr (of non-IO type, - result not showable) ==> error - - -\begin{code} ---------------------------- -tcUserStmt :: RenamedStmt -> TcM ([Id], TypecheckedHsExpr) -tcUserStmt (ExprStmt expr _ loc) - = newUnique `thenM` \ uniq -> - let - fresh_it = itName uniq - the_bind = FunMonoBind fresh_it False - [ mkSimpleMatch [] expr placeHolderType loc ] loc - in - tryTcLIE_ (do { -- Try this if the other fails - traceTc (text "tcs 1b") ; - tc_stmts [ - LetStmt (MonoBind the_bind [] NonRecursive), - ExprStmt (HsApp (HsVar printName) (HsVar fresh_it)) - placeHolderType loc] }) - (do { -- Try this first - traceTc (text "tcs 1a") ; - tc_stmts [BindStmt (VarPat fresh_it) expr loc] }) - -tcUserStmt stmt = tc_stmts [stmt] - ---------------------------- -tc_stmts stmts - = do { ioTyCon <- tcLookupTyCon ioTyConName ; - let { - ret_ty = mkListTy unitTy ; - names = collectStmtsBinders stmts ; - - stmt_ctxt = SC { sc_what = DoExpr, - sc_rhs = check_rhs, - sc_body = check_body, - sc_ty = ret_ty } ; - - check_rhs rhs rhs_ty = tcCheckRho rhs (mkTyConApp ioTyCon [rhs_ty]) ; - check_body body = tcCheckRho body (mkTyConApp ioTyCon [ret_ty]) ; - - -- ret_expr is the expression - -- returnIO [coerce () x, .., coerce () z] - ret_stmt = ResultStmt ret_expr noSrcLoc ; - ret_expr = HsApp (HsVar returnIOName) - (ExplicitList placeHolderType (map mk_item names)) ; - mk_item name = HsApp (HsVar unsafeCoerceName) (HsVar name) ; - - all_stmts = stmts ++ [ret_stmt] ; - - io_ty = mkTyConApp ioTyCon [] - } ; - - -- OK, we're ready to typecheck the stmts - traceTc (text "tcs 2") ; - ((ids, tc_expr), lie) <- getLIE $ do { - (ids, tc_stmts) <- tcStmtsAndThen combine stmt_ctxt all_stmts $ - do { - -- Look up the names right in the middle, - -- where they will all be in scope - ids <- mappM tcLookupId names ; - return (ids, []) } ; - io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ; - return (ids, HsDo DoExpr tc_stmts io_ids - (mkTyConApp ioTyCon [ret_ty]) noSrcLoc) - } ; - - -- Simplify the context right here, so that we fail - -- if there aren't enough instances. Notably, when we see - -- e - -- we use recoverTc_ to try it <- e - -- and then let it = e - -- It's the simplify step that rejects the first. - traceTc (text "tcs 3") ; - const_binds <- tcSimplifyInteractive lie ; - - -- Build result expression and zonk it - let { expr = mkHsLet const_binds tc_expr } ; - zonked_expr <- zonkTopExpr expr ; - zonked_ids <- zonkTopBndrs ids ; - - return (zonked_ids, zonked_expr) - } - where - combine stmt (ids, stmts) = (ids, stmt:stmts) + tcDump final_env ; + return final_env + }}}}} + + +-- The program is not allowed to contain two modules with the same +-- name, and we check for that here. It could happen if the home package +-- contains a module that is also present in an external package, for example. +checkConflicts imports this_mod and_then = do + dflags <- getDOpts + let + dep_mods = this_mod : map fst (moduleEnvElts (imp_dep_mods imports)) + -- don't forget to include the current module! + + mb_dep_pkgs = checkForPackageConflicts + dflags dep_mods (imp_dep_pkgs imports) + -- + case mb_dep_pkgs of + Failed msg -> + do addErr msg; failM + Succeeded _ -> + updGblEnv (\gbl -> gbl{ tcg_home_mods = mkHomeModules dep_mods }) + and_then \end{code} -tcRnExpr just finds the type of an expression - -\begin{code} -tcRnExpr :: HscEnv -> PersistentCompilerState - -> InteractiveContext - -> RdrNameHsExpr - -> IO (PersistentCompilerState, Maybe Type) -tcRnExpr hsc_env pcs ictxt rdr_expr - = initTc hsc_env pcs iNTERACTIVE $ - setInteractiveContext ictxt $ do { - - (rn_expr, fvs) <- initRnInteractive ictxt (rnExpr rdr_expr) ; - failIfErrsM ; - - -- Suck in the supporting declarations and typecheck them - tcg_env <- importSupportingDecls (fvs `plusFV` ubiquitousNames) ; - setGblEnv tcg_env $ do { - - -- Now typecheck the expression; - -- it might have a rank-2 type (e.g. :t runST) - ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ; - ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ; - tcSimplifyInteractive lie_top ; - - let { all_expr_ty = mkForAllTys qtvs $ - mkFunTys (map idType dict_ids) $ - res_ty } ; - zonkTcType all_expr_ty - }} - where - smpl_doc = ptext SLIT("main expression") -\end{code} - - -\begin{code} -tcRnThing :: HscEnv -> PersistentCompilerState - -> InteractiveContext - -> RdrName - -> IO (PersistentCompilerState, Maybe [TyThing]) --- Look up a RdrName and return all the TyThings it might be --- We treat a capitalised RdrName as both a data constructor --- and as a type or class constructor; hence we return up to two results -tcRnThing hsc_env pcs ictxt rdr_name - = initTc hsc_env pcs iNTERACTIVE $ - setInteractiveContext ictxt $ do { - - -- If the identifier is a constructor (begins with an - -- upper-case letter), then we need to consider both - -- constructor and type class identifiers. - let { rdr_names = dataTcOccs rdr_name } ; - - -- results :: [(Messages, Maybe Name)] - results <- initRnInteractive ictxt - (mapM (tryTc . lookupOccRn) rdr_names) ; - - -- The successful lookups will be (Just name) - let { (warns_s, good_names) = unzip [ (msgs, name) - | (msgs, Just name) <- results] ; - errs_s = [msgs | (msgs, Nothing) <- results] } ; - - -- Fail if nothing good happened, else add warnings - if null good_names then -- Fail - do { addMessages (head errs_s) ; failM } - else -- Add deprecation warnings - mapM_ addMessages warns_s ; - - -- Slurp in the supporting declarations - tcg_env <- importSupportingDecls (mkFVs good_names) ; - setGblEnv tcg_env $ do { - - -- And lookup up the entities - mapM tcLookupGlobal good_names - }} -\end{code} - - -\begin{code} -setInteractiveContext :: InteractiveContext -> TcRn m a -> TcRn m a -setInteractiveContext icxt thing_inside - = traceTc (text "setIC" <+> ppr (ic_type_env icxt)) `thenM_` - updGblEnv (\ env -> env { tcg_rdr_env = ic_rn_gbl_env icxt, - tcg_type_env = ic_type_env icxt }) - thing_inside - -initRnInteractive :: InteractiveContext -> RnM a -> TcM a --- Set the local RdrEnv from the interactive context -initRnInteractive ictxt rn_thing - = initRn CmdLineMode $ - setLocalRdrEnv (ic_rn_local_env ictxt) $ - rn_thing -#endif /* GHCI */ -\end{code} - %************************************************************************ %* * Type-checking external-core modules @@ -539,61 +284,60 @@ initRnInteractive ictxt rn_thing %************************************************************************ \begin{code} -tcRnExtCore :: HscEnv -> PersistentCompilerState - -> RdrNameHsModule - -> IO (PersistentCompilerState, Maybe ModGuts) +tcRnExtCore :: HscEnv + -> HsExtCore RdrName + -> IO (Messages, Maybe ModGuts) -- Nothing => some error occurred -tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc) - -- For external core, the module name is syntactically reqd - -- Rename the (Core) module. It's a bit like an interface - -- file: all names are original names +tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) + -- The decls are IfaceDecls; all names are original names = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; - initTc hsc_env pcs this_mod $ addSrcLoc loc $ do { + initTc hsc_env ExtCoreFile this_mod $ do { - -- Rename the source, only in interface mode. - -- rnSrcDecls handles fixity decls etc too, which won't occur - -- but that doesn't matter - let { local_group = mkGroup decls } ; - (_, rn_src_decls, dus) <- initRn (InterfaceMode this_mod) - (rnSrcDecls local_group) ; - failIfErrsM ; + let { ldecls = map noLoc decls } ; + + -- Deal with the type declarations; first bring their stuff + -- into scope, then rname them, then type check them + tcg_env <- importsFromLocalDecls (mkFakeGroup ldecls) ; - -- Get the supporting decls - rn_imp_decls <- slurpImpDecls (duUses dus) ; - let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ; + setGblEnv tcg_env $ do { + + rn_decls <- rnTyClDecls ldecls ; + failIfErrsM ; -- Dump trace of renaming part rnDump (ppr rn_decls) ; - rnStats rn_imp_decls ; -- Typecheck them all together so that -- any mutually recursive types are done right - tcg_env <- typecheckIfaceDecls rn_decls ; + tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails rn_decls) ; + -- Make the new type env available to stuff slurped from interface files + setGblEnv tcg_env $ do { -- Now the core bindings - core_prs <- tcCoreBinds (hs_coreds rn_decls) ; - tcExtendGlobalValEnv (map fst core_prs) $ do { - + core_binds <- initIfaceExtCore (tcExtCoreBindings src_binds) ; + -- Wrap up let { - bndrs = map fst core_prs ; - my_exports = map (Avail . idName) bndrs ; + bndrs = bindersOfBinds core_binds ; + my_exports = mkNameSet (map idName bndrs) ; -- ToDo: export the data types also? final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; mod_guts = ModGuts { mg_module = this_mod, + mg_boot = False, mg_usages = [], -- ToDo: compute usage mg_dir_imps = [], -- ?? mg_deps = noDependencies, -- ?? + mg_home_mods = mkHomeModules [], -- ?? wrong!! mg_exports = my_exports, mg_types = final_type_env, mg_insts = tcg_insts tcg_env, - mg_rules = hsCoreRules (tcg_rules tcg_env), - mg_binds = [Rec core_prs], + mg_rules = [], + mg_binds = core_binds, -- Stubs mg_rdr_env = emptyGlobalRdrEnv, @@ -606,6 +350,9 @@ tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc) return mod_guts }}}} + +mkFakeGroup decls -- Rather clumsy; lots of unused fields + = emptyRdrGroup { hs_tyclds = decls } \end{code} @@ -616,12 +363,19 @@ tcRnExtCore hsc_env pcs (HsModule (Just this_mod) _ _ decls _ loc) %************************************************************************ \begin{code} -tcRnSrcDecls :: [RdrNameHsDecl] -> TcM (TcGblEnv, DefUses) +tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv -- Returns the variables free in the decls -- Reason: solely to report unused imports and bindings tcRnSrcDecls decls - = do { -- Do all the declarations - ((tc_envs, dus), lie) <- getLIE (tc_rn_src_decls decls) ; + = do { -- Load the hi-boot interface for this module, if any + -- We do this now so that the boot_names can be passed + -- to tcTyAndClassDecls, because the boot_names are + -- automatically considered to be loop breakers + mod <- getModule ; + boot_iface <- tcHiBootIface mod ; + + -- Do all the declarations + (tc_envs, lie) <- getLIE (tc_rn_src_decls boot_iface decls) ; -- tcSimplifyTop deals with constant or ambiguous InstIds. -- How could there be ambiguous ones? They can only arise if a @@ -630,11 +384,10 @@ tcRnSrcDecls decls -- type. (Usually, ambiguous type variables are resolved -- during the generalisation step.) traceTc (text "Tc8") ; - setEnvs tc_envs $ do { + inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ; -- Setting the global env exposes the instances to tcSimplifyTop - -- Setting the local env exposes the local Ids, so that - -- we get better error messages (monomorphism restriction) - inst_binds <- tcSimplifyTop lie ; + -- Setting the local env exposes the local Ids to tcSimplifyTop, + -- so that we get better error messages (monomorphism restriction) -- Backsubstitution. This must be done last. -- Even tcSimplifyTop may do some unification. @@ -643,22 +396,34 @@ tcRnSrcDecls decls TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, tcg_rules = rules, tcg_fords = fords } = tcg_env } ; - (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds) + tcDump tcg_env ; + (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds) rules fords ; - return (tcg_env { tcg_type_env = extendTypeEnvWithIds type_env bind_ids, - tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' }, - dus) - }} + let { final_type_env = extendTypeEnvWithIds type_env bind_ids + ; tcg_env' = tcg_env { tcg_type_env = final_type_env, + tcg_binds = binds', + tcg_rules = rules', + tcg_fords = fords' } } ; + + -- Make the new type env available to stuff slurped from interface files + writeMutVar (tcg_type_env_var tcg_env) final_type_env ; + + -- Compare the hi-boot iface (if any) with the real thing + dfun_binds <- checkHiBootIface tcg_env' boot_iface ; -tc_rn_src_decls :: [RdrNameHsDecl] -> TcM ((TcGblEnv, TcLclEnv), DefUses) + return (tcg_env' { tcg_binds = tcg_binds tcg_env' `unionBags` dfun_binds }) + } -tc_rn_src_decls ds +tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) +-- Loops around dealing with each top level inter-splice group +-- in turn, until it's dealt with the entire module +tc_rn_src_decls boot_details ds = do { let { (first_group, group_tail) = findSplice ds } ; -- If ds is [] we get ([], Nothing) -- Type check the decls up to, but not including, the first splice - (tc_envs@(_,tcl_env), src_dus1) <- tcRnGroup first_group ; + tc_envs@(tcg_env,tcl_env) <- tcRnGroup boot_details first_group ; -- Bale out if errors; for example, error recovery when checking -- the RHS of 'main' can mean that 'main' is not in the envt for @@ -670,36 +435,169 @@ tc_rn_src_decls ds -- If there is no splice, we're nearly done case group_tail of { Nothing -> do { -- Last thing: check for `main' - (tcg_env, main_fvs) <- checkMain ; - return ((tcg_env, tcl_env), - src_dus1 `plusDU` usesOnly main_fvs) + tcg_env <- checkMain ; + return (tcg_env, tcl_env) } ; -- If there's a splice, we must carry on - Just (SpliceDecl splice_expr splice_loc, rest_ds) -> do { + Just (SpliceDecl splice_expr, rest_ds) -> do { #ifndef GHCI failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler") #else -- Rename the splice expression, and get its supporting decls - (rn_splice_expr, splice_fvs) <- initRn SourceMode $ - addSrcLoc splice_loc $ - rnExpr splice_expr ; - tcg_env <- importSupportingDecls (splice_fvs `plusFV` templateHaskellNames) ; - setGblEnv tcg_env $ do { + (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ; + failIfErrsM ; -- Don't typecheck if renaming failed -- Execute the splice spliced_decls <- tcSpliceDecls rn_splice_expr ; -- Glue them on the front of the remaining decls and loop - (tc_envs, src_dus2) <- tc_rn_src_decls (spliced_decls ++ rest_ds) ; - - return (tc_envs, src_dus1 `plusDU` usesOnly splice_fvs `plusDU` src_dus2) - } + setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ + tc_rn_src_decls boot_details (spliced_decls ++ rest_ds) #endif /* GHCI */ }}} \end{code} +%************************************************************************ +%* * + Compiling hs-boot source files, and + comparing the hi-boot interface with the real thing +%* * +%************************************************************************ + +\begin{code} +tcRnHsBootDecls :: [LHsDecl RdrName] -> TcM TcGblEnv +tcRnHsBootDecls decls + = do { let { (first_group, group_tail) = findSplice decls } + + ; case group_tail of + Just stuff -> spliceInHsBootErr stuff + Nothing -> return () + + -- Rename the declarations + ; (tcg_env, rn_group) <- rnTopSrcDecls first_group + ; setGblEnv tcg_env $ do { + + -- Todo: check no foreign decls, no rules, no default decls + + -- Typecheck type/class decls + ; traceTc (text "Tc2") + ; let tycl_decls = hs_tyclds rn_group + ; tcg_env <- checkNoErrs (tcTyAndClassDecls emptyModDetails tycl_decls) + ; setGblEnv tcg_env $ do { + + -- Typecheck instance decls + ; traceTc (text "Tc3") + ; (tcg_env, inst_infos, _binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group) + ; setGblEnv tcg_env $ do { + + -- Typecheck value declarations + ; traceTc (text "Tc5") + ; val_ids <- tcHsBootSigs (hs_valds rn_group) + + -- Wrap up + -- No simplification or zonking to do + ; traceTc (text "Tc7a") + ; gbl_env <- getGblEnv + + -- Make the final type-env + -- Include the dfun_ids so that their type sigs get + -- are written into the interface file + ; let { type_env0 = tcg_type_env gbl_env + ; type_env1 = extendTypeEnvWithIds type_env0 val_ids + ; type_env2 = extendTypeEnvWithIds type_env1 dfun_ids + ; dfun_ids = map iDFunId inst_infos } + ; return (gbl_env { tcg_type_env = type_env2 }) + }}}} + +spliceInHsBootErr (SpliceDecl (L loc _), _) + = addErrAt loc (ptext SLIT("Splices are not allowed in hs-boot files")) +\end{code} + +Once we've typechecked the body of the module, we want to compare what +we've found (gathered in a TypeEnv) with the hi-boot details (if any). + +\begin{code} +checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id) +-- Compare the hi-boot file for this module (if there is one) +-- with the type environment we've just come up with +-- In the common case where there is no hi-boot file, the list +-- of boot_names is empty. +-- +-- The bindings we return give bindings for the dfuns defined in the +-- hs-boot file, such as $fbEqT = $fEqT + +checkHiBootIface + (TcGblEnv { tcg_insts = local_insts, tcg_type_env = local_type_env }) + (ModDetails { md_insts = boot_insts, md_types = boot_type_env }) + = do { mapM_ check_one (typeEnvElts boot_type_env) + ; dfun_binds <- mapM check_inst boot_insts + ; return (unionManyBags dfun_binds) } + where + check_one boot_thing + | no_check name + = return () + | otherwise + = case lookupTypeEnv local_type_env name of + Nothing -> addErrTc (missingBootThing boot_thing) + Just real_thing -> check_thing boot_thing real_thing + where + name = getName boot_thing + + no_check name = isWiredInName name -- No checking for wired-in names. In particular, + -- 'error' is handled by a rather gross hack + -- (see comments in GHC.Err.hs-boot) + || name `elem` dfun_names + dfun_names = map getName boot_insts + + check_inst boot_inst + = case [dfun | inst <- local_insts, + let dfun = instanceDFunId inst, + idType dfun `tcEqType` boot_inst_ty ] of + [] -> do { addErrTc (instMisMatch boot_inst); return emptyBag } + (dfun:_) -> return (unitBag $ noLoc $ VarBind local_boot_dfun (nlHsVar dfun)) + where + boot_dfun = instanceDFunId boot_inst + boot_inst_ty = idType boot_dfun + local_boot_dfun = mkExportedLocalId (idName boot_dfun) boot_inst_ty + +---------------- +check_thing (ATyCon boot_tc) (ATyCon real_tc) + | isSynTyCon boot_tc && isSynTyCon real_tc, + defn1 `tcEqType` substTyWith tvs2 (mkTyVarTys tvs1) defn2 + = return () + + | tyConKind boot_tc == tyConKind real_tc + = return () + where + (tvs1, defn1) = synTyConDefn boot_tc + (tvs2, defn2) = synTyConDefn boot_tc + +check_thing (AnId boot_id) (AnId real_id) + | idType boot_id `tcEqType` idType real_id + = return () + +check_thing (ADataCon dc1) (ADataCon dc2) + | idType (dataConWrapId dc1) `tcEqType` idType (dataConWrapId dc2) + = return () + + -- Can't declare a class in a hi-boot file + +check_thing boot_thing real_thing -- Default case; failure + = addErrAt (srcLocSpan (getSrcLoc real_thing)) + (bootMisMatch real_thing) + +---------------- +missingBootThing thing + = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module") +bootMisMatch thing + = ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file") +instMisMatch inst + = hang (ppr inst) + 2 (ptext SLIT("is defined in the hs-boot file, but not in the module")) +\end{code} + %************************************************************************ %* * @@ -719,53 +617,46 @@ declarations. It expects there to be an incoming TcGblEnv in the monad; it augments it and returns the new TcGblEnv. \begin{code} -tcRnGroup :: HsGroup RdrName -> TcM ((TcGblEnv, TcLclEnv), DefUses) +tcRnGroup :: ModDetails -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv) -- Returns the variables free in the decls, for unused-binding reporting -tcRnGroup decls +tcRnGroup boot_details decls = do { -- Rename the declarations - (tcg_env, rn_decls, src_dus) <- rnTopSrcDecls decls ; + (tcg_env, rn_decls) <- rnTopSrcDecls decls ; setGblEnv tcg_env $ do { -- Typecheck the declarations - tc_envs <- tcTopSrcDecls rn_decls ; - - return (tc_envs, src_dus) + tcTopSrcDecls boot_details rn_decls }} ------------------------------------------------ -rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name, DefUses) +rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) rnTopSrcDecls group = do { -- Bring top level binders into scope - (rdr_env, imports) <- importsFromLocalDecls group ; - updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` - tcg_rdr_env gbl, - tcg_imports = imports `plusImportAvails` - tcg_imports gbl }) - $ do { + tcg_env <- importsFromLocalDecls group ; + setGblEnv tcg_env $ do { failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations -- Rename the source decls - (tcg_env, rn_src_decls, src_dus) <- initRn SourceMode (rnSrcDecls group) ; - setGblEnv tcg_env $ do { - + (tcg_env, rn_decls) <- rnSrcDecls group ; failIfErrsM ; - -- Import consquential imports - let { src_fvs = duUses src_dus } ; - rn_imp_decls <- slurpImpDecls (src_fvs `plusFV` implicitModuleFVs src_fvs) ; - let { rn_decls = rn_src_decls `addImpDecls` rn_imp_decls } ; + -- save the renamed syntax, if we want it + let { tcg_env' + | Just grp <- tcg_rn_decls tcg_env + = tcg_env{ tcg_rn_decls = Just (appendGroups grp rn_decls) } + | otherwise + = tcg_env }; -- Dump trace of renaming part rnDump (ppr rn_decls) ; - rnStats rn_imp_decls ; - return (tcg_env, rn_decls, src_dus) - }}} + return (tcg_env', rn_decls) + }} ------------------------------------------------ -tcTopSrcDecls :: HsGroup Name -> TcM (TcGblEnv, TcLclEnv) -tcTopSrcDecls +tcTopSrcDecls :: ModDetails -> HsGroup Name -> TcM (TcGblEnv, TcLclEnv) +tcTopSrcDecls boot_details (HsGroup { hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_fords = foreign_decls, @@ -775,24 +666,27 @@ tcTopSrcDecls = do { -- Type-check the type and class decls, and all imported decls -- The latter come in via tycl_decls traceTc (text "Tc2") ; - tcg_env <- tcTyClDecls tycl_decls ; - setGblEnv tcg_env $ do { + tcg_env <- checkNoErrs (tcTyAndClassDecls boot_details tycl_decls) ; + -- tcTyAndClassDecls recovers internally, but if anything gave rise to + -- an error we'd better stop now, to avoid a cascade + + -- Make these type and class decls available to stuff slurped from interface files + writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ; + + + setGblEnv tcg_env $ do { -- Source-language instances, including derivings, -- and import the supporting declarations traceTc (text "Tc3") ; - (tcg_env, inst_infos, deriv_binds, fvs) <- tcInstDecls1 tycl_decls inst_decls ; - setGblEnv tcg_env $ do { - tcg_env <- importSupportingDecls fvs ; + (tcg_env, inst_infos, deriv_binds) <- tcInstDecls1 tycl_decls inst_decls ; setGblEnv tcg_env $ do { -- Foreign import declarations next. No zonking necessary -- here; we can tuck them straight into the global environment. traceTc (text "Tc4") ; (fi_ids, fi_decls) <- tcForeignImports foreign_decls ; - tcExtendGlobalValEnv fi_ids $ - updGblEnv (\gbl -> gbl { tcg_fords = tcg_fords gbl ++ fi_decls }) - $ do { + tcExtendGlobalValEnv fi_ids $ do { -- Default declarations traceTc (text "Tc4a") ; @@ -801,17 +695,14 @@ tcTopSrcDecls -- Value declarations next -- We also typecheck any extra binds that came out - -- of the "deriving" process + -- of the "deriving" process (deriv_binds) traceTc (text "Tc5") ; - (tc_val_binds, lcl_env) <- tcTopBinds (val_binds `ThenBinds` deriv_binds) ; - setLclTypeEnv lcl_env $ do { + (tc_val_binds, tcl_env) <- tcTopBinds (val_binds `plusHsValBinds` deriv_binds) ; + setLclTypeEnv tcl_env $ do { -- Second pass over class and instance declarations, - -- plus rules and foreign exports, to generate bindings traceTc (text "Tc6") ; - (cls_dm_binds, dm_ids) <- tcClassDecls2 tycl_decls ; - tcExtendGlobalValEnv dm_ids $ do { - inst_binds <- tcInstDecls2 inst_infos ; + (inst_binds, tcl_env) <- tcInstDecls2 tycl_decls inst_infos ; showLIE (text "after instDecls2") ; -- Foreign exports @@ -820,371 +711,552 @@ tcTopSrcDecls (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; -- Rules - -- Need to partition them because the source rules - -- must be zonked before adding them to tcg_rules - -- NB: built-in rules come in as IfaceRuleOut's, and - -- get added to tcg_rules right here by tcExtendRules rules <- tcRules rule_decls ; - let { (src_rules, iface_rules) = partition isSrcRule rules } ; - tcExtendRules iface_rules $ do { -- Wrap up + traceTc (text "Tc7a") ; tcg_env <- getGblEnv ; - let { all_binds = tc_val_binds `AndMonoBinds` - inst_binds `AndMonoBinds` - cls_dm_binds `AndMonoBinds` + let { all_binds = tc_val_binds `unionBags` + inst_binds `unionBags` foe_binds ; -- Extend the GblEnv with the (as yet un-zonked) -- bindings, rules, foreign decls - tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `andMonoBinds` all_binds, - tcg_rules = tcg_rules tcg_env ++ src_rules, - tcg_fords = tcg_fords tcg_env ++ foe_decls } } ; - - return (tcg_env', lcl_env) - }}}}}}}}} + tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds, + tcg_rules = tcg_rules tcg_env ++ rules, + tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; + return (tcg_env', tcl_env) + }}}}}} \end{code} -\begin{code} -tcTyClDecls :: [RenamedTyClDecl] - -> TcM TcGblEnv - --- tcTyClDecls deals with --- type and class decls (some source, some imported) --- interface signatures (checked lazily) --- --- It returns the TcGblEnv for this module, and side-effects the --- persistent compiler state to reflect the things imported from --- other modules - -tcTyClDecls tycl_decls - = checkNoErrs $ - -- tcTyAndClassDecls recovers internally, but if anything gave rise to - -- an error we'd better stop now, to avoid a cascade - - traceTc (text "TyCl1") `thenM_` - tcTyAndClassDecls tycl_decls `thenM` \ tcg_env -> - -- Returns the extended environment - setGblEnv tcg_env $ - - traceTc (text "TyCl2") `thenM_` - tcInterfaceSigs tycl_decls `thenM` \ tcg_env -> - -- Returns the extended environment - - returnM tcg_env -\end{code} - - %************************************************************************ %* * - Load the old interface file for this module (unless - we have it aleady), and check whether it is up to date - + Checking for 'main' %* * %************************************************************************ \begin{code} -checkOldIface :: HscEnv - -> PersistentCompilerState - -> Module - -> FilePath -- Where the interface file is - -> Bool -- Source unchanged - -> Maybe ModIface -- Old interface from compilation manager, if any - -> IO (PersistentCompilerState, Maybe (RecompileRequired, Maybe ModIface)) - -- Nothing <=> errors happened - -checkOldIface hsc_env pcs mod iface_path source_unchanged maybe_iface - = do { showPass (hsc_dflags hsc_env) - ("Checking old interface for " ++ moduleUserString mod) ; - - initTc hsc_env pcs mod - (check_old_iface iface_path source_unchanged maybe_iface) - } - -check_old_iface iface_path source_unchanged maybe_iface - = -- CHECK WHETHER THE SOURCE HAS CHANGED - ifM (not source_unchanged) - (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) - `thenM_` - - -- If the source has changed and we're in interactive mode, avoid reading - -- an interface; just return the one we might have been supplied with. - getGhciMode `thenM` \ ghci_mode -> - if (ghci_mode == Interactive) && not source_unchanged then - returnM (outOfDate, maybe_iface) - else - - case maybe_iface of { - Just old_iface -> -- Use the one we already have - checkVersions source_unchanged old_iface `thenM` \ recomp -> - returnM (recomp, Just old_iface) - - ; Nothing -> - - -- Try and read the old interface for the current module - -- from the .hi file left from the last time we compiled it - getModule `thenM` \ this_mod -> - readIface this_mod iface_path False `thenM` \ read_result -> - case read_result of { - Left err -> -- Old interface file not found, or garbled; give up - traceHiDiffs (text "FYI: cannot read old interface file:" - $$ nest 4 (text (showException err))) `thenM_` - returnM (outOfDate, Nothing) - - ; Right parsed_iface -> - - -- We found the file and parsed it; now load it - tryTc (initRn (InterfaceMode this_mod) - (loadOldIface parsed_iface)) `thenM` \ ((_,errs), mb_iface) -> - case mb_iface of { - Nothing -> -- Something went wrong in loading. The main likely thing - -- is that the usages mentioned B.f, where B.hi and B.hs no - -- longer exist. Then newGlobalName2 fails with an error message - -- This isn't an error; we just don't have an old iface file to - -- look at. Spit out a traceHiDiffs for info though. - traceHiDiffs (text "FYI: loading old interface file failed" - $$ nest 4 (docToSDoc (pprBagOfErrors errs))) `thenM_` - return (outOfDate, Nothing) - - ; Just iface -> - - -- At last, we have got the old iface; check its versions - checkVersions source_unchanged iface `thenM` \ recomp -> - returnM (recomp, Just iface) +checkMain :: TcM TcGblEnv +-- If we are in module Main, check that 'main' is defined. +checkMain + = do { ghc_mode <- getGhcMode ; + tcg_env <- getGblEnv ; + dflags <- getDOpts ; + let { main_mod = mainModIs dflags ; + main_fn = case mainFunIs dflags of { + Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) ; + Nothing -> main_RDR_Unqual } } ; + + check_main ghc_mode tcg_env main_mod main_fn + } + + +check_main ghc_mode tcg_env main_mod main_fn + | mod /= main_mod + = traceTc (text "checkMain not" <+> ppr main_mod <+> ppr mod) >> + return tcg_env + + | otherwise + = addErrCtxt mainCtxt $ + do { mb_main <- lookupSrcOcc_maybe main_fn + -- Check that 'main' is in scope + -- It might be imported from another module! + ; case mb_main of { + Nothing -> do { traceTc (text "checkMain fail" <+> ppr main_mod <+> ppr main_fn) + ; complain_no_main + ; return tcg_env } ; + Just main_name -> do + { traceTc (text "checkMain found" <+> ppr main_mod <+> ppr main_fn) + ; let { rhs = nlHsApp (nlHsVar runMainIOName) (nlHsVar main_name) } + -- :Main.main :: IO () = runMainIO main + + ; (main_expr, ty) <- setSrcSpan (srcLocSpan (getSrcLoc main_name)) $ + tcInferRho rhs + + -- The function that the RTS invokes is always :Main.main, + -- which we call root_main_id. + -- (Because GHC allows the user to have a module not called + -- Main as the main module, we can't rely on the main function + -- being called "Main.main". That's why root_main_id has a fixed + -- module ":Main".) + -- We also make root_main_id an implicit Id, by making main_name + -- its parent (hence (Just main_name)). That has the effect + -- of preventing its type and unfolding from getting out into + -- the interface file. Otherwise we can end up with two defns + -- for 'main' in the interface file! + + ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN + (mkVarOccFS FSLIT("main")) + (Just main_name) (getSrcLoc main_name) + ; root_main_id = mkExportedLocalId root_main_name ty + ; main_bind = noLoc (VarBind root_main_id main_expr) } + + ; return (tcg_env { tcg_binds = tcg_binds tcg_env + `snocBag` main_bind, + tcg_dus = tcg_dus tcg_env + `plusDU` usesOnly (unitFV main_name) + -- Record the use of 'main', so that we don't + -- complain about it being defined but not used + }) }}} + where + mod = tcg_mod tcg_env + + complain_no_main | ghc_mode == Interactive = return () + | otherwise = failWithTc noMainMsg + -- In interactive mode, don't worry about the absence of 'main' + -- In other modes, fail altogether, so that we don't go on + -- and complain a second time when processing the export list. + + mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn) + noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn) + <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod) \end{code} +%********************************************************* +%* * + GHCi stuff +%* * +%********************************************************* + +\begin{code} +#ifdef GHCI +setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a +setInteractiveContext hsc_env icxt thing_inside + = let + -- Initialise the tcg_inst_env with instances + -- from all home modules. This mimics the more selective + -- call to hptInstances in tcRnModule + dfuns = hptInstances hsc_env (\mod -> True) + in + updGblEnv (\env -> env { + tcg_rdr_env = ic_rn_gbl_env icxt, + tcg_type_env = ic_type_env icxt, + tcg_inst_env = extendInstEnvList (tcg_inst_env env) dfuns }) $ + + updLclEnv (\env -> env { tcl_rdr = ic_rn_local_env icxt }) $ + + do { traceTc (text "setIC" <+> ppr (ic_type_env icxt)) + ; thing_inside } +\end{code} -%************************************************************************ -%* * - Type-check and rename supporting declarations - This is used to deal with the free vars of a splice, - or derived code: slurp in the necessary declarations, - typecheck them, and add them to the EPS -%* * -%************************************************************************ \begin{code} -importSupportingDecls :: FreeVars -> TcM TcGblEnv --- Completely deal with the supporting imports needed --- by the specified free-var set -importSupportingDecls fvs - = do { traceRn (text "Import supporting decls for" <+> ppr (nameSetToList fvs)) ; - decls <- slurpImpDecls fvs ; - traceRn (text "...namely:" <+> vcat (map ppr decls)) ; - typecheckIfaceDecls (mkGroup decls) } - -typecheckIfaceDecls :: HsGroup Name -> TcM TcGblEnv - -- The decls are all interface-file declarations - -- Usually they are all from other modules, but when we are reading - -- this module's interface from a file, it's possible that some of - -- them are for the module being compiled. - -- That is why the tcExtendX functions need to do partitioning. - -- - -- If all the decls are from other modules, the returned TcGblEnv - -- will have an empty tc_genv, but its tc_inst_env - -- cache may have been augmented. -typecheckIfaceDecls (HsGroup { hs_tyclds = tycl_decls, - hs_instds = inst_decls, - hs_ruleds = rule_decls }) - = do { -- Typecheck the type, class, and interface-sig decls - tcg_env <- tcTyClDecls tycl_decls ; - setGblEnv tcg_env $ do { - - -- Typecheck the instance decls, and rules - -- Note that imported dictionary functions are already - -- in scope from the preceding tcTyClDecls - tcIfaceInstDecls inst_decls `thenM` \ dfuns -> - tcExtendInstEnv dfuns $ - tcRules rule_decls `thenM` \ rules -> - tcExtendRules rules $ +tcRnStmt :: HscEnv + -> InteractiveContext + -> LStmt RdrName + -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id)) + -- The returned [Name] is the same as the input except for + -- ExprStmt, in which case the returned [Name] is [itName] + -- + -- The returned TypecheckedHsExpr is of type IO [ () ], + -- a list of the bound values, coerced to (). + +tcRnStmt hsc_env ictxt rdr_stmt + = initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext hsc_env ictxt $ do { + + -- Rename; use CmdLineMode because tcRnStmt is only used interactively + (([rn_stmt], _), fvs) <- rnStmts DoExpr [rdr_stmt] (return ((), emptyFVs)) ; + traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; + failIfErrsM ; - getGblEnv -- Return the environment - }} + -- The real work is done here + (bound_ids, tc_expr) <- mkPlan rn_stmt ; + zonked_expr <- zonkTopLExpr tc_expr ; + zonked_ids <- zonkTopBndrs bound_ids ; + + -- None of the Ids should be of unboxed type, because we + -- cast them all to HValues in the end! + mappM bad_unboxed (filter (isUnLiftedType . idType) zonked_ids) ; + + traceTc (text "tcs 1") ; + let { -- (a) Make all the bound ids "global" ids, now that + -- they're notionally top-level bindings. This is + -- important: otherwise when we come to compile an expression + -- using these ids later, the byte code generator will consider + -- the occurrences to be free rather than global. + -- + -- (b) Tidy their types; this is important, because :info may + -- ask to look at them, and :info expects the things it looks + -- up to have tidy types + global_ids = map globaliseAndTidy zonked_ids ; + + -- Update the interactive context + rn_env = ic_rn_local_env ictxt ; + type_env = ic_type_env ictxt ; + + bound_names = map idName global_ids ; + new_rn_env = extendLocalRdrEnv rn_env bound_names ; + + -- Remove any shadowed bindings from the type_env; + -- they are inaccessible but might, I suppose, cause + -- a space leak if we leave them there + shadowed = [ n | name <- bound_names, + let rdr_name = mkRdrUnqual (nameOccName name), + Just n <- [lookupLocalRdrEnv rn_env rdr_name] ] ; + + filtered_type_env = delListFromNameEnv type_env shadowed ; + new_type_env = extendTypeEnvWithIds filtered_type_env global_ids ; + + new_ic = ictxt { ic_rn_local_env = new_rn_env, + ic_type_env = new_type_env } + } ; + + dumpOptTcRn Opt_D_dump_tc + (vcat [text "Bound Ids" <+> pprWithCommas ppr global_ids, + text "Typechecked expr" <+> ppr zonked_expr]) ; + + returnM (new_ic, bound_names, zonked_expr) + } + where + bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"), + nest 2 (ppr id <+> dcolon <+> ppr (idType id))]) + +globaliseAndTidy :: Id -> Id +globaliseAndTidy id +-- Give the Id a Global Name, and tidy its type + = setIdType (globaliseId VanillaGlobal id) tidy_type + where + tidy_type = tidyTopType (idType id) \end{code} +Here is the grand plan, implemented in tcUserStmt + What you type The IO [HValue] that hscStmt returns + ------------- ------------------------------------ + let pat = expr ==> let pat = expr in return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] -%********************************************************* -%* * - mkGlobalContext: make up an interactive context + pat <- expr ==> expr >>= \ pat -> return [coerce HVal x, coerce HVal y, ...] + bindings: [x,y,...] + + expr (of IO type) ==> expr >>= \ it -> return [coerce HVal it] + [NB: result not printed] bindings: [it] + + expr (of non-IO type, ==> let it = expr in print it >> return [coerce HVal it] + result showable) bindings: [it] + + expr (of non-IO type, + result not showable) ==> error - Used for initialising the lexical environment - of the interactive read-eval-print loop -%* * -%********************************************************* \begin{code} -#ifdef GHCI -mkGlobalContext - :: HscEnv -> PersistentCompilerState - -> [Module] -- Expose these modules' top-level scope - -> [Module] -- Expose these modules' exports only - -> IO (PersistentCompilerState, Maybe GlobalRdrEnv) - -mkGlobalContext hsc_env pcs toplevs exports - = initTc hsc_env pcs iNTERACTIVE $ do { - - toplev_envs <- mappM getTopLevScope toplevs ; - export_envs <- mappM getModuleExports exports ; - returnM (foldr plusGlobalRdrEnv emptyGlobalRdrEnv - (toplev_envs ++ export_envs)) +--------------------------- +type PlanResult = ([Id], LHsExpr Id) +type Plan = TcM PlanResult + +runPlans :: [Plan] -> TcM PlanResult +-- Try the plans in order. If one fails (by raising an exn), try the next. +-- If one succeeds, take it. +runPlans [] = panic "runPlans" +runPlans [p] = p +runPlans (p:ps) = tryTcLIE_ (runPlans ps) p + +-------------------- +mkPlan :: LStmt Name -> TcM PlanResult +mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt + = do { uniq <- newUnique -- is treated very specially + ; let fresh_it = itName uniq + the_bind = L loc $ mkFunBind (L loc fresh_it) matches + matches = [mkMatch [] expr emptyLocalBinds] + let_stmt = L loc $ LetStmt (HsValBinds (ValBindsOut [(NonRecursive,unitBag the_bind)] [])) + bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr + (HsVar bindIOName) noSyntaxExpr + print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) + (HsVar thenIOName) placeHolderType + + -- The plans are: + -- [it <- e; print it] but not if it::() + -- [it <- e] + -- [let it = e; print it] + ; runPlans [ -- Plan A + do { stuff@([it_id], _) <- tcGhciStmts [bind_stmt, print_it] + ; it_ty <- zonkTcType (idType it_id) + ; ifM (isUnitTy it_ty) failM + ; return stuff }, + + -- Plan B; a naked bind statment + tcGhciStmts [bind_stmt], + + -- Plan C; check that the let-binding is typeable all by itself. + -- If not, fail; if so, try to print it. + -- The two-step process avoids getting two errors: one from + -- the expression itself, and one from the 'print it' part + -- This two-step story is very clunky, alas + do { checkNoErrs (tcGhciStmts [let_stmt]) + --- checkNoErrs defeats the error recovery of let-bindings + ; tcGhciStmts [let_stmt, print_it] } + ]} + +mkPlan stmt@(L loc (BindStmt {})) + | [L _ v] <- collectLStmtBinders stmt -- One binder, for a bind stmt + = do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) + (HsVar thenIOName) placeHolderType + -- The plans are: + -- [stmt; print v] but not if v::() + -- [stmt] + ; runPlans [do { stuff@([v_id], _) <- tcGhciStmts [stmt, print_v] + ; v_ty <- zonkTcType (idType v_id) + ; ifM (isUnitTy v_ty || not (isTauTy v_ty)) failM + ; return stuff }, + tcGhciStmts [stmt] + ]} + +mkPlan stmt + = tcGhciStmts [stmt] + +--------------------------- +tcGhciStmts :: [LStmt Name] -> TcM PlanResult +tcGhciStmts stmts + = do { ioTyCon <- tcLookupTyCon ioTyConName ; + ret_id <- tcLookupId returnIOName ; -- return @ IO + let { + io_ty = mkTyConApp ioTyCon [] ; + ret_ty = mkListTy unitTy ; + io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; + + names = map unLoc (collectLStmtsBinders stmts) ; + + -- mk_return builds the expression + -- returnIO @ [()] [coerce () x, .., coerce () z] + -- + -- Despite the inconvenience of building the type applications etc, + -- this *has* to be done in type-annotated post-typecheck form + -- because we are going to return a list of *polymorphic* values + -- coerced to type (). If we built a *source* stmt + -- return [coerce x, ..., coerce z] + -- then the type checker would instantiate x..z, and we wouldn't + -- get their *polymorphic* values. (And we'd get ambiguity errs + -- if they were overloaded, since they aren't applied to anything.) + mk_return ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty]) + (noLoc $ ExplicitList unitTy (map mk_item ids)) ; + mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy]) + (nlHsVar id) + } ; + + -- OK, we're ready to typecheck the stmts + traceTc (text "tcs 2") ; + ((tc_stmts, ids), lie) <- getLIE $ + tcStmts DoExpr (tcDoStmt io_ty) stmts io_ret_ty $ \ _ -> + mappM tcLookupId names ; + -- Look up the names right in the middle, + -- where they will all be in scope + + -- Simplify the context + const_binds <- checkNoErrs (tcSimplifyInteractive lie) ; + -- checkNoErrs ensures that the plan fails if context redn fails + + return (ids, mkHsDictLet const_binds $ + noLoc (HsDo DoExpr tc_stmts (mk_return ids) io_ret_ty)) } +\end{code} -getTopLevScope :: Module -> TcRn m GlobalRdrEnv -getTopLevScope mod - = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ; - case mi_globals iface of - Nothing -> panic "getTopLevScope" - Just env -> returnM env } - -getModuleExports :: Module -> TcRn m GlobalRdrEnv -getModuleExports mod - = do { iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ; - returnM (foldl add emptyGlobalRdrEnv (mi_exports iface)) } - where - prov_fn n = NonLocalDef ImplicitImport - add env (mod,avails) - = plusGlobalRdrEnv env (mkGlobalRdrEnv mod True prov_fn avails NoDeprecs) -contextDoc = text "context for compiling statements" +tcRnExpr just finds the type of an expression + +\begin{code} +tcRnExpr :: HscEnv + -> InteractiveContext + -> LHsExpr RdrName + -> IO (Maybe Type) +tcRnExpr hsc_env ictxt rdr_expr + = initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext hsc_env ictxt $ do { + + (rn_expr, fvs) <- rnLExpr rdr_expr ; + failIfErrsM ; + + -- Now typecheck the expression; + -- it might have a rank-2 type (e.g. :t runST) + ((tc_expr, res_ty), lie) <- getLIE (tcInferRho rn_expr) ; + ((qtvs, _, dict_ids), lie_top) <- getLIE (tcSimplifyInfer smpl_doc (tyVarsOfType res_ty) lie) ; + tcSimplifyInteractive lie_top ; + qtvs' <- mappM zonkQuantifiedTyVar qtvs ; + + let { all_expr_ty = mkForAllTys qtvs' $ + mkFunTys (map idType dict_ids) $ + res_ty } ; + zonkTcType all_expr_ty + } + where + smpl_doc = ptext SLIT("main expression") \end{code} +tcRnType just finds the kind of a type + \begin{code} -getModuleContents - :: HscEnv - -> PersistentCompilerState -- IN: persistent compiler state - -> Module -- module to inspect - -> Bool -- grab just the exports, or the whole toplev - -> IO (PersistentCompilerState, Maybe [TyThing]) - -getModuleContents hsc_env pcs mod exports_only - = initTc hsc_env pcs iNTERACTIVE $ do { - - -- Load the interface if necessary (a home module will certainly - -- alraedy be loaded, but a package module might not be) - iface <- loadInterface contextDoc (moduleName mod) (ImportByUser False) ; - - let { export_names = availsToNameSet export_avails ; - export_avails = [ avail | (mn, avails) <- mi_exports iface, - avail <- avails ] } ; - - all_names <- if exports_only then - return export_names - else case mi_globals iface of { - Just rdr_env -> - return (get_locals rdr_env) ; - - Nothing -> do { addErr (noRdrEnvErr mod) ; - return export_names } } ; - -- Invariant; we only have (not exports_only) - -- for a home module so it must already be in the HIT - -- So the Nothing case is a bug - - env <- importSupportingDecls all_names ; - setGblEnv env (mappM tcLookupGlobal (nameSetToList all_names)) +tcRnType :: HscEnv + -> InteractiveContext + -> LHsType RdrName + -> IO (Maybe Kind) +tcRnType hsc_env ictxt rdr_type + = initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext hsc_env ictxt $ do { + + rn_type <- rnLHsType doc rdr_type ; + failIfErrsM ; + + -- Now kind-check the type + (ty', kind) <- kcHsType rn_type ; + return kind } where - -- Grab all the things from the global env that are locally def'd - get_locals rdr_env = mkNameSet [ gre_name gre - | elts <- rdrEnvElts rdr_env, - gre <- elts, - isLocalGRE gre ] - -- Make a set because a name is often in the envt in - -- both qualified and unqualified forms - -noRdrEnvErr mod = ptext SLIT("No top-level environment available for module") - <+> quotes (ppr mod) -#endif + doc = ptext SLIT("In GHCi input") + +#endif /* GHCi */ \end{code} + %************************************************************************ %* * - Checking for 'main' + More GHCi stuff, to do with browsing and getting info %* * %************************************************************************ \begin{code} -checkMain - = do { ghci_mode <- getGhciMode ; - tcg_env <- getGblEnv ; +#ifdef GHCI +-- ASSUMES that the module is either in the HomePackageTable or is +-- a package module with an interface on disk. If neither of these is +-- true, then the result will be an error indicating the interface +-- could not be found. +getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe NameSet) +getModuleExports hsc_env mod + = initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod) + +tcGetModuleExports :: Module -> TcM NameSet +tcGetModuleExports mod = do + iface <- load_iface mod + loadOrphanModules (dep_orphs (mi_deps iface)) + -- Load any orphan-module interfaces, + -- so their instances are visible + ifaceExportNames (mi_exports iface) + +load_iface mod = loadSrcInterface doc mod False {- Not boot iface -} + where + doc = ptext SLIT("context for compiling statements") + + +tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name]) +tcRnLookupRdrName hsc_env rdr_name + = initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext hsc_env (hsc_IC hsc_env) $ + lookup_rdr_name rdr_name + +lookup_rdr_name rdr_name = do { + -- If the identifier is a constructor (begins with an + -- upper-case letter), then we need to consider both + -- constructor and type class identifiers. + let { rdr_names = dataTcOccs rdr_name } ; - mb_main_mod <- readMutVar v_MainModIs ; - mb_main_fn <- readMutVar v_MainFunIs ; - let { main_mod = case mb_main_mod of { - Just mod -> mkModuleName mod ; - Nothing -> mAIN_Name } ; - main_fn = case mb_main_fn of { - Just fn -> mkRdrUnqual (mkVarOcc (mkFastString fn)) ; - Nothing -> main_RDR_Unqual } } ; - - check_main ghci_mode tcg_env main_mod main_fn - } + -- results :: [Either Messages Name] + results <- mapM (tryTcErrs . lookupOccRn) rdr_names ; + + traceRn (text "xx" <+> vcat [ppr rdr_names, ppr (map snd results)]); + -- The successful lookups will be (Just name) + let { (warns_s, good_names) = unzip [ (msgs, name) + | (msgs, Just name) <- results] ; + errs_s = [msgs | (msgs, Nothing) <- results] } ; + -- Fail if nothing good happened, else add warnings + if null good_names then + -- No lookup succeeded, so + -- pick the first error message and report it + -- ToDo: If one of the errors is "could be Foo.X or Baz.X", + -- while the other is "X is not in scope", + -- we definitely want the former; but we might pick the latter + do { addMessages (head errs_s) ; failM } + else -- Add deprecation warnings + mapM_ addMessages warns_s ; + + return good_names + } -check_main ghci_mode tcg_env main_mod main_fn - -- If we are in module Main, check that 'main' is defined. - -- It may be imported from another module, in which case - -- we have to drag in its. - -- - -- Also form the definition - -- $main = runIO main - -- so we need to slurp in runIO too. - -- - -- ToDo: We have to return the main_name separately, because it's a - -- bona fide 'use', and should be recorded as such, but the others - -- aren't - -- - -- Blimey: a whole page of code to do this... - - | mod_name /= main_mod - = return (tcg_env, emptyFVs) - - -- Check that 'main' is in scope - -- It might be imported from another module! - -- - -- We use a guard for this (rather than letting lookupSrcName fail) - -- because it's not an error in ghci) - | not (main_fn `elemRdrEnv` rdr_env) - = do { complain_no_main; return (tcg_env, emptyFVs) } - - | otherwise -- OK, so the appropriate 'main' is in scope - -- - = do { main_name <- lookupSrcName main_fn ; - tcg_env <- importSupportingDecls (unitFV runIOName) ; +tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing) +tcRnLookupName hsc_env name + = initTcPrintErrors hsc_env iNTERACTIVE $ + setInteractiveContext hsc_env (hsc_IC hsc_env) $ + tcLookupGlobal name - addSrcLoc (getSrcLoc main_name) $ - addErrCtxt mainCtxt $ - setGblEnv tcg_env $ do { - - -- :Main.main :: IO () = runIO main - let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } ; - (main_expr, ty) <- tcInferRho rhs ; - let { root_main_id = setIdLocalExported (mkLocalId rootMainName ty) ; - main_bind = VarMonoBind root_main_id main_expr ; - tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env - `andMonoBinds` main_bind } } ; +tcRnGetInfo :: HscEnv + -> Name + -> IO (Maybe (TyThing, Fixity, [Instance])) - return (tcg_env', unitFV main_name) - }} +-- Used to implemnent :info in GHCi +-- +-- Look up a RdrName and return all the TyThings it might be +-- A capitalised RdrName is given to us in the DataName namespace, +-- but we want to treat it as *both* a data constructor +-- *and* as a type or class constructor; +-- hence the call to dataTcOccs, and we return up to two results +tcRnGetInfo hsc_env name + = initTcPrintErrors hsc_env iNTERACTIVE $ + let ictxt = hsc_IC hsc_env in + setInteractiveContext hsc_env ictxt $ do + + -- Load the interface for all unqualified types and classes + -- That way we will find all the instance declarations + -- (Packages have not orphan modules, and we assume that + -- in the home package all relevant modules are loaded.) + loadUnqualIfaces ictxt + + thing <- tcLookupGlobal name + fixity <- lookupFixityRn name + ispecs <- lookupInsts (icPrintUnqual ictxt) thing + return (thing, fixity, ispecs) + + +lookupInsts :: PrintUnqualified -> TyThing -> TcM [Instance] +-- Filter the instances by the ones whose tycons (or clases resp) +-- are in scope unqualified. Otherwise we list a whole lot too many! +lookupInsts print_unqual (AClass cls) + = do { inst_envs <- tcGetInstEnvs + ; return [ ispec + | ispec <- classInstances inst_envs cls + , plausibleDFun print_unqual (instanceDFunId ispec) ] } + +lookupInsts print_unqual (ATyCon tc) + = do { eps <- getEps -- Load all instances for all classes that are + -- in the type environment (which are all the ones + -- we've seen in any interface file so far) + ; (pkg_ie, home_ie) <- tcGetInstEnvs -- Search all + ; return [ ispec + | ispec <- instEnvElts home_ie ++ instEnvElts pkg_ie + , let dfun = instanceDFunId ispec + , relevant dfun + , plausibleDFun print_unqual dfun ] } where - mod_name = moduleName (tcg_mod tcg_env) - rdr_env = tcg_rdr_env tcg_env - - complain_no_main | ghci_mode == Interactive = return () - | otherwise = failWithTc noMainMsg - -- In interactive mode, don't worry about the absence of 'main' - -- In other modes, fail altogether, so that we don't go on - -- and complain a second time when processing the export list. + relevant df = tc_name `elemNameSet` tyClsNamesOfDFunHead (idType df) + tc_name = tyConName tc - mainCtxt = ptext SLIT("When checking the type of the main function") <+> quotes (ppr main_fn) - noMainMsg = ptext SLIT("The main function") <+> quotes (ppr main_fn) - <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod) -\end{code} +lookupInsts print_unqual other = return [] +plausibleDFun print_unqual dfun -- Dfun involving only names that print unqualified + = all ok (nameSetToList (tyClsNamesOfType (idType dfun))) + where + ok name | isBuiltInSyntax name = True + | isExternalName name = print_unqual (nameModule name) (nameOccName name) + | otherwise = True + +loadUnqualIfaces :: InteractiveContext -> TcM () +-- Load the home module for everything that is in scope unqualified +-- This is so that we can accurately report the instances for +-- something +loadUnqualIfaces ictxt + = initIfaceTcRn $ + mapM_ (loadSysInterface doc) (moduleSetElts (mkModuleSet unqual_mods)) + where + unqual_mods = [ nameModule name + | gre <- globalRdrEnvElts (ic_rn_gbl_env ictxt), + let name = gre_name gre, + isTcOcc (nameOccName name), -- Types and classes only + unQualOK gre ] -- In scope unqualified + doc = ptext SLIT("Need interface for module whose export(s) are in scope unqualified") +#endif /* GHCI */ +\end{code} %************************************************************************ %* * @@ -1193,11 +1265,11 @@ check_main ghci_mode tcg_env main_mod main_fn %************************************************************************ \begin{code} -rnDump :: SDoc -> TcRn m () +rnDump :: SDoc -> TcRn () -- Dump, with a banner, if -ddump-rn -rnDump doc = dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) +rnDump doc = do { dumpOptTcRn Opt_D_dump_rn (mkDumpDoc "Renamer" doc) } -tcDump :: TcGblEnv -> TcRn m () +tcDump :: TcGblEnv -> TcRn () tcDump env = do { dflags <- getDOpts ; @@ -1210,7 +1282,7 @@ tcDump env } where short_dump = pprTcGblEnv env - full_dump = ppr (tcg_binds env) + full_dump = pprLHsBinds (tcg_binds env) -- NB: foreign x-d's have undefined's in their types; -- hence can't show the tc_fords @@ -1244,10 +1316,11 @@ pprModGuts (ModGuts { mg_types = type_env, ppr_rules rules ] -ppr_types :: [Var] -> TypeEnv -> SDoc -ppr_types dfun_ids type_env +ppr_types :: [Instance] -> TypeEnv -> SDoc +ppr_types ispecs type_env = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids) where + dfun_ids = map instanceDFunId ispecs ids = [id | id <- typeEnvIds type_env, want_sig id] want_sig id | opt_PprStyle_Debug = True | otherwise = isLocalId id && @@ -1258,46 +1331,25 @@ ppr_types dfun_ids type_env -- that the type checker has invented. Top-level user-defined things -- have External names. -ppr_insts :: [Var] -> SDoc -ppr_insts [] = empty -ppr_insts dfun_ids = text "INSTANCES" $$ nest 4 (ppr_sigs dfun_ids) +ppr_insts :: [Instance] -> SDoc +ppr_insts [] = empty +ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs) ppr_sigs :: [Var] -> SDoc ppr_sigs ids - -- Print type signatures - -- Convert to HsType so that we get source-language style printing - -- And sort by RdrName - = vcat $ map ppr_sig $ sortLt lt_sig $ - [ (getRdrName id, toHsType (tidyTopType (idType id))) - | id <- ids ] + -- Print type signatures; sort by OccName + = vcat (map ppr_sig (sortLe le_sig ids)) where - lt_sig (n1,_) (n2,_) = n1 < n2 - ppr_sig (n,t) = ppr n <+> dcolon <+> ppr t - + le_sig id1 id2 = getOccName id1 <= getOccName id2 + ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id)) -ppr_rules :: [IdCoreRule] -> SDoc +ppr_rules :: [CoreRule] -> SDoc ppr_rules [] = empty ppr_rules rs = vcat [ptext SLIT("{-# RULES"), - nest 4 (pprIdRules rs), + nest 4 (pprRules rs), ptext SLIT("#-}")] ppr_gen_tycons [] = empty -ppr_gen_tycons tcs = vcat [ptext SLIT("Generic type constructor details:"), - nest 2 (vcat (map ppr_gen_tycon tcs)) - ] - --- x&y are now Id's, not CoreExpr's -ppr_gen_tycon tycon - | Just ep <- tyConGenInfo tycon - = (ppr tycon <> colon) $$ nest 4 (ppr_ep ep) - - | otherwise = ppr tycon <> colon <+> ptext SLIT("Not derivable") - -ppr_ep (EP from to) - = vcat [ ptext SLIT("Rep type:") <+> ppr (tcFunResultTy from_tau), - ptext SLIT("From:") <+> ppr (unfoldingTemplate (idUnfolding from)), - ptext SLIT("To:") <+> ppr (unfoldingTemplate (idUnfolding to)) - ] - where - (_,from_tau) = tcSplitForAllTys (idType from) +ppr_gen_tycons tcs = vcat [ptext SLIT("Tycons with generics:"), + nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))] \end{code}