they may be affected by renaming (which isn't fully worked out yet).
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
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
+ makeMiniFixityEnv, MiniFixityEnv
) where
-#include "HsVersions.h"
-
import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts )
import HsSyn
import RdrHsSyn
import RnHsSyn
import TcRnMonad
-import RnTypes ( rnHsSigType, rnLHsType, rnHsTypeFVs,checkPrecMatch)
-import RnPat (rnPatsAndThen_LocalRightwards, rnPat_LocalRec, rnPat_TopRec,
- NameMaker, localNameMaker, topNameMaker, applyNameMaker,
- patSigErr)
+import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch)
+import RnPat (rnPats, rnBindPat,
+ NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker
+ )
-import RnEnv ( lookupLocatedBndrRn,
- lookupInstDeclBndr, newIPNameRn,
- lookupLocatedSigOccRn, bindPatSigTyVarsFV,
- bindLocalFixities, bindSigTyVarsFV,
- warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
- bindLocatedLocalsFV, bindLocalNames, bindLocalNamesFV,
- bindLocalNamesFV_WithFixities,
- bindLocatedLocalsRn,
- checkDupNames, checkShadowing
- )
+import RnEnv
import DynFlags ( DynFlag(..) )
-import HscTypes (FixItem(..))
import Name
import NameEnv
-import UniqFM
import NameSet
-import PrelNames ( isUnboundName )
import RdrName ( RdrName, rdrNameOcc )
-import SrcLoc ( Located(..), unLoc, noLoc )
+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 Util ( filterOut )
-import Monad ( foldM )
+import Control.Monad
\end{code}
-- ToDo: Put the annotations into the monad, so that they arrive in the proper
\begin{code}
-- for top-level bindings, we need to make top-level names,
-- so we have a different entry point than for local bindings
-rnTopBindsLHS :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
- -- these fixities need to be brought into scope with the names
+rnTopBindsLHS :: MiniFixityEnv
-> HsValBinds RdrName
-> RnM (HsValBindsLR Name RdrName)
-rnTopBindsLHS fix_env binds =
- (uncurry $ rnValBindsLHSFromDoc True) (bindersAndDoc binds) fix_env 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 =
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 emptyUFM b
- let bound_names = map unLoc (collectHsValBinders nl)
- bindLocalNames bound_names $ rnTopBindsRHS bound_names nl
+ do nl <- rnTopBindsLHS emptyFsEnv b
+ let bound_names = collectHsValBinders nl
+ bindLocalNames bound_names $ rnTopBindsRHS (mkNameSet bound_names) nl
rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
-- Return a single HsBindGroup with empty binds and renamed signatures
rnTopBindsBoot (ValBindsIn mbinds sigs)
= do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds)
- ; sigs' <- renameSigs okHsBootSig sigs
+ ; sigs' <- renameSigs Nothing okHsBootSig sigs
; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) }
+rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b)
\end{code}
= rnValBindsAndThen val_binds $ \ val_binds' ->
thing_inside (HsValBinds val_binds')
-rnLocalBindsAndThen (HsIPBinds binds) thing_inside
- = rnIPBinds binds `thenM` \ (binds',fv_binds) ->
- thing_inside (HsIPBinds binds') `thenM` \ (thing, fvs_thing) ->
- returnM (thing, fvs_thing `plusFV` fv_binds)
-
+rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do
+ (binds',fv_binds) <- rnIPBinds binds
+ (thing, fvs_thing) <- thing_inside (HsIPBinds binds')
+ return (thing, fvs_thing `plusFV` fv_binds)
-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) }
+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)
-rnIPBind (IPBind n expr)
- = newIPNameRn n `thenM` \ name ->
- rnLExpr expr `thenM` \ (expr',fvExpr) ->
+rnIPBind :: IPBind RdrName -> RnM (IPBind Name, FreeVars)
+rnIPBind (IPBind n expr) = do
+ name <- newIPNameRn n
+ (expr',fvExpr) <- rnLExpr expr
return (IPBind name expr', fvExpr)
\end{code}
%************************************************************************
\begin{code}
--- wrapper for local binds
--- creates the documentation info and calls the helper below
-rnValBindsLHS :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
- -- these fixities need to be brought into scope with the names
+-- 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
- -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
- -- these fixities need to be brought into scope with the names
- -> 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.
- --
- checkDupNames doc boundNames
- -- Warn about shadowing, but only in source modules
- ifOptM Opt_WarnNameShadowing (checkShadowing 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 False boundNames doc fix_env 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 :: Bool -- top or not
- -> [Located RdrName] -- RdrNames of the LHS (so we don't have to gather them twice)
- -> SDoc -- doc string for dup names and shadowing
- -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
- -- these fixities need to be brought into scope with the names
+rnValBindsLHSFromDoc :: NameMaker
-> HsValBinds RdrName
-> RnM (HsValBindsLR Name RdrName)
-rnValBindsLHSFromDoc topP original_bndrs doc fix_env binds@(ValBindsIn mbinds sigs)
- = do
- -- rename the LHSes
- mbinds' <- mapBagM (rnBindLHS topP doc fix_env) mbinds
- return $ ValBindsIn mbinds' sigs
-
--- assumes the LHS vars are in scope
--- general version used both from the top-level and for local things
+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
--
--- does not bind the local fixity declarations
+-- Does not bind the local fixity declarations
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 binds@(ValBindsIn mbinds sigs)
- = do -- rename the sigs
- sigs' <- rename_sigs 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)
- -- We do the check-sigs after renaming the bindings,
- -- so that we have convenient access to the binders
- check_sigs (okBindSig (duDefs anal_dus)) sigs'
- returnM (valbind', valbind'_dus)
-
--- wrapper for local binds
+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)
+
+-- Wrapper for local binds
--
--- the *client* of this function is responsible for checking for unused binders;
+-- The *client* of this function is responsible for checking for unused binders;
-- 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
+-- The client is also responsible for bringing the fixities into scope
+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
rnValBindsAndThen :: HsValBinds RdrName
-> (HsValBinds Name -> RnM (result, FreeVars))
-> RnM (result, FreeVars)
-rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside =
- let
- (original_bndrs, doc) = bindersAndDoc binds
-
- in 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
-
- -- and bring them (and their fixities) into scope
- bindLocalNamesFV_WithFixities bound_names new_fixities $ do
-
- -- (C) do the RHS and thing inside
- (binds', dus) <- rnValBindsRHS bound_names new_lhs
- (result, result_fvs) <- thing_inside binds'
-
- let
- -- the variables used in the val binds are:
- -- (1) the uses of the binds
+rnValBindsAndThen 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
+ ; (bound_names, new_lhs) <- rnValBindsLHS new_fixities binds
+
+ -- ...and bring them (and their fixities) into scope
+ ; bindLocalNamesFV bound_names $
+ addLocalFixities new_fixities bound_names $ do
+
+ { -- (C) Do the RHS and thing inside
+ (binds', dus) <- rnValBindsRHS (mkNameSet bound_names) new_lhs
+ ; (result, result_fvs) <- thing_inside binds'
+
+ -- Report unused bindings based on the (accurate)
+ -- findUses. E.g.
+ -- let x = x in 3
+ -- should report 'x' unused
+ ; let real_uses = findUses dus result_fvs
+ ; warnUnusedLocalBinds bound_names real_uses
+
+ ; let
+ -- The variables "used" in the val binds are:
+ -- (1) the uses of the binds (allUses)
-- (2) the FVs of the thing-inside
- all_uses = (duUses dus) `plusFV` result_fvs
- -- duUses: It's important to return all the uses. Otherwise consider:
+ all_uses = allUses dus `plusFV` result_fvs
+ -- Note [Unused binding hack]
+ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~
+ -- Note that *in contrast* to the above reporting of
+ -- unused bindings, (1) above uses duUses to return *all*
+ -- the uses, even if the binding is unused. Otherwise consider:
-- x = 3
-- y = let p = x in 'x' -- NB: p not used
-- If we don't "see" the dependency of 'y' on 'x', we may put the
-- bindings in the wrong order, and the type checker will complain
-- that x isn't in scope
+ --
+ -- But note that this means we won't report 'x' as unused,
+ -- whereas we would if we had { x = 3; p = x; y = 'x' }
- -- check for unused binders. note that we only want to do
- -- this for local ValBinds; it gets done elsewhere for
- -- top-level binds (where the scoping is different)
- unused_bndrs = [ b | b <- bound_names, not (b `elemNameSet` all_uses)]
-
- warnUnusedLocalBinds unused_bndrs
+ ; return (result, all_uses) }}
+ -- The bound names are pruned out of all_uses
+ -- by the bindLocalNamesFV call above
- return (result,
- -- the bound names are pruned out of all_uses
- -- by the bindLocalNamesFV call above
- all_uses)
+rnValBindsAndThen bs _ = pprPanic "rnValBindsAndThen" (ppr bs)
-- Process the fixity declarations, making a FastString -> (Located Fixity) map
-- Checks for duplicates, but not that only locally defined things are fixed.
-- Note: for local fixity declarations, duplicates would also be checked in
-- check_sigs below. But we also use this function at the top level.
-makeMiniFixityEnv :: [LFixitySig RdrName]
- -> RnM (UniqFM (Located Fixity)) -- key is the FastString of the OccName
- -- of the fixity declaration it came from
-
-makeMiniFixityEnv decls = foldlM add_one emptyUFM decls
+
+makeMiniFixityEnv :: [LFixitySig RdrName] -> RnM MiniFixityEnv
+
+makeMiniFixityEnv decls = foldlM add_one emptyFsEnv decls
where
add_one env (L loc (FixitySig (L name_loc name) fixity)) = do
{ -- this fixity decl is a duplicate iff
-- the ReaderName's OccName's FastString is already in the env
-- (we only need to check the local fix_env because
-- definitions of non-local will be caught elsewhere)
- let {occ = rdrNameOcc name;
- curKey = occNameFS occ;
- fix_item = L loc fixity};
+ let { fs = occNameFS (rdrNameOcc name)
+ ; fix_item = L loc fixity };
- case lookupUFM env curKey of
- Nothing -> return $ addToUFM env curKey fix_item
+ case lookupFsEnv env fs of
+ 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}
}
-pprFixEnv :: NameEnv FixItem -> SDoc
-pprFixEnv env
- = pprWithCommas (\ (FixItem n f) -> ppr f <+> ppr n)
- (nameEnvElts env)
-
+dupFixityDecl :: SrcSpan -> RdrName -> SDoc
dupFixityDecl loc rdr_name
- = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name),
- ptext SLIT("also at ") <+> ppr loc]
+ = vcat [ptext (sLit "Multiple fixity declarations for") <+> quotes (ppr rdr_name),
+ ptext (sLit "also at ") <+> ppr loc]
---------------------
-- renaming a single bind
-rnBindLHS :: Bool -- top if true; local if false
+rnBindLHS :: NameMaker
-> SDoc
- -> UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind
- -- these fixities need to be brought into scope with the names
-> LHsBind RdrName
-- returns the renamed left-hand side,
-- and the FreeVars *of the LHS*
-- (i.e., any free variables of the pattern)
-> RnM (LHsBindLR Name RdrName)
-rnBindLHS topP doc fix_env (L loc (PatBind { pat_lhs = pat,
- pat_rhs = grhss,
- bind_fvs=bind_fvs,
- pat_rhs_ty=pat_rhs_ty
- }))
+rnBindLHS name_maker _ (L loc (PatBind { pat_lhs = pat,
+ pat_rhs = grhss,
+ pat_rhs_ty=pat_rhs_ty
+ }))
= setSrcSpan loc $ do
-- we don't actually use the FV processing of rnPatsAndThen here
- (pat',pat'_fvs) <- (if topP then rnPat_TopRec else rnPat_LocalRec) fix_env pat
+ (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;
-- when we rename the RHS
pat_rhs_ty = pat_rhs_ty }))
-rnBindLHS topP doc fix_env (L loc (FunBind { fun_id = name@(L nameLoc _),
- fun_infix = inf,
- fun_matches = matches,
- fun_co_fn = fun_co_fn,
- bind_fvs = bind_fvs,
- fun_tick = fun_tick
- }))
- = setSrcSpan loc $ do
- newname <- applyNameMaker (if topP then topNameMaker else localNameMaker) name
- 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
- }))
+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
+ }))
+ = setSrcSpan loc $
+ do { newname <- applyNameMaker name_maker name
+ ; 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
+ })) }
+
+rnBindLHS _ _ b = pprPanic "rnBindLHS" (ppr b)
-- assumes the left-hands-side vars are in scope
rnBind :: (Name -> [Name]) -- Signature tyvar function
-> (FreeVars -> FreeVars) -- Trimming function for rhs free vars
-> LHsBindLR Name RdrName
-> RnM (LHsBind Name, [Name], Uses)
-rnBind sig_fn 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 (PatBind { pat_lhs = pat,
+ pat_rhs = grhss,
+ -- pat fvs were stored here while
+ -- 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 all_fvs = pat_fvs `plusFV` fvs
+ fvs' = trim all_fvs
- ; return (L loc (PatBind { pat_lhs = pat,
- pat_rhs = grhss',
- pat_rhs_ty = placeHolderType,
- bind_fvs = trim fvs }),
- bndrs, pat_fvs `plusFV` 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, 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
+
+ ; 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 (FunBind { fun_id = name,
+ fun_infix = is_infix,
+ fun_matches = matches',
+ bind_fvs = fvs',
+ fun_co_fn = idHsWrapper,
+ fun_tick = Nothing }),
[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 ..]
, bndr <- bndrs ]
get_binds (AcyclicSCC (bind, _, _)) = (NonRecursive, unitBag bind)
- get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,d,u) <- binds_w_dus])
+ get_binds (CyclicSCC binds_w_dus) = (Recursive, listToBag [b | (b,_,_) <- binds_w_dus])
get_du (AcyclicSCC (_, bndrs, uses)) = (Just (mkNameSet bndrs), uses)
get_du (CyclicSCC binds_w_dus) = (Just defs, uses)
-> 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)
-
-rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = inf,
+ = 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 = is_infix,
fun_matches = MatchGroup matches _ }))
- = setSrcSpan loc $
- lookupInstDeclBndr cls name `thenM` \ sel_name ->
- let plain_name = unLoc sel_name in
- -- We use the selector name as the binder
-
- bindSigTyVarsFV (sig_fn plain_name) $
- mapFvRn (rn_match plain_name) matches `thenM` \ (new_matches, fvs) ->
- let
- new_group = MatchGroup new_matches placeHolderType
- in
- checkPrecMatch inf plain_name new_group `thenM_`
- returnM (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 })),
- fvs `addOneFV` plain_name)
- -- The 'fvs' field isn't used for method binds
+ = setSrcSpan loc $ do
+ sel_name <- wrapLocM (lookupInstDeclBndr cls) name
+ let plain_name = unLoc sel_name
+ -- We use the selector name as the binder
+
+ (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 (FunBind {
+ fun_id = sel_name, fun_infix = is_infix,
+ fun_matches = new_group,
+ bind_fvs = fvs, fun_co_fn = idHsWrapper,
+ fun_tick = Nothing })),
+ 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 cls sig_fn gen_tyvars mbind@(L loc (PatBind other_pat _ _ _))
- = addLocErr mbind methodBindErr `thenM_`
- returnM (emptyBag, emptyFVs)
+rnMethodBind _ _ _ (L loc bind@(PatBind {})) = do
+ addErrAt loc (methodBindErr bind)
+ return (emptyBag, emptyFVs)
+
+rnMethodBind _ _ _ b = pprPanic "rnMethodBind" (ppr b)
\end{code}
\begin{enumerate}
\item more than one sig for one thing;
\item signatures given for things not bound here;
-\item with suitably flaggery, that all top-level things have type signatures.
\end{enumerate}
%
At the moment we don't gather free-var info from the types in
signatures. We'd only need this if we wanted to report unused tyvars.
\begin{code}
-renameSigs :: (LSig Name -> Bool) -> [LSig RdrName] -> RnM [LSig Name]
+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
+ -> [LSig RdrName]
+ -> RnM [LSig Name]
-- Renames the signatures and performs error checks
-renameSigs ok_sig sigs
- = do { sigs' <- rename_sigs sigs
- ; check_sigs ok_sig sigs'
- ; return sigs' }
-
-----------------------
-rename_sigs :: [LSig RdrName] -> RnM [LSig Name]
-rename_sigs sigs = mappM (wrapLocM renameSig) sigs
+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' }
----------------------
-check_sigs :: (LSig Name -> Bool) -> [LSig Name] -> RnM ()
--- Used for class and instance decls, as well as regular bindings
-check_sigs ok_sig sigs
- -- Check for (a) duplicate signatures
- -- (b) signatures for things not in this group
- = do {
- traceRn (text "SIGS" <+> ppr sigs)
- ; mappM_ unknownSigErr (filter (not . ok_sig) sigs')
- ; mappM_ dupSigDeclErr (findDupsEq eqHsSig sigs') }
- where
- -- Don't complain about an unbound name again
- sigs' = filterOut bad_name sigs
- bad_name sig = case sigName sig of
- Just n -> isUnboundName n
- other -> False
-
--- We use lookupLocatedSigOccRn in the signatures, which is a little bit unsatisfactory
+-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory
-- because this won't work for:
-- instance Foo T where
-- {-# INLINE op #-}
-- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.)
-- Doesn't seem worth much trouble to sort this.
-renameSig :: Sig RdrName -> RnM (Sig Name)
--- FixitSig is renamed elsewhere.
-renameSig (TypeSig v ty)
- = lookupLocatedSigOccRn v `thenM` \ new_v ->
- rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty ->
- returnM (TypeSig new_v new_ty)
-
-renameSig (SpecInstSig ty)
- = rnLHsType (text "A SPECIALISE instance pragma") ty `thenM` \ new_ty ->
- returnM (SpecInstSig new_ty)
-
-renameSig (SpecSig v ty inl)
- = lookupLocatedSigOccRn v `thenM` \ new_v ->
- rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty ->
- returnM (SpecSig new_v new_ty inl)
-
-renameSig (InlineSig v s)
- = lookupLocatedSigOccRn v `thenM` \ new_v ->
- returnM (InlineSig new_v s)
-
-renameSig (FixSig (FixitySig v f))
- = lookupLocatedSigOccRn v `thenM` \ new_v ->
- returnM (FixSig (FixitySig new_v f))
+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
+ ; return (TypeSig new_v new_ty) }
+
+renameSig _ (SpecInstSig ty)
+ = do { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty
+ ; return (SpecInstSig new_ty) }
+
+renameSig mb_names sig@(SpecSig v ty inl)
+ = do { new_v <- lookupSigOccRn mb_names sig v
+ ; new_ty <- rnHsSigType (quotes (ppr v)) ty
+ ; return (SpecSig new_v new_ty inl) }
+
+renameSig mb_names sig@(InlineSig v s)
+ = do { new_v <- lookupSigOccRn mb_names sig v
+ ; return (InlineSig new_v s) }
+
+renameSig mb_names sig@(FixSig (FixitySig v f))
+ = do { new_v <- lookupSigOccRn mb_names sig v
+ ; return (FixSig (FixitySig new_v f)) }
\end{code}
-************************************************************************
-* *
+%************************************************************************
+%* *
\subsection{Match}
-* *
-************************************************************************
+%* *
+%************************************************************************
\begin{code}
rnMatchGroup :: HsMatchContext Name -> MatchGroup RdrName -> RnM (MatchGroup Name, FreeVars)
-rnMatchGroup ctxt (MatchGroup ms _)
- = mapFvRn (rnMatch ctxt) ms `thenM` \ (new_ms, ms_fvs) ->
- returnM (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)
+rnMatch' :: HsMatchContext Name -> Match RdrName -> RnM (Match Name, FreeVars)
rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss)
- =
- -- Deal with the rhs type signature
- bindPatSigTyVarsFV rhs_sig_tys $
- doptM Opt_PatternSignatures `thenM` \ opt_PatternSignatures ->
- (case maybe_rhs_sig of
- Nothing -> returnM (Nothing, emptyFVs)
- Just ty | opt_PatternSignatures -> rnHsTypeFVs doc_sig ty `thenM` \ (ty', ty_fvs) ->
- returnM (Just ty', ty_fvs)
- | otherwise -> addLocErr ty patSigErr `thenM_`
- returnM (Nothing, emptyFVs)
- ) `thenM` \ (maybe_rhs_sig', ty_fvs) ->
-
- -- Now the main event
- -- note that there are no local ficity decls for matches
- rnPatsAndThen_LocalRightwards ctxt pats $ \ (pats',_) ->
- rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) ->
-
- returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs)
+ = do { -- Result type signatures are no longer supported
+ case maybe_rhs_sig of
+ Nothing -> return ()
+ Just (L loc ty) -> addErrAt loc (resSigErr ctxt match ty)
+
+ -- Now the main event
+ -- note that there are no local ficity decls for matches
+ ; 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
- rhs_sig_tys = case maybe_rhs_sig of
- Nothing -> []
- Just ty -> [ty]
- doc_sig = text "In a result type-signature"
+
+resSigErr :: HsMatchContext Name -> Match RdrName -> HsType RdrName -> SDoc
+resSigErr ctxt match ty
+ = vcat [ ptext (sLit "Illegal result type signature") <+> quotes (ppr ty)
+ , nest 2 $ ptext (sLit "Result signatures are no longer supported in pattern matches")
+ , pprMatchInCtxt ctxt match ]
\end{code}
rnGRHSs :: HsMatchContext Name -> GRHSs RdrName -> RnM (GRHSs Name, FreeVars)
rnGRHSs ctxt (GRHSs grhss binds)
- = rnLocalBindsAndThen binds $ \ binds' ->
- mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) ->
- returnM (GRHSs grhss' binds', fvGRHSs)
+ = rnLocalBindsAndThen binds $ \ binds' -> do
+ (grhss', fvGRHSs) <- mapFvRn (rnGRHS ctxt) grhss
+ return (GRHSs grhss' binds', fvGRHSs)
rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars)
rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt)
+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 $
rnLExpr rhs
- ; checkM (pattern_guards_allowed || is_standard_guard guards')
+ ; unless (pattern_guards_allowed || is_standard_guard guards')
(addWarn (nonStdGuardErr guards'))
; return (GRHS guards' rhs', fvs) }
-- Glasgow extension
is_standard_guard [] = True
is_standard_guard [L _ (ExprStmt _ _ _)] = True
- is_standard_guard other = False
+ is_standard_guard _ = False
\end{code}
%************************************************************************
%************************************************************************
\begin{code}
+dupSigDeclErr :: [LSig RdrName] -> RnM ()
dupSigDeclErr sigs@(L loc sig : _)
= addErrAt loc $
- vcat [ptext SLIT("Duplicate") <+> what_it_is <> colon,
+ vcat [ptext (sLit "Duplicate") <+> what_it_is <> colon,
nest 2 (vcat (map ppr_sig sigs))]
where
what_it_is = hsSigDoc sig
ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig
+dupSigDeclErr [] = panic "dupSigDeclErr"
+unknownSigErr :: LSig RdrName -> RnM ()
unknownSigErr (L loc sig)
- = do { mod <- getModule
- ; addErrAt loc $
- vcat [sep [ptext SLIT("Misplaced") <+> what_it_is <> colon, ppr sig],
- extra_stuff mod sig] }
- where
- what_it_is = hsSigDoc sig
- extra_stuff mod (TypeSig (L _ n) _)
- | nameIsLocalOrFrom mod n
- = ptext SLIT("The type signature must be given where")
- <+> quotes (ppr n) <+> ptext SLIT("is declared")
- | otherwise
- = ptext SLIT("You cannot give a type signature for an imported value")
-
- extra_stuff mod other = empty
+ = addErrAt loc $
+ sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig]
+methodBindErr :: HsBindLR RdrName RdrName -> SDoc
methodBindErr mbind
- = hang (ptext SLIT("Pattern bindings (except simple variables) not allowed in instance declarations"))
+ = hang (ptext (sLit "Pattern bindings (except simple variables) not allowed in instance declarations"))
2 (ppr mbind)
+bindsInHsBootFile :: LHsBindsLR Name RdrName -> SDoc
bindsInHsBootFile mbinds
- = hang (ptext SLIT("Bindings in hs-boot files are not allowed"))
+ = hang (ptext (sLit "Bindings in hs-boot files are not allowed"))
2 (ppr mbinds)
+nonStdGuardErr :: [LStmtLR Name Name] -> SDoc
nonStdGuardErr guards
- = hang (ptext SLIT("accepting non-standard pattern guards (use -XPatternGuards to suppress this message)"))
+ = hang (ptext (sLit "accepting non-standard pattern guards (use -XPatternGuards to suppress this message)"))
4 (interpp'SP guards)
\end{code}