X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnBinds.lhs;h=9efe64e133ee1966c23dd38d1304c726d9b2fdfa;hb=27286cf2ce6733cbbf008972c6bea30ea2e562ee;hp=e52e3f1cb54d3a82cacc20530a8aa074413f360a;hpb=5f8d93baa07271687825458e01c187081bcb1ddc;p=ghc-hetmet.git diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index e52e3f1..9efe64e 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -23,12 +23,12 @@ import RdrHsSyn import RnHsSyn import TcRnMonad import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch) -import RnPat (rnPatsAndThen_LocalRightwards, rnBindPat, +import RnPat (rnPats, rnBindPat, NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker ) import RnEnv -import DynFlags ( DynFlag(..) ) +import DynFlags import Name import NameEnv import NameSet @@ -42,7 +42,7 @@ import Outputable import FastString import Data.List ( partition ) import Maybes ( orElse ) -import Monad ( foldM, unless ) +import Control.Monad \end{code} -- ToDo: Put the annotations into the monad, so that they arrive in the proper @@ -157,8 +157,8 @@ it expects the global environment to contain bindings for the binders rnTopBindsLHS :: MiniFixityEnv -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) -rnTopBindsLHS fix_env binds = - (uncurry $ rnValBindsLHSFromDoc (topRecNameMaker fix_env)) (bindersAndDoc binds) binds +rnTopBindsLHS fix_env binds + = rnValBindsLHSFromDoc (topRecNameMaker fix_env) binds rnTopBindsRHS :: NameSet -- Names bound by these binds -> HsValBindsLR Name RdrName @@ -178,7 +178,7 @@ rnTopBinds :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) rnTopBinds b = do nl <- rnTopBindsLHS emptyFsEnv b - let bound_names = map unLoc (collectHsValBinders nl) + let bound_names = collectHsValBinders nl bindLocalNames bound_names $ rnTopBindsRHS (mkNameSet bound_names) nl @@ -239,63 +239,46 @@ rnIPBind (IPBind n expr) = do %************************************************************************ \begin{code} --- wrapper for local binds --- creates the documentation info and calls the helper below +-- Renaming local binding gropus +-- Does duplicate/shadow check rnValBindsLHS :: MiniFixityEnv -> HsValBinds RdrName - -> RnM (HsValBindsLR Name RdrName) -rnValBindsLHS fix_env binds = - let (boundNames,doc) = bindersAndDoc binds - in rnValBindsLHSFromDoc_Local boundNames doc fix_env binds - --- a helper used for local binds that does the duplicates check, --- 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 - -> MiniFixityEnv - -> HsValBinds RdrName - -> RnM (HsValBindsLR Name RdrName) - -rnValBindsLHSFromDoc_Local boundNames doc fix_env binds = do - -- Do error checking: we need to check for dups here because we - -- don't don't bind all of the variables from the ValBinds at once - -- with bindLocatedLocals any more. - checkDupAndShadowedRdrNames doc boundNames - - -- (Note that we don't want to do this at the top level, since - -- sorting out duplicates and shadowing there happens elsewhere. - -- The behavior is even different. For example, - -- import A(f) - -- f = ... - -- should not produce a shadowing warning (but it will produce - -- an ambiguity warning if you use f), but - -- import A(f) - -- g = let f = ... in f - -- should. - rnValBindsLHSFromDoc (localRecNameMaker fix_env) boundNames doc binds - -bindersAndDoc :: HsValBinds RdrName -> ([Located RdrName], SDoc) -bindersAndDoc binds = - let - -- the unrenamed bndrs for error checking and reporting - orig = collectHsValBinders binds - doc = text "In the binding group for:" <+> pprWithCommas ppr (map unLoc orig) - in - (orig, doc) + -> RnM ([Name], HsValBindsLR Name RdrName) +rnValBindsLHS fix_env binds + = do { -- Do error checking: we need to check for dups here because we + -- don't don't bind all of the variables from the ValBinds at once + -- with bindLocatedLocals any more. + -- + -- Note that we don't want to do this at the top level, since + -- sorting out duplicates and shadowing there happens elsewhere. + -- The behavior is even different. For example, + -- import A(f) + -- f = ... + -- should not produce a shadowing warning (but it will produce + -- an ambiguity warning if you use f), but + -- import A(f) + -- g = let f = ... in f + -- should. + ; binds' <- rnValBindsLHSFromDoc (localRecNameMaker fix_env) binds + ; let bound_names = collectHsValBinders binds' + ; envs <- getRdrEnvs + ; checkDupAndShadowedNames envs bound_names + ; return (bound_names, binds') } -- renames the left-hand sides -- generic version used both at the top level and for local binds -- does some error checking, but not what gets done elsewhere at the top level rnValBindsLHSFromDoc :: NameMaker - -> [Located RdrName] -- RdrNames of the LHS (so we don't have to gather them twice) - -> SDoc -- doc string for dup names and shadowing -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) -rnValBindsLHSFromDoc topP _original_bndrs doc (ValBindsIn mbinds sigs) = do - -- rename the LHSes - mbinds' <- mapBagM (rnBindLHS topP doc) mbinds - return $ ValBindsIn mbinds' sigs -rnValBindsLHSFromDoc _ _ _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) +rnValBindsLHSFromDoc topP (ValBindsIn mbinds sigs) + = do { mbinds' <- mapBagM (rnBindLHS topP doc) mbinds + ; return $ ValBindsIn mbinds' sigs } + where + bndrs = collectHsBindsBinders mbinds + doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs + +rnValBindsLHSFromDoc _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) -- General version used both from the top-level and for local things -- Assumes the LHS vars are in scope @@ -308,16 +291,16 @@ rnValBindsRHSGen :: (FreeVars -> FreeVars) -- for trimming free var sets -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -rnValBindsRHSGen trim bound_names (ValBindsIn mbinds sigs) = do - -- rename the sigs - sigs' <- renameSigs (Just bound_names) okBindSig sigs - -- rename the RHSes - binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds - case depAnalBinds binds_w_dus of - (anal_binds, anal_dus) -> - do let valbind' = ValBindsOut anal_binds sigs' - valbind'_dus = usesOnly (hsSigsFVs sigs') `plusDU` anal_dus - return (valbind', valbind'_dus) +rnValBindsRHSGen trim bound_names (ValBindsIn mbinds sigs) + = do { -- rename the sigs + sigs' <- renameSigs (Just bound_names) okBindSig sigs + -- rename the RHSes + ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds + ; case depAnalBinds binds_w_dus of + (anal_binds, anal_dus) -> do + { let valbind' = ValBindsOut anal_binds sigs' + valbind'_dus = usesOnly (hsSigsFVs sigs') `plusDU` anal_dus + ; return (valbind', valbind'_dus) }} rnValBindsRHSGen _ _ b = pprPanic "rnValBindsRHSGen" (ppr b) @@ -330,10 +313,11 @@ rnValBindsRHSGen _ _ b = pprPanic "rnValBindsRHSGen" (ppr b) rnValBindsRHS :: NameSet -- names bound by the LHSes -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -rnValBindsRHS bound_names binds = - rnValBindsRHSGen (\ fvs -> -- only keep the names the names from this group - intersectNameSet bound_names fvs) bound_names binds - +rnValBindsRHS bound_names binds + = rnValBindsRHSGen trim bound_names binds + where + trim fvs = intersectNameSet bound_names fvs + -- Only keep the names the names from this group -- for local binds -- wrapper that does both the left- and right-hand sides @@ -344,17 +328,15 @@ rnValBindsAndThen :: HsValBinds RdrName -> (HsValBinds Name -> RnM (result, FreeVars)) -> RnM (result, FreeVars) rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside - = do { let (original_bndrs, doc) = bindersAndDoc binds - - -- (A) Create the local fixity environment - ; new_fixities <- makeMiniFixityEnv [L loc sig | L loc (FixSig sig) <- sigs] + = do { -- (A) Create the local fixity environment + new_fixities <- makeMiniFixityEnv [L loc sig | L loc (FixSig sig) <- sigs] -- (B) Rename the LHSes - ; new_lhs <- rnValBindsLHSFromDoc_Local original_bndrs doc new_fixities binds - ; let bound_names = map unLoc $ collectHsValBinders new_lhs + ; (bound_names, new_lhs) <- rnValBindsLHS new_fixities binds -- ...and bring them (and their fixities) into scope - ; bindLocalNamesFV_WithFixities bound_names new_fixities $ do + ; bindLocalNamesFV bound_names $ + addLocalFixities new_fixities bound_names $ do { -- (C) Do the RHS and thing inside (binds', dus) <- rnValBindsRHS (mkNameSet bound_names) new_lhs @@ -369,9 +351,9 @@ rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside ; let -- The variables "used" in the val binds are: - -- (1) the uses of the binds (duUses) + -- (1) the uses of the binds (allUses) -- (2) the FVs of the thing-inside - all_uses = duUses dus `plusFV` result_fvs + all_uses = allUses dus `plusFV` result_fvs -- Note [Unused binding hack] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Note that *in contrast* to the above reporting of @@ -416,7 +398,7 @@ makeMiniFixityEnv decls = foldlM add_one emptyFsEnv decls Nothing -> return $ extendFsEnv env fs fix_item Just (L loc' _) -> do { setSrcSpan loc $ - addLocErr (L name_loc name) (dupFixityDecl loc') + addErrAt name_loc (dupFixityDecl loc' name) ; return env} } @@ -461,8 +443,7 @@ rnBindLHS name_maker _ (L loc (FunBind { fun_id = name@(L nameLoc _), fun_tick = fun_tick })) = setSrcSpan loc $ - do { (newname, _fvs) <- applyNameMaker name_maker name $ \ newname -> - return (newname, emptyFVs) + do { newname <- applyNameMaker name_maker name ; return (L loc (FunBind { fun_id = L nameLoc newname, fun_infix = inf, fun_matches = matches, @@ -484,26 +465,27 @@ rnBind :: (Name -> [Name]) -- Signature tyvar function rnBind _ trim (L loc (PatBind { pat_lhs = pat, pat_rhs = grhss, -- pat fvs were stored here while - -- processing the LHS - bind_fvs=pat_fvs })) + -- after processing the LHS + bind_fvs = pat_fvs })) = setSrcSpan loc $ do {let bndrs = collectPatBinders pat ; (grhss', fvs) <- rnGRHSs PatBindRhs grhss -- No scoped type variables for pattern bindings - ; let fvs' = trim fvs + ; let all_fvs = pat_fvs `plusFV` fvs + fvs' = trim all_fvs ; fvs' `seq` -- See Note [Free-variable space leak] - return (L loc (PatBind { pat_lhs = pat, - pat_rhs = grhss', - pat_rhs_ty = placeHolderType, - bind_fvs = fvs' }), - bndrs, pat_fvs `plusFV` fvs) } + return (L loc (PatBind { pat_lhs = pat, + pat_rhs = grhss', + pat_rhs_ty = placeHolderType, + bind_fvs = fvs' }), + bndrs, all_fvs) } rnBind sig_fn trim (L loc (FunBind { fun_id = name, - fun_infix = inf, + fun_infix = is_infix, fun_matches = matches, -- no pattern FVs bind_fvs = _ @@ -514,18 +496,19 @@ rnBind sig_fn ; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ -- bindSigTyVars tests for Opt_ScopedTyVars - rnMatchGroup (FunRhs plain_name inf) matches + rnMatchGroup (FunRhs plain_name is_infix) matches ; let fvs' = trim fvs - ; checkPrecMatch inf plain_name matches' + ; when is_infix $ checkPrecMatch plain_name matches' ; fvs' `seq` -- See Note [Free-variable space leak] - return (L loc (FunBind { fun_id = name, - fun_infix = inf, - fun_matches = matches', - bind_fvs = fvs', - fun_co_fn = idHsWrapper, - fun_tick = Nothing }), + + return (L loc (FunBind { fun_id = name, + fun_infix = is_infix, + fun_matches = matches', + bind_fvs = fvs', + fun_co_fn = idHsWrapper, + fun_tick = Nothing }), [plain_name], fvs) } @@ -625,31 +608,31 @@ rnMethodBinds :: Name -- Class name -> RnM (LHsBinds Name, FreeVars) rnMethodBinds cls sig_fn gen_tyvars binds - = foldM do_one (emptyBag,emptyFVs) (bagToList binds) - where do_one (binds,fvs) bind = do - (bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind - return (bind' `unionBags` binds, fvs_bind `plusFV` fvs) + = foldlM do_one (emptyBag,emptyFVs) (bagToList binds) + where + do_one (binds,fvs) bind + = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind + ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) } rnMethodBind :: Name -> (Name -> [Name]) -> [Name] -> LHsBindLR RdrName RdrName -> RnM (Bag (LHsBindLR Name Name), FreeVars) -rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = inf, +rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = is_infix, fun_matches = MatchGroup matches _ })) = setSrcSpan loc $ do - sel_name <- lookupInstDeclBndr cls name + sel_name <- wrapLocM (lookupInstDeclBndr cls) name let plain_name = unLoc sel_name -- We use the selector name as the binder - bindSigTyVarsFV (sig_fn plain_name) $ do - (new_matches, fvs) <- mapFvRn (rn_match plain_name) matches - let - new_group = MatchGroup new_matches placeHolderType + (new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ + mapFvRn (rn_match (FunRhs plain_name is_infix)) matches + let new_group = MatchGroup new_matches placeHolderType - checkPrecMatch inf plain_name new_group - return (unitBag (L loc (FunBind { - fun_id = sel_name, fun_infix = inf, + when is_infix $ checkPrecMatch plain_name new_group + return (unitBag (L loc (FunBind { + fun_id = sel_name, fun_infix = is_infix, fun_matches = new_group, bind_fvs = fvs, fun_co_fn = idHsWrapper, fun_tick = Nothing })), @@ -658,19 +641,18 @@ rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = where -- Truly gruesome; bring into scope the correct members of the generic -- type variables. See comments in RnSource.rnSourceDecl(ClassDecl) - rn_match sel_name match@(L _ (Match (L _ (TypePat ty) : _) _ _)) + rn_match info match@(L _ (Match (L _ (TypePat ty) : _) _ _)) = extendTyVarEnvFVRn gen_tvs $ - rnMatch (FunRhs sel_name inf) match + rnMatch info match where tvs = map (rdrNameOcc.unLoc) (extractHsTyRdrTyVars ty) gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs] - rn_match sel_name match = rnMatch (FunRhs sel_name inf) match - + rn_match info match = rnMatch info match -- Can't handle method pattern-bindings which bind multiple methods. -rnMethodBind _ _ _ mbind@(L _ (PatBind _ _ _ _)) = do - addLocErr mbind methodBindErr +rnMethodBind _ _ _ (L loc bind@(PatBind {})) = do + addErrAt loc (methodBindErr bind) return (emptyBag, emptyFVs) rnMethodBind _ _ _ b = pprPanic "rnMethodBind" (ppr b) @@ -718,6 +700,8 @@ renameSigs mb_names ok_sig sigs renameSig :: Maybe NameSet -> Sig RdrName -> RnM (Sig Name) -- FixitySig is renamed elsewhere. +renameSig _ (IdSig x) + = return (IdSig x) -- Actually this never occurs renameSig mb_names sig@(TypeSig v ty) = do { new_v <- lookupSigOccRn mb_names sig v ; new_ty <- rnHsSigType (quotes (ppr v)) ty @@ -762,17 +746,15 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) = do { -- Result type signatures are no longer supported case maybe_rhs_sig of Nothing -> return () - Just ty -> addLocErr ty (resSigErr ctxt match) - + Just (L loc ty) -> addErrAt loc (resSigErr ctxt match ty) -- Now the main event -- note that there are no local ficity decls for matches - ; rnPatsAndThen_LocalRightwards ctxt pats $ \ pats' -> do + ; rnPats ctxt pats $ \ pats' -> do { (grhss', grhss_fvs) <- rnGRHSs ctxt grhss ; return (Match pats' Nothing grhss', grhss_fvs) }} -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs - where resSigErr :: HsMatchContext Name -> Match RdrName -> HsType RdrName -> SDoc resSigErr ctxt match ty