they may be affected by renaming (which isn't fully worked out yet).
\begin{code}
-module RnBinds (rnTopBinds, rnTopBindsLHS, rnTopBindsRHS, -- use these for top-level bindings
- rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS, -- or these for local bindings
- rnMethodBinds, renameSigs, mkSigTvFn,
- rnMatchGroup, rnGRHSs,
- makeMiniFixityEnv, MiniFixityEnv
+module RnBinds (
+ -- Renaming top-level bindings
+ rnTopBinds, rnTopBindsLHS, rnTopBindsRHS,
+
+ -- Renaming local bindings
+ rnLocalBindsAndThen, rnLocalValBindsLHS, rnLocalValBindsRHS,
+
+ -- Other bindings
+ rnMethodBinds, renameSigs, mkSigTvFn,
+ rnMatchGroup, rnGRHSs,
+ makeMiniFixityEnv, MiniFixityEnv,
+ misplacedSigErr
) where
import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
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
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
rnTopBindsLHS :: MiniFixityEnv
-> HsValBinds RdrName
-> RnM (HsValBindsLR Name RdrName)
-rnTopBindsLHS fix_env binds =
- (uncurry $ rnValBindsLHSFromDoc (topRecNameMaker fix_env)) (bindersAndDoc binds) binds
+rnTopBindsLHS fix_env binds
+ = rnValBindsLHS (topRecNameMaker fix_env) binds
-rnTopBindsRHS :: [Name] -- the names bound by these binds
- -> HsValBindsLR Name RdrName
+rnTopBindsRHS :: HsValBindsLR Name RdrName
-> RnM (HsValBinds Name, DefUses)
-rnTopBindsRHS bound_names binds =
- do { is_boot <- tcIsHsBoot
+rnTopBindsRHS binds
+ = do { is_boot <- tcIsHsBoot
; if is_boot
then rnTopBindsBoot binds
- else rnValBindsRHSGen (\x -> x) -- don't trim free vars
- bound_names binds }
-
+ else rnValBindsRHS noTrimFVs -- don't trim free vars
+ Nothing -- Allow SPEC prags for imports
+ 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
+rnTopBinds b
+ = do { nl <- rnTopBindsLHS emptyFsEnv b
+ ; let bound_names = collectHsValBinders nl
+ ; bindLocalNames bound_names $
+ rnValBindsRHS noTrimFVs (Just (mkNameSet bound_names)) nl }
rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
\end{code}
-
%*********************************************************
%* *
HsLocalBinds
= thing_inside EmptyLocalBinds
rnLocalBindsAndThen (HsValBinds val_binds) thing_inside
- = rnValBindsAndThen val_binds $ \ val_binds' ->
+ = rnLocalValBindsAndThen val_binds $ \ val_binds' ->
thing_inside (HsValBinds val_binds')
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
%************************************************************************
\begin{code}
--- wrapper for local binds
--- creates the documentation info and calls the helper below
-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)
+-- Renaming local binding gropus
+-- Does duplicate/shadow check
+rnLocalValBindsLHS :: MiniFixityEnv
+ -> HsValBinds RdrName
+ -> RnM ([Name], HsValBindsLR Name RdrName)
+rnLocalValBindsLHS 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' <- rnValBindsLHS (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)
+rnValBindsLHS :: NameMaker
+ -> HsValBinds RdrName
+ -> RnM (HsValBindsLR Name RdrName)
+rnValBindsLHS 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
+
+rnValBindsLHS _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b)
-- General version used both from the top-level and for local things
-- Assumes the LHS vars are in scope
--
-- Does not bind the local fixity declarations
-rnValBindsRHSGen :: (FreeVars -> FreeVars) -- for trimming free var sets
+rnValBindsRHS :: (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
- -> 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 _ _ b = pprPanic "rnValBindsRHSGen" (ppr b)
+ -> Maybe NameSet -- Names bound by the LHSes
+ -- Nothing if expect sigs for imports
+ -> HsValBindsLR Name RdrName
+ -> RnM (HsValBinds Name, DefUses)
+
+rnValBindsRHS trim mb_bound_names (ValBindsIn mbinds sigs)
+ = do { sigs' <- renameSigs mb_bound_names okBindSig sigs
+ ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds
+ ; case depAnalBinds binds_w_dus of
+ (anal_binds, anal_dus) -> return (valbind', valbind'_dus)
+ where
+ valbind' = ValBindsOut anal_binds sigs'
+ valbind'_dus = anal_dus `plusDU` usesOnly (hsSigsFVs sigs')
+ -- Put the sig uses *after* the bindings
+ -- so that the binders are removed from
+ -- the uses in the sigs
+ }
+
+rnValBindsRHS _ _ b = pprPanic "rnValBindsRHS" (ppr b)
+
+noTrimFVs :: FreeVars -> FreeVars
+noTrimFVs fvs = fvs
-- Wrapper for local binds
--
-- 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
- -> 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
-
+rnLocalValBindsRHS :: NameSet -- names bound by the LHSes
+ -> HsValBindsLR Name RdrName
+ -> RnM (HsValBinds Name, DefUses)
+rnLocalValBindsRHS bound_names binds
+ = rnValBindsRHS trim (Just 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
--
-- here there are no local fixity decls passed in;
-- the local fixity decls come from the ValBinds sigs
-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]
+rnLocalValBindsAndThen :: HsValBinds RdrName
+ -> (HsValBinds Name -> RnM (result, FreeVars))
+ -> RnM (result, FreeVars)
+rnLocalValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside
+ = 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) <- rnLocalValBindsLHS 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) <- rnLocalValBindsRHS (mkNameSet bound_names) new_lhs
; (result, result_fvs) <- thing_inside binds'
-- Report unused bindings based on the (accurate)
-- let x = x in 3
-- should report 'x' unused
; let real_uses = findUses dus result_fvs
- ; warnUnusedLocalBinds bound_names real_uses
+ -- Insert fake uses for variables introduced implicitly by wildcards (#4404)
+ implicit_uses = hsValBindsImplicits binds'
+ ; warnUnusedLocalBinds bound_names (real_uses `unionNameSets` implicit_uses)
; 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
-- The bound names are pruned out of all_uses
-- by the bindLocalNamesFV call above
-rnValBindsAndThen bs _ = pprPanic "rnValBindsAndThen" (ppr bs)
+rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs)
-- Process the fixity declarations, making a FastString -> (Located Fixity) map
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}
}
-- (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)
-> (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 $
+ = 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
+
+ ; when is_infix $ checkPrecMatch plain_name matches'
- ; checkPrecMatch inf 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 = trim fvs,
- fun_co_fn = idHsWrapper,
- fun_tick = Nothing }),
+ 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)
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 ..]
-> 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)
\begin{code}
renameSigs :: Maybe NameSet -- If (Just ns) complain if the sig isn't for one of ns
- -> (Sig RdrName -> Bool) -- Complain about the wrong kind of signature if this is False
+ -> (Sig Name -> Bool) -- Complain about the wrong kind of signature if this is False
-> [LSig RdrName]
-> RnM [LSig Name]
-- Renames the signatures and performs error checks
renameSigs mb_names ok_sig sigs
- = do { let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs
- ; mapM_ unknownSigErr bad_sigs -- Misplaced
- ; mapM_ dupSigDeclErr (findDupsEq eqHsSig sigs) -- Duplicate
- ; sigs' <- mapM (wrapLocM (renameSig mb_names)) good_sigs
- ; return sigs' }
+ = do { mapM_ dupSigDeclErr (findDupsEq eqHsSig sigs) -- Duplicate
+ -- Check for duplicates on RdrName version,
+ -- because renamed version has unboundName for
+ -- not-in-scope binders, which gives bogus dup-sig errors
+
+ ; sigs' <- mapM (wrapLocM (renameSig mb_names)) sigs
+
+ ; let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs'
+ ; mapM_ misplacedSigErr bad_sigs -- Misplaced
+
+ ; return good_sigs }
----------------------
-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
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
= do { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty
; return (SpecInstSig new_ty) }
+-- {-# SPECIALISE #-} pragmas can refer to imported Ids
+-- so, in the top-level case (when mb_names is Nothing)
+-- we use lookupOccRn. If there's both an imported and a local 'f'
+-- then the SPECIALISE pragma is ambiguous, unlike all other signatures
renameSig mb_names sig@(SpecSig v ty inl)
- = do { new_v <- lookupSigOccRn mb_names sig v
+ = do { new_v <- case mb_names of
+ Just {} -> lookupSigOccRn mb_names sig v
+ Nothing -> lookupLocatedOccRn v
; new_ty <- rnHsSigType (quotes (ppr v)) ty
; return (SpecSig new_v new_ty inl) }
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}
\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)
= 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
rnGRHS' :: HsMatchContext Name -> GRHS RdrName -> RnM (GRHS Name, FreeVars)
rnGRHS' ctxt (GRHS guards rhs)
- = do { pattern_guards_allowed <- doptM Opt_PatternGuards
- ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $
+ = do { pattern_guards_allowed <- xoptM Opt_PatternGuards
+ ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $ \ _ ->
rnLExpr rhs
; unless (pattern_guards_allowed || is_standard_guard guards')
ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig
dupSigDeclErr [] = panic "dupSigDeclErr"
-unknownSigErr :: LSig RdrName -> RnM ()
-unknownSigErr (L loc sig)
+misplacedSigErr :: LSig Name -> RnM ()
+misplacedSigErr (L loc sig)
= addErrAt loc $
sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig]
projects / ghc-hetmet.git / blobdiff