X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnBinds.lhs;h=9efe64e133ee1966c23dd38d1304c726d9b2fdfa;hb=1a9245caefb80a3c4c5965aaacdf9a607e792e1c;hp=876f25aeacd6c7d7cb0424b64dd2fd3374c52f9b;hpb=df8b00e014ad8280354dd3fab6e6df0a52377627;p=ghc-hetmet.git diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 876f25a..9efe64e 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -28,7 +28,7 @@ import RnPat (rnPats, rnBindPat, ) import RnEnv -import DynFlags ( DynFlag(..) ) +import DynFlags import Name import NameEnv import NameSet @@ -158,8 +158,7 @@ rnTopBindsLHS :: MiniFixityEnv -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) rnTopBindsLHS fix_env binds - = do { mod <- getModule - ; rnValBindsLHSFromDoc (topRecNameMaker mod fix_env) binds } + = rnValBindsLHSFromDoc (topRecNameMaker fix_env) binds rnTopBindsRHS :: NameSet -- Names bound by these binds -> HsValBindsLR Name RdrName @@ -179,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 @@ -261,7 +260,7 @@ rnValBindsLHS fix_env binds -- g = let f = ... in f -- should. ; binds' <- rnValBindsLHSFromDoc (localRecNameMaker fix_env) binds - ; let bound_names = map unLoc $ collectHsValBinders binds' + ; let bound_names = collectHsValBinders binds' ; envs <- getRdrEnvs ; checkDupAndShadowedNames envs bound_names ; return (bound_names, binds') } @@ -276,7 +275,7 @@ rnValBindsLHSFromDoc topP (ValBindsIn mbinds sigs) = do { mbinds' <- mapBagM (rnBindLHS topP doc) mbinds ; return $ ValBindsIn mbinds' sigs } where - bndrs = collectHsBindBinders mbinds + bndrs = collectHsBindsBinders mbinds doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs rnValBindsLHSFromDoc _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) @@ -314,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 @@ -335,7 +335,8 @@ rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside ; (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 @@ -350,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 @@ -464,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 = _ @@ -494,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) } @@ -605,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 <- 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 })), @@ -638,15 +641,14 @@ 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 _ _ _ (L loc bind@(PatBind {})) = do