X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnDriver.lhs;h=a1592ec2a490a4422ecfbc58aad93c9aa8cd7fe1;hp=372ccab14859547f72c691d131472091aef25865;hb=b00b5bc04ff36a551552470060064f0b7d84ca30;hpb=db375d630cb6e3377e48daaa0388ba5a4f798f7b diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs index 372ccab..a1592ec 100644 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@ -40,7 +40,9 @@ import TcExpr ( tcInferRho ) import TcRnMonad import TcType ( tidyTopType, tcEqType ) import Inst ( showLIE ) -import InstEnv ( extendInstEnvList, Instance, pprInstances, instanceDFunId ) +import InstEnv ( extendInstEnvList, Instance, pprInstances, + instanceDFunId ) +import FamInstEnv ( FamInst, pprFamInsts ) import TcBinds ( tcTopBinds, tcHsBootSigs ) import TcDefaults ( tcDefaults ) import TcEnv ( tcExtendGlobalValEnv, iDFunId ) @@ -49,12 +51,11 @@ import TcForeign ( tcForeignImports, tcForeignExports ) import TcInstDcls ( tcInstDecls1, tcInstDecls2 ) import TcIface ( tcExtCoreBindings, tcHiBootIface ) import MkIface ( tyThingToIfaceDecl ) -import IfaceSyn ( checkBootDecl, IfaceExtName(..) ) +import IfaceSyn 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 ) @@ -68,8 +69,9 @@ import Module import UniqFM ( elemUFM, eltsUFM ) import OccName ( mkVarOccFS, plusOccEnv ) import Name ( Name, NamedThing(..), isExternalName, getSrcLoc, isWiredInName, - nameModule, nameOccName, isImplicitName, mkExternalName ) + nameModule, nameOccName, mkExternalName ) import NameSet +import NameEnv import TyCon ( tyConHasGenerics ) import SrcLoc ( srcLocSpan, Located(..), noLoc ) import DriverPhases ( HscSource(..), isHsBoot ) @@ -77,10 +79,10 @@ import HscTypes ( ModGuts(..), ModDetails(..), emptyModDetails, HscEnv(..), ExternalPackageState(..), IsBootInterface, noDependencies, Deprecs( NoDeprecs ), plusDeprecs, - ForeignStubs(NoStubs), + ForeignStubs(NoStubs), availsToNameSet, TypeEnv, lookupTypeEnv, hptInstances, extendTypeEnvWithIds, typeEnvIds, typeEnvTyCons, typeEnvElts, - emptyFixityEnv + emptyFixityEnv, GenAvailInfo(..) ) import Outputable @@ -119,7 +121,6 @@ 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(..), @@ -134,6 +135,7 @@ import FastString ( mkFastString ) import Util ( sortLe ) import Bag ( unionBags, snocBag, emptyBag, unitBag, unionManyBags ) +import Control.Monad ( unless ) import Data.Maybe ( isJust ) \end{code} @@ -168,8 +170,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax setSrcSpan loc $ do { -- Deal with imports; - rn_imports <- rnImports import_decls ; - (rdr_env, imports) <- mkRdrEnvAndImports rn_imports ; + (rn_imports, rdr_env, imports) <- rnImports import_decls ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) ; dep_mods = imp_dep_mods imports @@ -208,6 +209,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax -- 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 interfaces, so that @@ -232,7 +234,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax reportDeprecations (hsc_dflags hsc_env) tcg_env ; -- Process the export list - rn_exports <- rnExports export_ies ; + (rn_exports, exports) <- rnExports (isJust maybe_mod) export_ies ; -- Rename the Haddock documentation header rn_module_doc <- rnMbHsDoc maybe_doc ; @@ -241,10 +243,6 @@ tcRnModule hsc_env hsc_src save_rn_syntax 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 } ; @@ -254,7 +252,7 @@ tcRnModule hsc_env hsc_src save_rn_syntax tcg_rn_exports = if save_rn_syntax then rn_exports else Nothing, - tcg_dus = tcg_dus tcg_env `plusDU` usesOnly exports, + tcg_dus = tcg_dus tcg_env `plusDU` usesOnly (availsToNameSet exports), tcg_deprecs = tcg_deprecs tcg_env `plusDeprecs` mod_deprecs, tcg_doc = rn_module_doc, @@ -318,27 +316,28 @@ 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 ; - mod_guts = ModGuts { mg_module = this_mod, - mg_boot = False, - mg_usages = [], -- ToDo: compute usage - mg_dir_imps = [], -- ?? - mg_deps = noDependencies, -- ?? - mg_exports = my_exports, - mg_types = final_type_env, - mg_insts = tcg_insts tcg_env, - mg_rules = [], - mg_binds = core_binds, + mod_guts = ModGuts { mg_module = this_mod, + mg_boot = False, + mg_usages = [], -- ToDo: compute usage + mg_dir_imps = [], -- ?? + mg_deps = noDependencies, -- ?? + mg_exports = my_exports, + mg_types = final_type_env, + mg_insts = tcg_insts tcg_env, + mg_fam_insts = tcg_fam_insts tcg_env, + mg_rules = [], + mg_binds = core_binds, -- Stubs - mg_rdr_env = emptyGlobalRdrEnv, - mg_fix_env = emptyFixityEnv, - mg_deprecs = NoDeprecs, - mg_foreign = NoStubs + mg_rdr_env = emptyGlobalRdrEnv, + mg_fix_env = emptyFixityEnv, + mg_deprecs = NoDeprecs, + mg_foreign = NoStubs } } ; tcCoreDump mod_guts ; @@ -525,19 +524,27 @@ checkHiBootIface :: TcGblEnv -> ModDetails -> TcM (LHsBinds Id) -- 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 }) + (TcGblEnv { tcg_insts = local_insts, tcg_fam_insts = local_fam_insts, + tcg_type_env = local_type_env, tcg_imports = imports }) + (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 + ; 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) } where check_one boot_thing | no_check name = return () | 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 boot_thing + real_decl = tyThingToIfaceDecl real_thing ; checkTc (checkBootDecl boot_decl real_decl) (bootMisMatch boot_thing boot_decl real_decl) } -- The easiest way to check compatibility is to convert to @@ -547,14 +554,16 @@ checkHiBootIface where name = getName boot_thing - ext_nm name = ExtPkg (nameModule name) (nameOccName name) - -- Just enough to compare; no versions etc needed + avail_env = imp_parent imports + is_implicit name = case lookupNameEnv avail_env name of + Just (AvailTC tc _) | tc /= name -> True + _otherwise -> False 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 + || is_implicit name -- Has a parent, which we'll check dfun_names = map getName boot_insts @@ -773,7 +782,7 @@ check_main ghc_mode tcg_env main_mod main_fn ; let { root_main_name = mkExternalName rootMainKey rOOT_MAIN (mkVarOccFS FSLIT("main")) - (Just main_name) (getSrcLoc main_name) + (getSrcLoc main_name) ; root_main_id = mkExportedLocalId root_main_name ty ; main_bind = noLoc (VarBind root_main_id main_expr) } @@ -875,16 +884,30 @@ tcRnStmt hsc_env ictxt rdr_stmt 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 +{- --------------------------------------------- + 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 + 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_type_env = extendTypeEnvWithIds type_env global_ids ; new_ic = ictxt { ic_rn_local_env = new_rn_env, ic_type_env = new_type_env } } ; @@ -1288,12 +1311,14 @@ tcCoreDump mod_guts -- It's unpleasant having both pprModGuts and pprModDetails here pprTcGblEnv :: TcGblEnv -> SDoc -pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, - tcg_insts = dfun_ids, - tcg_rules = rules, - tcg_imports = imports }) - = vcat [ ppr_types dfun_ids type_env - , ppr_insts dfun_ids +pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_rules = rules, + tcg_imports = imports }) + = vcat [ ppr_types insts type_env + , ppr_insts insts + , ppr_fam_insts fam_insts , vcat (map ppr rules) , ppr_gen_tycons (typeEnvTyCons type_env) , ptext SLIT("Dependent modules:") <+> ppr (eltsUFM (imp_dep_mods imports)) @@ -1305,12 +1330,11 @@ pprModGuts (ModGuts { mg_types = type_env, = vcat [ ppr_types [] type_env, ppr_rules rules ] - ppr_types :: [Instance] -> TypeEnv -> SDoc -ppr_types ispecs type_env +ppr_types insts type_env = text "TYPE SIGNATURES" $$ nest 4 (ppr_sigs ids) where - dfun_ids = map instanceDFunId ispecs + dfun_ids = map instanceDFunId insts ids = [id | id <- typeEnvIds type_env, want_sig id] want_sig id | opt_PprStyle_Debug = True | otherwise = isLocalId id && @@ -1325,6 +1349,11 @@ ppr_insts :: [Instance] -> SDoc ppr_insts [] = empty ppr_insts ispecs = text "INSTANCES" $$ nest 2 (pprInstances ispecs) +ppr_fam_insts :: [FamInst] -> SDoc +ppr_fam_insts [] = empty +ppr_fam_insts fam_insts = + text "FAMILY INSTANCES" $$ nest 2 (pprFamInsts fam_insts) + ppr_sigs :: [Var] -> SDoc ppr_sigs ids -- Print type signatures; sort by OccName