X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=521d71541ce3c2a826648977073907c2b5cf5027;hp=d2bae387f905f91c22f9f0e194a20094eb79a267;hb=61bcd16d4f3d4cf84b26bf7bb92f16f0440b7071;hpb=7299e42cc5214458ba16034dbfbf58de55f7121b diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index d2bae38..521d715 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -30,7 +30,7 @@ import RnEnv ( lookupLocalDataTcNames, bindLocalNames, checkDupRdrNames, mapFvRn, ) import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn ) -import HscTypes ( GenAvailInfo(..) ) +import HscTypes ( GenAvailInfo(..), availsToNameSet ) import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcRnMonad @@ -95,6 +95,7 @@ Checks the @(..)@ etc constraints in the export list. -- Brings the binders of the group into scope in the appropriate places; -- does NOT assume that anything is in scope already rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) +-- Rename a HsGroup; used for normal source files *and* hs-boot files rnSrcDecls group@(HsGroup {hs_valds = val_decls, hs_tyclds = tycl_decls, hs_instds = inst_decls, @@ -113,8 +114,10 @@ rnSrcDecls group@(HsGroup {hs_valds = val_decls, -- (B) Bring top level binders (and their fixities) into scope, -- *except* for the value bindings, which get brought in below. - avails <- getLocalNonValBinders group ; - tc_envs <- extendGlobalRdrEnvRn avails local_fix_env ; + -- However *do* include class ops, data constructors + -- And for hs-boot files *do* include the value signatures + tc_avails <- getLocalNonValBinders group ; + tc_envs <- extendGlobalRdrEnvRn tc_avails local_fix_env ; setEnvs tc_envs $ do { failIfErrsM ; -- No point in continuing if (say) we have duplicate declarations @@ -131,10 +134,12 @@ rnSrcDecls group@(HsGroup {hs_valds = val_decls, -- It uses the fixity env from (A) to bind fixities for view patterns. new_lhs <- rnTopBindsLHS local_fix_env val_decls ; -- bind the LHSes (and their fixities) in the global rdr environment - let { lhs_binders = map unLoc $ collectHsValBinders new_lhs; - lhs_avails = map Avail lhs_binders + let { val_binders = map unLoc $ collectHsValBinders new_lhs ; + val_bndr_set = mkNameSet val_binders ; + all_bndr_set = val_bndr_set `unionNameSets` availsToNameSet tc_avails ; + val_avails = map Avail val_binders } ; - (tcg_env, tcl_env) <- extendGlobalRdrEnvRn lhs_avails local_fix_env ; + (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ; setEnvs (tcg_env, tcl_env) $ do { -- Now everything is in scope, as the remaining renaming assumes. @@ -154,18 +159,19 @@ rnSrcDecls group@(HsGroup {hs_valds = val_decls, -- (F) Rename Value declarations right-hand sides traceRn (text "Start rnmono") ; - (rn_val_decls, bind_dus) <- rnTopBindsRHS lhs_binders new_lhs ; + (rn_val_decls, bind_dus) <- rnTopBindsRHS val_bndr_set new_lhs ; traceRn (text "finish rnmono" <+> ppr rn_val_decls) ; -- (G) Rename Fixity and deprecations - -- rename fixity declarations and error if we try to + -- Rename fixity declarations and error if we try to -- fix something from another module (duplicates were checked in (A)) - rn_fix_decls <- rnSrcFixityDecls fix_decls ; - -- rename deprec decls; + rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ; + + -- Rename deprec decls; -- check for duplicates and ensure that deprecated things are defined locally -- at the moment, we don't keep these around past renaming - rn_warns <- rnSrcWarnDecls warn_decls ; + rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ; -- (H) Rename Everything else @@ -259,14 +265,14 @@ rnDocDecl (DocGroup lev doc) = do %********************************************************* \begin{code} -rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM [LFixitySig Name] +rnSrcFixityDecls :: NameSet -> [LFixitySig RdrName] -> RnM [LFixitySig Name] -- Rename the fixity decls, so we can put -- the renamed decls in the renamed syntax tree -- Errors if the thing being fixed is not defined locally. -- -- The returned FixitySigs are not actually used for anything, -- except perhaps the GHCi API -rnSrcFixityDecls fix_decls +rnSrcFixityDecls bound_names fix_decls = do fix_decls <- mapM rn_decl fix_decls return (concat fix_decls) where @@ -278,9 +284,10 @@ rnSrcFixityDecls fix_decls rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity)) = setSrcSpan name_loc $ -- this lookup will fail if the definition isn't local - do names <- lookupLocalDataTcNames rdr_name + do names <- lookupLocalDataTcNames bound_names what rdr_name return [ L loc (FixitySig (L name_loc name) fixity) - | name <- names ] + | name <- names ] + what = ptext (sLit "fixity signature") \end{code} @@ -298,11 +305,11 @@ gather them together. \begin{code} -- checks that the deprecations are defined locally, and that there are no duplicates -rnSrcWarnDecls :: [LWarnDecl RdrName] -> RnM Warnings -rnSrcWarnDecls [] +rnSrcWarnDecls :: NameSet -> [LWarnDecl RdrName] -> RnM Warnings +rnSrcWarnDecls _bound_names [] = returnM NoWarnings -rnSrcWarnDecls decls +rnSrcWarnDecls bound_names decls = do { -- check for duplicates ; mappM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupWarnDecl lrdr')) warn_rdr_dups ; mappM (addLocM rn_deprec) decls `thenM` \ pairs_s -> @@ -310,9 +317,11 @@ rnSrcWarnDecls decls where rn_deprec (Warning rdr_name txt) -- ensures that the names are defined locally - = lookupLocalDataTcNames rdr_name `thenM` \ names -> + = lookupLocalDataTcNames bound_names what rdr_name `thenM` \ names -> returnM [(nameOccName name, txt) | name <- names] + what = ptext (sLit "deprecation") + -- look for duplicates among the OccNames; -- we check that the names are defined above -- invt: the lists returned by findDupsEq always have at least two elements @@ -1038,14 +1047,16 @@ extendRecordFieldEnv decls ; return $ unLoc x'} get (L _ (TyData { tcdCons = cons })) env = foldrM get_con env cons - get _ env = return env + get _ env = return env - get_con (L _ (ConDecl { con_name = con, con_details = RecCon flds })) env + get_con (L _ (ConDecl { con_name = con, con_details = RecCon flds })) + (RecFields env fld_set) = do { con' <- lookup con - ; flds' <- mappM lookup (map cd_fld_name flds) - ; return $ extendNameEnv env con' flds' } - get_con _ env - = return env + ; flds' <- mappM lookup (map cd_fld_name flds) + ; let env' = extendNameEnv env con' flds' + fld_set' = addListToNameSet fld_set flds' + ; return $ (RecFields env' fld_set') } + get_con _ env = return env \end{code} %*********************************************************