X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnBinds.lhs;h=fd5695b0c1608d3f98eb4b984e9db28dee06f374;hp=134a929bef516a559cf720b324810cfb839939dc;hb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;hpb=432b38b66700d243369df5b76e5c5c01b5e197ff diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 134a929..fd5695b 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -23,13 +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 PrelNames ( mkUnboundName ) -import DynFlags ( DynFlag(..) ) +import DynFlags import Name import NameEnv import NameSet @@ -37,13 +36,13 @@ import RdrName ( RdrName, rdrNameOcc ) import SrcLoc import ListSetOps ( findDupsEq ) import BasicTypes ( RecFlag(..) ) -import Digraph ( SCC(..), stronglyConnComp ) +import Digraph ( SCC(..), stronglyConnCompFromEdgedVertices ) import Bag 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 @@ -158,10 +157,10 @@ 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 :: [Name] -- the names bound by these binds +rnTopBindsRHS :: NameSet -- Names bound by these binds -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) rnTopBindsRHS bound_names binds = @@ -170,18 +169,17 @@ rnTopBindsRHS bound_names binds = then rnTopBindsBoot binds else rnValBindsRHSGen (\x -> x) -- don't trim free vars bound_names binds } - --- wrapper if we don't need to do anything in between the left and right, +-- Wrapper if we don't need to do anything in between the left and right, -- or anything else in the scope of the left -- --- never used when there are fixity declarations +-- Never used when there are fixity declarations rnTopBinds :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) rnTopBinds b = do nl <- rnTopBindsLHS emptyFsEnv b - let bound_names = map unLoc (collectHsValBinders nl) - bindLocalNames bound_names $ rnTopBindsRHS bound_names nl + let bound_names = collectHsValBinders nl + bindLocalNames bound_names $ rnTopBindsRHS (mkNameSet bound_names) nl rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) @@ -224,7 +222,7 @@ rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do rnIPBinds :: HsIPBinds RdrName -> RnM (HsIPBinds Name, FreeVars) rnIPBinds (IPBinds ip_binds _no_dict_binds) = do (ip_binds', fvs_s) <- mapAndUnzipM (wrapLocFstM rnIPBind) ip_binds - return (IPBinds ip_binds' emptyLHsBinds, plusFVs fvs_s) + return (IPBinds ip_binds' emptyTcEvBinds, plusFVs fvs_s) rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars) rnIPBind (IPBind n expr) = do @@ -241,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 @@ -306,21 +287,20 @@ rnValBindsLHSFromDoc _ _ _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) rnValBindsRHSGen :: (FreeVars -> FreeVars) -- for trimming free var sets -- The trimming function trims the free vars we attach to a -- binding so that it stays reasonably small - -> [Name] -- names bound by the LHSes + -> NameSet -- Names bound by the LHSes -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -rnValBindsRHSGen trim bound_names (ValBindsIn mbinds sigs) = do - -- rename the sigs - env <- getGblEnv - traceRn (ptext (sLit "Rename sigs") <+> ppr (tcg_rdr_env env)) - sigs' <- renameSigs (Just (mkNameSet bound_names)) okBindSig sigs - -- rename the RHSes - binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds - let (anal_binds, anal_dus) = depAnalBinds binds_w_dus - (valbind', valbind'_dus) = (ValBindsOut anal_binds sigs', - 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,13 +310,14 @@ rnValBindsRHSGen _ _ b = pprPanic "rnValBindsRHSGen" (ppr b) -- it doesn't (and can't: we don't have the thing inside the binds) happen here -- -- The client is also responsible for bringing the fixities into scope -rnValBindsRHS :: [Name] -- names bound by the LHSes +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 (mkNameSet 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 @@ -347,20 +328,18 @@ 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 bound_names new_lhs + (binds', dus) <- rnValBindsRHS (mkNameSet bound_names) new_lhs ; (result, result_fvs) <- thing_inside binds' -- Report unused bindings based on the (accurate) @@ -372,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 @@ -419,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} } @@ -440,42 +419,19 @@ rnBindLHS :: NameMaker -- (i.e., any free variables of the pattern) -> RnM (LHsBindLR Name RdrName) -rnBindLHS name_maker _ (L loc (PatBind { pat_lhs = pat, - pat_rhs = grhss, - pat_rhs_ty=pat_rhs_ty - })) +rnBindLHS name_maker _ (L loc bind@(PatBind { pat_lhs = pat })) = setSrcSpan loc $ do -- we don't actually use the FV processing of rnPatsAndThen here (pat',pat'_fvs) <- rnBindPat name_maker pat - return (L loc (PatBind { pat_lhs = pat', - pat_rhs = grhss, - -- we temporarily store the pat's FVs here; - -- gets updated to the FVs of the whole bind - -- when doing the RHS below - bind_fvs = pat'_fvs, - -- these will get ignored in the next pass, - -- when we rename the RHS - pat_rhs_ty = pat_rhs_ty })) - -rnBindLHS name_maker _ (L loc (FunBind { fun_id = name@(L nameLoc _), - fun_infix = inf, - fun_matches = matches, - fun_co_fn = fun_co_fn, - fun_tick = fun_tick - })) + return (L loc (bind { pat_lhs = pat', bind_fvs = pat'_fvs })) + -- We temporarily store the pat's FVs in bind_fvs; + -- gets updated to the FVs of the whole bind + -- when doing the RHS below + +rnBindLHS name_maker _ (L loc bind@(FunBind { fun_id = name@(L nameLoc _) })) = setSrcSpan loc $ - do { (newname, _fvs) <- applyNameMaker name_maker name $ \ newname -> - return (newname, emptyFVs) - ; return (L loc (FunBind { fun_id = L nameLoc newname, - fun_infix = inf, - fun_matches = matches, - -- we temporatily store the LHS's FVs (empty in this case) here - -- gets updated when doing the RHS below - bind_fvs = emptyFVs, - -- everything else will get ignored in the next pass - fun_co_fn = fun_co_fn, - fun_tick = fun_tick - })) } + do { newname <- applyNameMaker name_maker name + ; return (L loc (bind { fun_id = L nameLoc newname })) } rnBindLHS _ _ b = pprPanic "rnBindLHS" (ppr b) @@ -484,52 +440,61 @@ rnBind :: (Name -> [Name]) -- Signature tyvar function -> (FreeVars -> FreeVars) -- Trimming function for rhs free vars -> LHsBindLR Name RdrName -> RnM (LHsBind Name, [Name], Uses) -rnBind _ trim (L loc (PatBind { pat_lhs = pat, - pat_rhs = grhss, - -- pat fvs were stored here while - -- processing the LHS - bind_fvs=pat_fvs })) +rnBind _ trim (L loc bind@(PatBind { pat_lhs = pat + , pat_rhs = grhss + -- pat fvs were stored in bind_fvs + -- after processing the LHS + , bind_fvs = pat_fvs })) = setSrcSpan loc $ - do {let bndrs = collectPatBinders pat + do { let bndrs = collectPatBinders pat ; (grhss', fvs) <- rnGRHSs PatBindRhs grhss -- No scoped type variables for pattern bindings - - ; return (L loc (PatBind { pat_lhs = pat, - pat_rhs = grhss', - pat_rhs_ty = placeHolderType, - bind_fvs = trim fvs }), - bndrs, pat_fvs `plusFV` fvs) } - -rnBind sig_fn - trim - (L loc (FunBind { fun_id = name, - fun_infix = inf, - fun_matches = matches, - -- no pattern FVs - bind_fvs = _ - })) + ; let all_fvs = pat_fvs `plusFV` fvs + fvs' = trim all_fvs + + ; fvs' `seq` -- See Note [Free-variable space leak] + return (L loc (bind { pat_rhs = grhss' + , bind_fvs = fvs' }), + bndrs, all_fvs) } + +rnBind sig_fn trim + (L loc bind@(FunBind { fun_id = name + , fun_infix = is_infix + , fun_matches = matches })) -- invariant: no free vars here when it's a FunBind = setSrcSpan loc $ do { let plain_name = unLoc name ; (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' - ; return (L loc (FunBind { fun_id = name, - fun_infix = inf, - fun_matches = matches', - bind_fvs = trim fvs, - fun_co_fn = idHsWrapper, - fun_tick = Nothing }), + ; fvs' `seq` -- See Note [Free-variable space leak] + + return (L loc (bind { fun_matches = matches' + , bind_fvs = fvs' }), [plain_name], fvs) } rnBind _ _ b = pprPanic "rnBind" (ppr b) - + +{- +Note [Free-variable space leak] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We have + fvs' = trim fvs +and we seq fvs' before turning it as part of a record. + +The reason is that trim is sometimes something like + \xs -> intersectNameSet (mkNameSet bound_names) xs +and we don't want to retain the list bound_names. This showed up in +trac ticket #1136. +-} + --------------------- depAnalBinds :: Bag (LHsBind Name, [Name], Uses) -> ([(RecFlag, LHsBinds Name)], DefUses) @@ -538,7 +503,7 @@ depAnalBinds :: Bag (LHsBind Name, [Name], Uses) depAnalBinds binds_w_dus = (map get_binds sccs, map get_du sccs) where - sccs = stronglyConnComp edges + sccs = stronglyConnCompFromEdgedVertices edges keyd_nodes = bagToList binds_w_dus `zip` [0::Int ..] @@ -611,52 +576,50 @@ 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, - fun_matches = MatchGroup matches _ })) +rnMethodBind cls sig_fn gen_tyvars + (L loc bind@(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 - - checkPrecMatch inf plain_name new_group - return (unitBag (L loc (FunBind { - fun_id = sel_name, fun_infix = inf, - fun_matches = new_group, - bind_fvs = fvs, fun_co_fn = idHsWrapper, - fun_tick = Nothing })), + (new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ + mapFvRn (rn_match (FunRhs plain_name is_infix)) matches + let new_group = MatchGroup new_matches placeHolderType + + when is_infix $ checkPrecMatch plain_name new_group + return (unitBag (L loc (bind { fun_id = sel_name + , fun_matches = new_group + , bind_fvs = fvs })), fvs `addOneFV` plain_name) -- The 'fvs' field isn't used for method binds 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) @@ -704,6 +667,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 @@ -725,54 +690,6 @@ renameSig mb_names sig@(InlineSig v s) renameSig mb_names sig@(FixSig (FixitySig v f)) = do { new_v <- lookupSigOccRn mb_names sig v ; return (FixSig (FixitySig new_v f)) } - --- lookupSigOccRn is used for type signatures and pragmas --- Is this valid? --- module A --- import M( f ) --- f :: Int -> Int --- f x = x --- It's clear that the 'f' in the signature must refer to A.f --- The Haskell98 report does not stipulate this, but it will! --- So we must treat the 'f' in the signature in the same way --- as the binding occurrence of 'f', using lookupBndrRn --- --- However, consider this case: --- import M( f ) --- f :: Int -> Int --- g x = x --- We don't want to say 'f' is out of scope; instead, we want to --- return the imported 'f', so that later on the reanamer will --- correctly report "misplaced type sig". - -lookupSigOccRn :: Maybe NameSet -> Sig RdrName -> Located RdrName -> RnM (Located Name) -lookupSigOccRn mb_names sig (L loc v) - = do { mb_n <- lookupBndrRn_maybe v - ; case mb_n of { - Just n -> case mb_names of { - Nothing -> return (L loc n) ; - Just ns | n `elemNameSet` ns -> return (L loc n) - | otherwise -> bale_out_with local_msg } ; - - Nothing -> do - { mb_n <- lookupGreRn_maybe v - ; case mb_n of - Just _ -> bale_out_with import_msg - Nothing -> bale_out_with empty - } }} - where - bale_out_with msg - = do { addErr (sep [ ptext (sLit "The") <+> hsSigDoc sig - <+> ptext (sLit "for") <+> quotes (ppr v) - , nest 2 $ ptext (sLit "lacks an accompanying binding")] - $$ nest 2 msg) - ; return (L loc (mkUnboundName v)) } - - local_msg = parens $ ptext (sLit "The") <+> hsSigDoc sig <+> ptext (sLit "must be given where") - <+> quotes (ppr v) <+> ptext (sLit "is declared") - - import_msg = parens $ ptext (sLit "You cannot give a") <+> hsSigDoc sig - <+> ptext (sLit "an imported value") \end{code} @@ -784,9 +701,9 @@ lookupSigOccRn mb_names sig (L loc v) \begin{code} rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars) -rnMatchGroup ctxt (MatchGroup ms _) = do - (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt) ms - return (MatchGroup new_ms placeHolderType, ms_fvs) +rnMatchGroup ctxt (MatchGroup ms _) + = do { (new_ms, ms_fvs) <- mapFvRn (rnMatch ctxt) ms + ; return (MatchGroup new_ms placeHolderType, ms_fvs) } rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars) rnMatch ctxt = wrapLocFstM (rnMatch' ctxt) @@ -796,17 +713,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