)
import RnEnv
-import DynFlags ( DynFlag(..) )
+import DynFlags
import Name
import NameEnv
import NameSet
-> 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
-> 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
-- 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') }
= 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)
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
; (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
; 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
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 = _
; (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)
}
-> 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 })),
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
projects / ghc-hetmet.git / blobdiff