X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnBinds.lhs;h=1d17c7b4cc85329819ce38598cf698b4be37b3f8;hb=d8c655c1e3cac3eaf4ffa223b06fc37aba0871e5;hp=e7a781c6439f8e51e941fc95cb6311d7b311941a;hpb=7502efdcd468b9a77385c5456481cf39f8eec79f;p=ghc-hetmet.git diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index e7a781c..1d17c7b 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -20,11 +20,9 @@ module RnBinds (rnTopBinds, rnTopBindsLHS, rnTopBindsRHS, -- use these for top-l rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS, -- or these for local bindings rnMethodBinds, renameSigs, mkSigTvFn, rnMatchGroup, rnGRHSs, - makeMiniFixityEnv + makeMiniFixityEnv, MiniFixityEnv ) where -#include "HsVersions.h" - import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) import HsSyn @@ -36,16 +34,7 @@ import RnPat (rnPatsAndThen_LocalRightwards, rnBindPat, NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker, patSigErr) -import RnEnv ( lookupLocatedBndrRn, - lookupInstDeclBndr, newIPNameRn, - lookupLocatedSigOccRn, bindPatSigTyVarsFV, - bindLocalFixities, bindSigTyVarsFV, - warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, - bindLocatedLocalsFV, bindLocalNames, bindLocalNamesFV, - bindLocalNamesFV_WithFixities, - bindLocatedLocalsRn, - checkDupAndShadowedRdrNames - ) +import RnEnv import DynFlags ( DynFlag(..) ) import HscTypes (FixItem(..)) import Name @@ -175,8 +164,7 @@ it expects the global environment to contain bindings for the binders \begin{code} -- for top-level bindings, we need to make top-level names, -- so we have a different entry point than for local bindings -rnTopBindsLHS :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind - -- these fixities need to be brought into scope with the names +rnTopBindsLHS :: MiniFixityEnv -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) rnTopBindsLHS fix_env binds = @@ -200,7 +188,7 @@ rnTopBindsRHS bound_names binds = rnTopBinds :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) rnTopBinds b = - do nl <- rnTopBindsLHS emptyUFM b + do nl <- rnTopBindsLHS emptyFsEnv b let bound_names = map unLoc (collectHsValBinders nl) bindLocalNames bound_names $ rnTopBindsRHS bound_names nl @@ -262,8 +250,7 @@ rnIPBind (IPBind n expr) = do \begin{code} -- wrapper for local binds -- creates the documentation info and calls the helper below -rnValBindsLHS :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind - -- these fixities need to be brought into scope with the names +rnValBindsLHS :: MiniFixityEnv -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) rnValBindsLHS fix_env binds = @@ -274,8 +261,7 @@ rnValBindsLHS fix_env binds = -- just so we don't forget to do it somewhere rnValBindsLHSFromDoc_Local :: [Located RdrName] -- RdrNames of the LHS (so we don't have to gather them twice) -> SDoc -- doc string for dup names and shadowing - -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind - -- these fixities need to be brought into scope with the names + -> MiniFixityEnv -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) @@ -332,6 +318,8 @@ rnValBindsRHSGen :: (FreeVars -> FreeVars) -- for trimming free var sets rnValBindsRHSGen trim bound_names binds@(ValBindsIn mbinds sigs) = do -- rename the sigs + env <- getGblEnv + traceRn (ptext (sLit "Rename sigs") <+> ppr (tcg_rdr_env env)) sigs' <- rename_sigs sigs -- rename the RHSes binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds @@ -420,26 +408,24 @@ rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside -- Checks for duplicates, but not that only locally defined things are fixed. -- Note: for local fixity declarations, duplicates would also be checked in -- check_sigs below. But we also use this function at the top level. -makeMiniFixityEnv :: [LFixitySig RdrName] - -> RnM (UniqFM (Located Fixity)) -- key is the FastString of the OccName - -- of the fixity declaration it came from - -makeMiniFixityEnv decls = foldlM add_one emptyUFM decls + +makeMiniFixityEnv :: [LFixitySig RdrName] -> RnM MiniFixityEnv + +makeMiniFixityEnv decls = foldlM add_one emptyFsEnv decls where add_one env (L loc (FixitySig (L name_loc name) fixity)) = do { -- this fixity decl is a duplicate iff -- the ReaderName's OccName's FastString is already in the env -- (we only need to check the local fix_env because -- definitions of non-local will be caught elsewhere) - let {occ = rdrNameOcc name; - curKey = occNameFS occ; - fix_item = L loc fixity}; + let { fs = occNameFS (rdrNameOcc name) + ; fix_item = L loc fixity }; - case lookupUFM env curKey of - Nothing -> return $ addToUFM env curKey fix_item + case lookupFsEnv env fs of + Nothing -> return $ extendFsEnv env fs fix_item Just (L loc' _) -> do { setSrcSpan loc $ - addLocErr (L name_loc name) (dupFixityDecl loc') + addLocErr (L name_loc name) (dupFixityDecl loc') ; return env} } @@ -449,8 +435,8 @@ pprFixEnv env (nameEnvElts env) dupFixityDecl loc rdr_name - = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), - ptext SLIT("also at ") <+> ppr loc] + = vcat [ptext (sLit "Multiple fixity declarations for") <+> quotes (ppr rdr_name), + ptext (sLit "also at ") <+> ppr loc] --------------------- @@ -844,7 +830,7 @@ rnGRHS' ctxt (GRHS guards rhs) \begin{code} dupSigDeclErr sigs@(L loc sig : _) = addErrAt loc $ - vcat [ptext SLIT("Duplicate") <+> what_it_is <> colon, + vcat [ptext (sLit "Duplicate") <+> what_it_is <> colon, nest 2 (vcat (map ppr_sig sigs))] where what_it_is = hsSigDoc sig @@ -853,28 +839,28 @@ dupSigDeclErr sigs@(L loc sig : _) unknownSigErr (L loc sig) = do { mod <- getModule ; addErrAt loc $ - vcat [sep [ptext SLIT("Misplaced") <+> what_it_is <> colon, ppr sig], + vcat [sep [ptext (sLit "Misplaced") <+> what_it_is <> colon, ppr sig], extra_stuff mod sig] } where what_it_is = hsSigDoc sig extra_stuff mod (TypeSig (L _ n) _) | nameIsLocalOrFrom mod n - = ptext SLIT("The type signature must be given where") - <+> quotes (ppr n) <+> ptext SLIT("is declared") + = ptext (sLit "The type signature must be given where") + <+> quotes (ppr n) <+> ptext (sLit "is declared") | otherwise - = ptext SLIT("You cannot give a type signature for an imported value") + = ptext (sLit "You cannot give a type signature for an imported value") extra_stuff mod other = empty methodBindErr mbind - = hang (ptext SLIT("Pattern bindings (except simple variables) not allowed in instance declarations")) + = hang (ptext (sLit "Pattern bindings (except simple variables) not allowed in instance declarations")) 2 (ppr mbind) bindsInHsBootFile mbinds - = hang (ptext SLIT("Bindings in hs-boot files are not allowed")) + = hang (ptext (sLit "Bindings in hs-boot files are not allowed")) 2 (ppr mbinds) nonStdGuardErr guards - = hang (ptext SLIT("accepting non-standard pattern guards (use -XPatternGuards to suppress this message)")) + = hang (ptext (sLit "accepting non-standard pattern guards (use -XPatternGuards to suppress this message)")) 4 (interpp'SP guards) \end{code}