X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=8468f8753723667761adfac5b624223047fa438b;hp=8f11232737019aba384e69b70f6856d6bdf74b9f;hb=c1681a73fa4ca4cf8758264ae387ac09a9e900d8;hpb=2a8cdc3aee5997374273e27365f92c161aca8453 diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 8f11232..8468f87 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -1,4 +1,5 @@ % +% (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcModule]{Typechecking a whole module} @@ -24,120 +25,79 @@ import IO import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) #endif -import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) ) -import StaticFlags ( opt_PprStyle_Debug ) -import HsSyn ( HsModule(..), HsExtCore(..), HsGroup(..), LHsDecl, - SpliceDecl(..), HsBind(..), LHsBinds, - emptyRdrGroup, emptyRnGroup, appendGroups, plusHsValBinds, - nlHsApp, nlHsVar, pprLHsBinds, HaddockModInfo(..) ) -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 DynFlags +import StaticFlags +import HsSyn +import RdrHsSyn + +import PrelNames +import RdrName +import TcHsSyn +import TcExpr import TcRnMonad -import TcType ( tidyTopType, tcEqType ) -import Inst ( showLIE ) -import InstEnv ( extendInstEnvList, Instance, pprInstances, - instanceDFunId ) -import FamInstEnv ( FamInst, pprFamInsts ) -import TcBinds ( tcTopBinds, tcHsBootSigs ) -import TcDefaults ( tcDefaults ) -import TcEnv ( tcExtendGlobalValEnv, iDFunId ) -import TcRules ( tcRules ) -import TcForeign ( tcForeignImports, tcForeignExports ) -import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) -import TcIface ( tcExtCoreBindings, tcHiBootIface ) -import MkIface ( tyThingToIfaceDecl ) -import IfaceSyn ( checkBootDecl, IfaceExtName(..) ) -import TcSimplify ( tcSimplifyTop ) -import TcTyClsDecls ( tcTyAndClassDecls ) -import LoadIface ( loadOrphanModules ) -import RnNames ( importsFromLocalDecls, rnImports, rnExports, - mkRdrEnvAndImports, mkExportNameSet, - reportUnusedNames, reportDeprecations ) -import RnEnv ( lookupSrcOcc_maybe ) -import RnSource ( rnSrcDecls, rnTyClDecls, checkModDeprec ) -import RnHsDoc ( rnMbHsDoc ) -import PprCore ( pprRules, pprCoreBindings ) -import CoreSyn ( CoreRule, bindersOfBinds ) -import ErrUtils ( Messages, mkDumpDoc, showPass ) -import Id ( Id, mkExportedLocalId, isLocalId, idName, idType ) -import Var ( Var ) +import TcType +import Inst +import FamInst +import InstEnv +import FamInstEnv +import TcBinds +import TcDefaults +import TcEnv +import TcRules +import TcForeign +import TcInstDcls +import TcIface +import MkIface +import IfaceSyn +import TcSimplify +import TcTyClsDecls +import LoadIface +import RnNames +import RnEnv +import RnSource +import RnHsDoc +import PprCore +import CoreSyn +import ErrUtils +import Id +import Var import Module -import UniqFM ( elemUFM, eltsUFM ) -import OccName ( mkVarOccFS, plusOccEnv ) -import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName, - nameModule, nameOccName, isImplicitName, mkExternalName ) +import UniqFM +import Name +import NameEnv import NameSet -import TyCon ( tyConHasGenerics ) -import SrcLoc ( srcLocSpan, Located(..), noLoc ) -import DriverPhases ( HscSource(..), isHsBoot ) -import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails, - HscEnv(..), ExternalPackageState(..), - IsBootInterface, noDependencies, - Deprecs( NoDeprecs ), plusDeprecs, - ForeignStubs(NoStubs), - TypeEnv, lookupTypeEnv, hptInstances, - extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts, - emptyFixityEnv - ) +import TyCon +import SrcLoc +import HscTypes +import ListSetOps import Outputable #ifdef GHCI -import HsSyn ( HsStmtContext(..), Stmt(..), HsExpr(..), - HsLocalBinds(..), HsValBinds(..), - LStmt, LHsExpr, LHsType, mkMatch, emptyLocalBinds, - collectLStmtsBinders, collectLStmtBinders, nlVarPat, - mkFunBind, placeHolderType, noSyntaxExpr, nlHsTyApp ) -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 TcGadt ( emptyRefinement ) -import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType, isTauTy, - isUnLiftedType, tyClsNamesOfDFunHead, tyClsNamesOfType, isUnitTy ) -import TcEnv ( tcLookupTyCon, tcLookupId, tcLookupGlobal ) -import TypeRep ( TyThing(..) ) -import RnTypes ( rnLHsType ) -import Inst ( tcGetInstEnvs ) -import InstEnv ( classInstances, instEnvElts ) -import RnExpr ( rnStmts, rnLExpr ) -import LoadIface ( loadSysInterface ) -import IfaceEnv ( ifaceExportNames ) -import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) -import Id ( setIdType ) -import MkId ( unsafeCoerceId ) -import TyCon ( tyConName ) -import TysWiredIn ( mkListTy, unitTy ) -import IdInfo ( GlobalIdDetails(..) ) -import {- Kind parts of -} Type ( Kind ) -import Var ( globaliseId ) -import Name ( isBuiltInSyntax, isInternalName ) -import OccName ( isTcOcc ) -import NameEnv ( delListFromNameEnv ) -import PrelNames ( iNTERACTIVE, ioTyConName, printName, itName, - bindIOName, thenIOName, returnIOName ) -import HscTypes ( InteractiveContext(..), - ModIface(..), icPrintUnqual, - Dependencies(..) ) -import BasicTypes ( Fixity, RecFlag(..) ) -import SrcLoc ( unLoc ) -import Data.Maybe ( isNothing ) +import Linker +import DataCon +import TcHsType +import TcMType +import TcMatches +import TcGadt +import RnTypes +import RnExpr +import IfaceEnv +import MkId +import TysWiredIn +import IdInfo +import {- Kind parts of -} Type +import BasicTypes +import Foreign.Ptr( Ptr ) #endif -import FastString ( mkFastString ) -import Util ( sortLe ) -import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags ) +import FastString +import Maybes +import Util +import Bag import Control.Monad ( unless ) import Data.Maybe ( isJust ) + \end{code} @@ -158,7 +118,8 @@ tcRnModule :: HscEnv tcRnModule hsc_env hsc_src save_rn_syntax (L loc (HsModule maybe_mod export_ies - import_decls local_decls mod_deprec _ module_info maybe_doc)) + import_decls local_decls mod_deprec _ + module_info maybe_doc)) = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; let { this_pkg = thisPackage (hsc_dflags hsc_env) ; @@ -167,117 +128,135 @@ tcRnModule hsc_env hsc_src save_rn_syntax Just (L _ mod) -> mkModule this_pkg mod } ; -- The normal case - initTc hsc_env hsc_src this_mod $ + initTc hsc_env hsc_src save_rn_syntax this_mod $ setSrcSpan loc $ - do { - -- Deal with imports; - rn_imports <- rnImports import_decls ; - (rdr_env, imports) <- mkRdrEnvAndImports rn_imports ; - - let { dep_mods :: ModuleNameEnv (ModuleName, 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 :: ModuleName -> Bool - ; want_instances mod = mod `elemUFM` dep_mods - && mod /= moduleName 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 }) ; - - -- Update the gbl env - updGblEnv ( \ gbl -> - gbl { tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) 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 ; + do { -- Deal with imports; + tcg_env <- tcRnImports hsc_env this_mod import_decls ; + setGblEnv tcg_env $ do { - -- Load any orphan-module interfaces, so that - -- their rules and instance decls will be found - loadOrphanModules (imp_orphs imports) ; + -- 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 + -- + -- Do this *after* tcRnImports, so that we know whether + -- a module that we import imports us; and hence whether to + -- look for a hi-boot file + boot_iface <- tcHiBootIface hsc_src this_mod ; - traceRn (text "rn1a") ; -- Rename and type check the declarations + traceRn (text "rn1a") ; tcg_env <- if isHsBoot hsc_src then tcRnHsBootDecls local_decls else - tcRnSrcDecls local_decls ; + tcRnSrcDecls boot_iface 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 + -- 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 (hsc_dflags hsc_env) tcg_env ; + -- That is, only uses in the *body* of the module are complained about + traceRn (text "rn3") ; + failIfErrsM ; -- finishDeprecations crashes sometimes + -- as a result of typechecker repairs (e.g. unboundNames) + tcg_env <- finishDeprecations (hsc_dflags hsc_env) mod_deprec tcg_env ; -- Process the export list - rn_exports <- rnExports export_ies ; - - -- Rename the Haddock documentation header - rn_module_doc <- rnMbHsDoc maybe_doc ; - - -- Rename the Haddock module info - rn_description <- rnMbHsDoc (hmi_description module_info) ; - let { rn_module_info = module_info { hmi_description = rn_description } } ; - - let { liftM2' fn a b = do a' <- a; b' <- b; return (fn a' b') } ; - exports <- mkExportNameSet (isJust maybe_mod) - (liftM2' (,) rn_exports export_ies) ; - - -- Check whether the entire module is deprecated - -- This happens only once per module - let { mod_deprecs = checkModDeprec mod_deprec } ; - - -- 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, - tcg_doc = rn_module_doc, - tcg_hmi = rn_module_info - } - -- A module deprecation over-rides the earlier ones - } ; + tcg_env <- rnExports (isJust maybe_mod) export_ies tcg_env ; + traceRn (text "rn4") ; + + -- Compare the hi-boot iface (if any) with the real thing + -- Must be done after processing the exports + tcg_env <- checkHiBootIface tcg_env boot_iface ; + + -- Make the new type env available to stuff slurped from interface files + -- Must do this after checkHiBootIface, because the latter might add new + -- bindings for boot_dfuns, which may be mentioned in imported unfoldings + writeMutVar (tcg_type_env_var tcg_env) (tcg_type_env tcg_env) ; + + -- Rename the Haddock documentation + tcg_env <- rnHaddock module_info maybe_doc tcg_env ; -- Report unused names - reportUnusedNames export_ies final_env ; + reportUnusedNames export_ies tcg_env ; -- Dump output and return - tcDump final_env ; - return final_env + tcDump tcg_env ; + return tcg_env }}}} \end{code} %************************************************************************ %* * + Import declarations +%* * +%************************************************************************ + +\begin{code} +tcRnImports :: HscEnv -> Module -> [LImportDecl RdrName] -> TcM TcGblEnv +tcRnImports hsc_env this_mod import_decls + = do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ; + + ; let { dep_mods :: ModuleNameEnv (ModuleName, 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 :: ModuleName -> Bool + ; want_instances mod = mod `elemUFM` dep_mods + && mod /= moduleName this_mod + ; (home_insts, home_fam_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 }) ; + + -- Update the gbl env + ; updGblEnv ( \ gbl -> + gbl { + tcg_rdr_env = plusOccEnv (tcg_rdr_env gbl) rdr_env, + tcg_imports = tcg_imports gbl `plusImportAvails` imports, + tcg_rn_imports = fmap (const rn_imports) (tcg_rn_imports gbl), + tcg_inst_env = extendInstEnvList (tcg_inst_env gbl) home_insts, + tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env gbl) + home_fam_insts, + tcg_hpc = hpc_info + }) $ 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 +-- ; traceIf (text "rdr_env: " <+> ppr rdr_env) + ; failIfErrsM + + -- Load any orphan-module and family instance-module + -- interfaces, so that their rules and instance decls will be + -- found. + ; loadOrphanModules (imp_orphs imports) False + ; loadOrphanModules (imp_finsts imports) True + + -- Check type-familily consistency + ; traceRn (text "rn1: checking family instance consistency") + ; let { dir_imp_mods = map (\ (mod, _, _) -> mod) + . moduleEnvElts + . imp_mods + $ imports } + ; checkFamInstConsistency (imp_finsts imports) dir_imp_mods ; + + ; getGblEnv } } +\end{code} + + +%************************************************************************ +%* * Type-checking external-core modules %* * %************************************************************************ @@ -292,7 +271,7 @@ 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 ExtCoreFile this_mod $ do { + initTc hsc_env ExtCoreFile False this_mod $ do { let { ldecls = map noLoc decls } ; @@ -321,7 +300,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) -- Wrap up let { bndrs = bindersOfBinds core_binds ; - my_exports = mkNameSet (map idName bndrs) ; + my_exports = map (Avail . idName) bndrs ; -- ToDo: export the data types also? final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; @@ -335,6 +314,8 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_types = final_type_env, mg_insts = tcg_insts tcg_env, mg_fam_insts = tcg_fam_insts tcg_env, + mg_inst_env = tcg_inst_env tcg_env, + mg_fam_inst_env = tcg_fam_inst_env tcg_env, mg_rules = [], mg_binds = core_binds, @@ -342,7 +323,10 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mg_rdr_env = emptyGlobalRdrEnv, mg_fix_env = emptyFixityEnv, mg_deprecs = NoDeprecs, - mg_foreign = NoStubs + mg_foreign = NoStubs, + mg_hpc_info = emptyHpcInfo False, + mg_modBreaks = emptyModBreaks, + mg_vect_info = noVectInfo } } ; tcCoreDump mod_guts ; @@ -362,41 +346,39 @@ mkFakeGroup decls -- Rather clumsy; lots of unused fields %************************************************************************ \begin{code} -tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv +tcRnSrcDecls :: ModDetails -> [LHsDecl RdrName] -> TcM TcGblEnv -- Returns the variables free in the decls -- Reason: solely to report unused imports and bindings -tcRnSrcDecls 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) ; +tcRnSrcDecls boot_iface decls + = do { -- Do all the declarations + (tc_envs, lie) <- getLIE $ tc_rn_src_decls boot_iface decls ; + -- Finish simplifying class constraints + -- -- tcSimplifyTop deals with constant or ambiguous InstIds. -- How could there be ambiguous ones? They can only arise if a - -- top-level decl falls under the monomorphism - -- restriction, and no subsequent decl instantiates its - -- type. (Usually, ambiguous type variables are resolved - -- during the generalisation step.) + -- top-level decl falls under the monomorphism restriction + -- and no subsequent decl instantiates its type. + -- + -- We do this after checkMain, so that we use the type info + -- thaat checkMain adds + -- + -- We do it with both global and local env in scope: + -- * the global env exposes the instances to tcSimplifyTop + -- * the local env exposes the local Ids to tcSimplifyTop, + -- so that we get better error messages (monomorphism restriction) traceTc (text "Tc8") ; inst_binds <- setEnvs tc_envs (tcSimplifyTop lie) ; - -- Setting the global env exposes the instances to tcSimplifyTop - -- 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. traceTc (text "Tc9") ; - let { (tcg_env, _) = tc_envs ; - TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, - tcg_rules = rules, tcg_fords = fords } = tcg_env } ; + let { (tcg_env, _) = tc_envs + ; TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, + tcg_rules = rules, tcg_fords = fords } = tcg_env + ; all_binds = binds `unionBags` inst_binds } ; - (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds) - rules fords ; + (bind_ids, binds', fords', rules') <- zonkTopDecls all_binds rules fords ; let { final_type_env = extendTypeEnvWithIds type_env bind_ids ; tcg_env' = tcg_env { tcg_type_env = final_type_env, @@ -404,13 +386,7 @@ tcRnSrcDecls decls 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 ; - - return (tcg_env' { tcg_binds = tcg_binds tcg_env' `unionBags` dfun_binds }) + return (tcg_env' { tcg_binds = tcg_binds tcg_env' }) } tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) @@ -420,20 +396,17 @@ 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@(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 - -- the subsequent checkMain test - failIfErrsM ; + -- Deal with decls up to, but not including, the first splice + (tcg_env, rn_decls) <- checkNoErrs $ rnTopSrcDecls first_group ; + -- checkNoErrs: stop if renaming fails - setEnvs tc_envs $ + (tcg_env, tcl_env) <- setGblEnv tcg_env $ + tcTopSrcDecls boot_details rn_decls ; -- If there is no splice, we're nearly done + setEnvs (tcg_env, tcl_env) $ case group_tail of { - Nothing -> do { -- Last thing: check for `main' - tcg_env <- checkMain ; + Nothing -> do { tcg_env <- checkMain ; -- Check for `main' return (tcg_env, tcl_env) } ; @@ -444,8 +417,8 @@ tc_rn_src_decls boot_details ds #else -- Rename the splice expression, and get its supporting decls - (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ; - failIfErrsM ; -- Don't typecheck if renaming failed + (rn_splice_expr, splice_fvs) <- checkNoErrs (rnLExpr splice_expr) ; + -- checkNoErrs: don't typecheck if renaming failed rnDump (ppr rn_splice_expr) ; -- Execute the splice @@ -455,7 +428,7 @@ tc_rn_src_decls boot_details ds setGblEnv (tcg_env `addTcgDUs` usesOnly splice_fvs) $ tc_rn_src_decls boot_details (spliced_decls ++ rest_ds) #endif /* GHCI */ - }}} + } } } \end{code} %************************************************************************ @@ -488,7 +461,7 @@ tcRnHsBootDecls decls -- Typecheck instance decls ; traceTc (text "Tc3") - ; (tcg_env, inst_infos, _binds) + ; (tcg_env, inst_infos, _deriv_binds) <- tcInstDecls1 tycl_decls (hs_instds rn_group) (hs_derivds rn_group) ; setGblEnv tcg_env $ do { @@ -502,7 +475,7 @@ tcRnHsBootDecls decls ; gbl_env <- getGblEnv -- Make the final type-env - -- Include the dfun_ids so that their type sigs get + -- Include the dfun_ids so that their type sigs -- are written into the interface file ; let { type_env0 = tcg_type_env gbl_env ; type_env1 = extendTypeEnvWithIds type_env0 val_ids @@ -519,7 +492,7 @@ 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) +checkHiBootIface :: TcGblEnv -> ModDetails -> TcM TcGblEnv -- 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 @@ -529,68 +502,105 @@ checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id) -- hs-boot file, such as $fbEqT = $fEqT checkHiBootIface - (TcGblEnv { tcg_insts = local_insts, tcg_fam_insts = local_fam_insts, - tcg_type_env = local_type_env }) + tcg_env@(TcGblEnv { tcg_src = hs_src, tcg_binds = binds, + tcg_insts = local_insts, tcg_fam_insts = local_fam_insts, + tcg_type_env = local_type_env, tcg_exports = local_exports }) (ModDetails { md_insts = boot_insts, md_fam_insts = boot_fam_insts, - md_types = boot_type_env }) - = do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts)) ; - ; mapM_ check_one (typeEnvElts boot_type_env) - ; dfun_binds <- mapM check_inst boot_insts + md_types = boot_type_env, md_exports = boot_exports }) + | isHsBoot hs_src -- Current module is already a hs-boot file! + = return tcg_env + + | otherwise + = do { traceTc (text "checkHiBootIface" <+> (ppr boot_type_env $$ ppr boot_insts $$ + ppr boot_exports)) ; + + -- Check the exports of the boot module, one by one + ; mapM_ check_export boot_exports + + -- Check instance declarations + ; mb_dfun_prs <- mapM check_inst boot_insts + ; let tcg_env' = tcg_env { tcg_binds = binds `unionBags` dfun_binds, + tcg_type_env = extendTypeEnvWithIds local_type_env boot_dfuns } + dfun_prs = catMaybes mb_dfun_prs + boot_dfuns = map fst dfun_prs + dfun_binds = listToBag [ noLoc $ VarBind boot_dfun (nlHsVar dfun) + | (boot_dfun, dfun) <- dfun_prs ] + + -- Check for no family instances ; unless (null boot_fam_insts) $ panic ("TcRnDriver.checkHiBootIface: Cannot handle family " ++ "instances in boot files yet...") -- FIXME: Why? The actual comparison is not hard, but what would -- be the equivalent to the dfun bindings returned for class -- instances? We can't easily equate tycons... - ; return (unionManyBags dfun_binds) } + + ; return tcg_env' } where - check_one boot_thing - | no_check name - = return () + check_export boot_avail -- boot_avail is exported by the boot iface + | name `elem` dfun_names = return () + | isWiredInName name = return () -- No checking for wired-in names. In particular, + -- 'error' is handled by a rather gross hack + -- (see comments in GHC.Err.hs-boot) + + -- Check that the actual module exports the same thing + | not (null missing_names) + = addErrTc (missingBootThing (head missing_names) "exported by") + + -- If the boot module does not *define* the thing, we are done + -- (it simply re-exports it, and names match, so nothing further to do) + | isNothing mb_boot_thing = return () + + -- Check that the actual module also defines the thing, and + -- then compare the definitions | Just real_thing <- lookupTypeEnv local_type_env name - = do { let boot_decl = tyThingToIfaceDecl ext_nm boot_thing - real_decl = tyThingToIfaceDecl ext_nm real_thing + = do { let boot_decl = tyThingToIfaceDecl (fromJust mb_boot_thing) + real_decl = tyThingToIfaceDecl real_thing ; checkTc (checkBootDecl boot_decl real_decl) - (bootMisMatch boot_thing boot_decl real_decl) } + (bootMisMatch real_thing boot_decl real_decl) } -- The easiest way to check compatibility is to convert to -- iface syntax, where we already have good comparison functions + | otherwise - = addErrTc (missingBootThing boot_thing) + = addErrTc (missingBootThing name "defined in") where - name = getName boot_thing - - ext_nm name = ExtPkg (nameModule name) (nameOccName name) - -- Just enough to compare; no versions etc needed - - 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 - || isImplicitName name -- Has a parent, which we'll check - + name = availName boot_avail + mb_boot_thing = lookupTypeEnv boot_type_env name + missing_names = case lookupNameEnv local_export_env name of + Nothing -> [name] + Just avail -> availNames boot_avail `minusList` availNames avail + dfun_names = map getName boot_insts + local_export_env :: NameEnv AvailInfo + local_export_env = availsToNameEnv local_exports + + check_inst :: Instance -> TcM (Maybe (Id, Id)) + -- Returns a pair of the boot dfun in terms of the equivalent real dfun 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)) + [] -> do { addErrTc (instMisMatch boot_inst); return Nothing } + (dfun:_) -> return (Just (local_boot_dfun, dfun)) where boot_dfun = instanceDFunId boot_inst boot_inst_ty = idType boot_dfun - local_boot_dfun = mkExportedLocalId (idName boot_dfun) boot_inst_ty + local_boot_dfun = Id.mkExportedLocalId (idName boot_dfun) boot_inst_ty + ---------------- -missingBootThing thing - = ppr thing <+> ptext SLIT("is defined in the hs-boot file, but not in the module") +missingBootThing thing what + = ppr thing <+> ptext SLIT("is exported by the hs-boot file, but not") + <+> text what <+> ptext SLIT("the module") + bootMisMatch thing boot_decl real_decl = vcat [ppr thing <+> ptext SLIT("has conflicting definitions in the module and its hs-boot file"), - ptext SLIT("Decl") <+> ppr real_decl, - ptext SLIT("Boot file:") <+> ppr boot_decl] + ptext SLIT("Main module:") <+> ppr real_decl, + ptext SLIT("Boot file: ") <+> ppr boot_decl] + instMisMatch inst = hang (ppr inst) - 2 (ptext SLIT("is defined in the hs-boot file, but not in the module")) + 2 (ptext SLIT("is defined in the hs-boot file, but not in the module itself")) \end{code} @@ -612,17 +622,6 @@ declarations. It expects there to be an incoming TcGblEnv in the monad; it augments it and returns the new TcGblEnv. \begin{code} -tcRnGroup :: ModDetails -> HsGroup RdrName -> TcM (TcGblEnv, TcLclEnv) - -- Returns the variables free in the decls, for unused-binding reporting -tcRnGroup boot_details decls - = do { -- Rename the declarations - (tcg_env, rn_decls) <- rnTopSrcDecls decls ; - setGblEnv tcg_env $ do { - - -- Typecheck the declarations - tcTopSrcDecls boot_details rn_decls - }} - ------------------------------------------------ rnTopSrcDecls :: HsGroup RdrName -> TcM (TcGblEnv, HsGroup Name) rnTopSrcDecls group @@ -694,12 +693,17 @@ tcTopSrcDecls boot_details -- We also typecheck any extra binds that came out -- of the "deriving" process (deriv_binds) traceTc (text "Tc5") ; - (tc_val_binds, tcl_env) <- tcTopBinds (val_binds `plusHsValBinds` deriv_binds) ; + (tc_val_binds, tcl_env) <- tcTopBinds val_binds ; setLclTypeEnv tcl_env $ do { + -- Now GHC-generated derived bindings and generics. + -- Do not generate warnings from compiler-generated code. + (tc_deriv_binds, tcl_env) <- discardWarnings $ + tcTopBinds deriv_binds ; + -- Second pass over class and instance declarations, traceTc (text "Tc6") ; - (inst_binds, tcl_env) <- tcInstDecls2 tycl_decls inst_infos ; + (inst_binds, tcl_env) <- setLclTypeEnv tcl_env $ tcInstDecls2 tycl_decls inst_infos ; showLIE (text "after instDecls2") ; -- Foreign exports @@ -714,6 +718,7 @@ tcTopSrcDecls boot_details traceTc (text "Tc7a") ; tcg_env <- getGblEnv ; let { all_binds = tc_val_binds `unionBags` + tc_deriv_binds `unionBags` inst_binds `unionBags` foe_binds ; @@ -737,26 +742,18 @@ tcTopSrcDecls boot_details checkMain :: TcM TcGblEnv -- If we are in module Main, check that 'main' is defined. checkMain - = do { ghc_mode <- getGhcMode ; - tcg_env <- getGblEnv ; + = do { 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 dflags tcg_env } - -check_main ghc_mode tcg_env main_mod main_fn +check_main dflags tcg_env | 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 + = do { mb_main <- lookupSrcOcc_maybe main_fn -- Check that 'main' is in scope -- It might be imported from another module! ; case mb_main of { @@ -764,29 +761,20 @@ check_main ghc_mode tcg_env main_mod 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)) $ + ; (main_expr, ty) <- addErrCtxt mainCtxt $ + 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! - + -- See Note [Root-main Id] ; 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 + (getSrcSpan main_name) + ; root_main_id = Id.mkExportedLocalId root_main_name ty ; main_bind = noLoc (VarBind root_main_id main_expr) } ; return (tcg_env { tcg_binds = tcg_binds tcg_env @@ -798,19 +786,40 @@ check_main ghc_mode tcg_env main_mod main_fn }) }}} where - mod = tcg_mod tcg_env - - complain_no_main | ghc_mode == Interactive = return () - | otherwise = failWithTc noMainMsg + mod = tcg_mod tcg_env + main_mod = mainModIs dflags + main_is_flag = mainFunIs dflags + + main_fn = case main_is_flag of + Just fn -> mkRdrUnqual (mkVarOccFS (mkFastString fn)) + Nothing -> main_RDR_Unqual + + complain_no_main | ghcLink dflags == LinkInMemory = 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) + mainCtxt = ptext SLIT("When checking the type of the") <+> pp_main_fn + noMainMsg = ptext SLIT("The") <+> pp_main_fn <+> ptext SLIT("is not defined in module") <+> quotes (ppr main_mod) + pp_main_fn | isJust main_is_flag = ptext SLIT("main function") <+> quotes (ppr main_fn) + | otherwise = ptext SLIT("function") <+> quotes (ppr main_fn) \end{code} +Note [Root-main Id] +~~~~~~~~~~~~~~~~~~~ +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".) + +This is unusual: it's a LocalId whose Name has a Module from another +module. Tiresomely, we must filter it out again in MkIface, les we +get two defns for 'main' in the interface file! + + %********************************************************* %* * GHCi stuff @@ -825,16 +834,25 @@ setInteractiveContext hsc_env icxt thing_inside -- 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) + dfuns = fst (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)) + tcExtendGhciEnv (ic_tmp_ids icxt) $ + -- tcExtendGhciEnv does lots: + -- - it extends the local type env (tcl_env) with the given Ids, + -- - it extends the local rdr env (tcl_rdr) with the Names from + -- the given Ids + -- - it adds the free tyvars of the Ids to the tcl_tyvars + -- set. + -- + -- later ids in ic_tmp_ids must shadow earlier ones with the same + -- OccName, and tcExtendIdEnv implements this behaviour. + + do { traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt)) ; thing_inside } \end{code} @@ -843,9 +861,10 @@ setInteractiveContext hsc_env icxt thing_inside 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] + -> IO (Maybe ([Id], LHsExpr Id)) + -- The returned [Id] is the list of new Ids bound by + -- this statement. It can be used to extend the + -- InteractiveContext via extendInteractiveContext. -- -- The returned TypecheckedHsExpr is of type IO [ () ], -- a list of the bound values, coerced to (). @@ -880,32 +899,31 @@ tcRnStmt hsc_env ictxt rdr_stmt -- 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 ; +{- --------------------------------------------- + At one stage I removed any shadowed bindings from the type_env; + they are inaccessible but might, I suppose, cause a space leak if we leave them there. + However, with Template Haskell they aren't necessarily inaccessible. Consider this + GHCi session + Prelude> let f n = n * 2 :: Int + Prelude> fName <- runQ [| f |] + Prelude> $(return $ AppE fName (LitE (IntegerL 7))) + 14 + Prelude> let f n = n * 3 :: Int + Prelude> $(return $ AppE fName (LitE (IntegerL 7))) + In the last line we use 'fName', which resolves to the *first* 'f' + in scope. If we delete it from the type env, GHCi crashes because + it doesn't expect that. + + Hence this code is commented out - 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) + returnM (global_ids, zonked_expr) } where bad_unboxed id = addErr (sep [ptext SLIT("GHCi can't bind a variable of unlifted type:"), @@ -914,7 +932,7 @@ tcRnStmt hsc_env ictxt rdr_stmt globaliseAndTidy :: Id -> Id globaliseAndTidy id -- Give the Id a Global Name, and tidy its type - = setIdType (globaliseId VanillaGlobal id) tidy_type + = Id.setIdType (globaliseId VanillaGlobal id) tidy_type where tidy_type = tidyTopType (idType id) \end{code} @@ -1074,12 +1092,11 @@ tcRnExpr hsc_env ictxt rdr_expr -- 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) ; + ((qtvs, dict_insts, _), 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) $ + let { all_expr_ty = mkForAllTys qtvs $ + mkFunTys (map (idType . instToId) dict_insts) $ res_ty } ; zonkTcType all_expr_ty } @@ -1124,18 +1141,34 @@ tcRnType hsc_env ictxt rdr_type -- 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 :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo]) getModuleExports hsc_env mod - = initTc hsc_env HsSrcFile iNTERACTIVE (tcGetModuleExports mod) + = let + ic = hsc_IC hsc_env + checkMods = ic_toplev_scope ic ++ ic_exports ic + in + initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod checkMods) + +-- Get the export avail info and also load all orphan and family-instance +-- modules. Finally, check that the family instances of all modules in the +-- interactive context are consistent (these modules are in the second +-- argument). +tcGetModuleExports :: Module -> [Module] -> TcM [AvailInfo] +tcGetModuleExports mod directlyImpMods + = do { let doc = ptext SLIT("context for compiling statements") + ; iface <- initIfaceTcRn $ loadSysInterface doc mod -tcGetModuleExports :: Module -> TcM NameSet -tcGetModuleExports mod = do - let doc = ptext SLIT("context for compiling statements") - iface <- initIfaceTcRn $ loadSysInterface doc mod - loadOrphanModules (dep_orphs (mi_deps iface)) - -- Load any orphan-module interfaces, - -- so their instances are visible - ifaceExportNames (mi_exports iface) + -- Load any orphan-module and family instance-module + -- interfaces, so their instances are visible. + ; loadOrphanModules (dep_orphs (mi_deps iface)) False + ; loadOrphanModules (dep_finsts (mi_deps iface)) True + + -- Check that the family instances of all directly loaded + -- modules are consistent. + ; checkFamInstConsistency (dep_finsts (mi_deps iface)) directlyImpMods + + ; ifaceExportNames (mi_exports iface) + } tcRnLookupRdrName :: HscEnv -> RdrName -> IO (Maybe [Name]) tcRnLookupRdrName hsc_env rdr_name @@ -1172,13 +1205,23 @@ lookup_rdr_name rdr_name = do { return good_names } - tcRnLookupName :: HscEnv -> Name -> IO (Maybe TyThing) tcRnLookupName hsc_env name = initTcPrintErrors hsc_env iNTERACTIVE $ setInteractiveContext hsc_env (hsc_IC hsc_env) $ - tcLookupGlobal name + tcRnLookupName' name +-- To look up a name we have to look in the local environment (tcl_lcl) +-- as well as the global environment, which is what tcLookup does. +-- But we also want a TyThing, so we have to convert: + +tcRnLookupName' :: Name -> TcRn TyThing +tcRnLookupName' name = do + tcthing <- tcLookup name + case tcthing of + AGlobal thing -> return thing + ATcId{tct_id=id} -> return (AnId id) + _ -> panic "tcRnLookupName'" tcRnGetInfo :: HscEnv -> Name @@ -1202,12 +1245,11 @@ tcRnGetInfo hsc_env name -- in the home package all relevant modules are loaded.) loadUnqualIfaces ictxt - thing <- tcLookupGlobal name + thing <- tcRnLookupName' 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! @@ -1306,6 +1348,7 @@ pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, tcg_rules = rules, tcg_imports = imports }) = vcat [ ppr_types insts type_env + , ppr_tycons fam_insts type_env , ppr_insts insts , ppr_fam_insts fam_insts , vcat (map ppr rules) @@ -1334,6 +1377,17 @@ ppr_types insts type_env -- that the type checker has invented. Top-level user-defined things -- have External names. +ppr_tycons :: [FamInst] -> TypeEnv -> SDoc +ppr_tycons fam_insts type_env + = text "TYPE CONSTRUCTORS" $$ nest 4 (ppr_tydecls tycons) + where + fi_tycons = map famInstTyCon fam_insts + tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon] + want_tycon tycon | opt_PprStyle_Debug = True + | otherwise = not (isImplicitTyCon tycon) && + isExternalName (tyConName tycon) && + not (tycon `elem` fi_tycons) + ppr_insts :: [Instance] -> SDoc ppr_insts [] = empty ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs) @@ -1351,6 +1405,16 @@ ppr_sigs ids le_sig id1 id2 = getOccName id1 <= getOccName id2 ppr_sig id = ppr id <+> dcolon <+> ppr (tidyTopType (idType id)) +ppr_tydecls :: [TyCon] -> SDoc +ppr_tydecls tycons + -- Print type constructor info; sort by OccName + = vcat (map ppr_tycon (sortLe le_sig tycons)) + where + le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2 + ppr_tycon tycon + | isCoercionTyCon tycon = ptext SLIT("coercion") <+> ppr tycon + | otherwise = ppr (tyThingToIfaceDecl (ATyCon tycon)) + ppr_rules :: [CoreRule] -> SDoc ppr_rules [] = empty ppr_rules rs = vcat [ptext SLIT("{-# RULES"),