X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnBinds.lhs;h=286e3f28158f7bf619121a65cfec9abc80d0a15f;hp=628f67e9d91ce9456de01d39f3514d53f5eef358;hb=224ef3094189bc9a33f23285b5dccbffdd8d7de0;hpb=e8687b3cb725bcc7d6cd38aa9bd71b2ba5a763f1 diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 628f67e..286e3f2 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -9,60 +9,47 @@ type-synonym declarations; those cannot be done at this stage because 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 +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 -#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, rnBindPat, - NameMaker, localRecNameMaker, topRecNameMaker, 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, - checkDupAndShadowedRdrNames - ) -import DynFlags ( DynFlag(..) ) -import HscTypes (FixItem(..)) +import RnEnv +import DynFlags 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, unless ) +import Control.Monad \end{code} -- ToDo: Put the annotations into the monad, so that they arrive in the proper @@ -174,34 +161,33 @@ it expects the global environment to contain bindings for the binders \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 (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 emptyUFM 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) @@ -209,12 +195,12 @@ 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} - %********************************************************* %* * HsLocalBinds @@ -232,7 +218,7 @@ rnLocalBindsAndThen EmptyLocalBinds thing_inside = 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 @@ -240,11 +226,12 @@ rnLocalBindsAndThen (HsIPBinds binds) thing_inside = do (thing, fvs_thing) <- thing_inside (HsIPBinds binds') return (thing, fvs_thing `plusFV` fv_binds) - +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 name <- newIPNameRn n (expr',fvExpr) <- rnLExpr expr @@ -259,147 +246,148 @@ rnIPBind (IPBind n expr) = do %************************************************************************ \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 - -> 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. - 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 binds@(ValBindsIn mbinds sigs) = do - -- rename the LHSes - mbinds' <- mapBagM (rnBindLHS topP doc) mbinds - return $ ValBindsIn mbinds' sigs - --- assumes the LHS vars are in scope --- general version used both from the top-level and for local things +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 +-- Does not bind the local fixity declarations +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 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' - return (valbind', valbind'_dus) - --- wrapper for local binds + -> 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 -- --- 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 - -> 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 - +-- The client is also responsible for bringing the fixities into scope +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 = - 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 $ - warnUnusedLocalBinds bound_names $ 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 +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 + ; (bound_names, new_lhs) <- rnLocalValBindsLHS 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) <- rnLocalValBindsRHS (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 + -- 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 (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' } + + ; 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) +rnLocalValBindsAndThen bs _ = pprPanic "rnLocalValBindsAndThen" (ppr bs) -- Process the fixity declarations, making a FastString -> (Located Fixity) map @@ -408,37 +396,31 @@ rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside = -- 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] --------------------- @@ -452,93 +434,82 @@ rnBindLHS :: NameMaker -- (i.e., any free variables of the pattern) -> RnM (LHsBindLR Name RdrName) -rnBindLHS name_maker doc (L loc (PatBind { pat_lhs = pat, - pat_rhs = grhss, - bind_fvs=bind_fvs, - 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 doc (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 - })) + 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) -- 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 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) @@ -547,7 +518,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 ..] @@ -560,7 +531,7 @@ depAnalBinds binds_w_dus , 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) @@ -620,48 +591,53 @@ 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) - -rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = inf, - fun_matches = MatchGroup matches _ })) + = 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 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 cls sig_fn gen_tyvars mbind@(L loc (PatBind other_pat _ _ _)) = do - addLocErr mbind methodBindErr +rnMethodBind _ _ _ (L loc bind@(PatBind {})) = do + addErrAt loc (methodBindErr bind) return (emptyBag, emptyFVs) + +rnMethodBind _ _ _ b = pprPanic "rnMethodBind" (ppr b) \end{code} @@ -676,41 +652,32 @@ rnMethodBind cls sig_fn gen_tyvars mbind@(L loc (PatBind other_pat _ _ _)) = do \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 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 ok_sig sigs - = do { sigs' <- rename_sigs sigs - ; check_sigs ok_sig sigs' - ; return sigs' } +renameSigs mb_names ok_sig 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 ----------------------- -rename_sigs :: [LSig RdrName] -> RnM [LSig Name] -rename_sigs sigs = mapM (wrapLocM renameSig) sigs + ; sigs' <- mapM (wrapLocM (renameSig mb_names)) 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 = do - -- Check for (a) duplicate signatures - -- (b) signatures for things not in this group = do - traceRn (text "SIGS" <+> ppr sigs) - mapM_ unknownSigErr (filter (not . ok_sig) sigs') - mapM_ 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 + ; let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs' + ; mapM_ misplacedSigErr bad_sigs -- Misplaced --- We use lookupLocatedSigOccRn in the signatures, which is a little bit unsatisfactory + ; return good_sigs } + +---------------------- +-- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory -- because this won't work for: -- instance Foo T where -- {-# INLINE op #-} @@ -719,72 +686,75 @@ check_sigs ok_sig sigs = do -- 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) = do - new_v <- lookupLocatedSigOccRn 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 (SpecSig v ty inl) = do - new_v <- lookupLocatedSigOccRn v - new_ty <- rnHsSigType (quotes (ppr v)) ty - return (SpecSig new_v new_ty inl) - -renameSig (InlineSig v s) = do - new_v <- lookupLocatedSigOccRn v - return (InlineSig new_v s) - -renameSig (FixSig (FixitySig v f)) = do - new_v <- lookupLocatedSigOccRn v - return (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) } + +-- {-# 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 <- 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@(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 _) = 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) +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 $ do - opt_PatternSignatures <- doptM Opt_PatternSignatures - (maybe_rhs_sig', ty_fvs) <- - case maybe_rhs_sig of - Nothing -> return (Nothing, emptyFVs) - Just ty | opt_PatternSignatures -> do (ty', ty_fvs) <- rnHsTypeFVs doc_sig ty - return (Just ty', ty_fvs) - | otherwise -> do addLocErr ty patSigErr - return (Nothing, emptyFVs) - - -- Now the main event - -- note that there are no local ficity decls for matches - rnPatsAndThen_LocalRightwards ctxt pats $ \ pats' -> do - (grhss', grhss_fvs) <- rnGRHSs ctxt grhss - - return (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} @@ -805,9 +775,10 @@ rnGRHSs ctxt (GRHSs grhss binds) 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 $ + = do { pattern_guards_allowed <- xoptM Opt_PatternGuards + ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $ \ _ -> rnLExpr rhs ; unless (pattern_guards_allowed || is_standard_guard guards') @@ -820,7 +791,7 @@ rnGRHS' ctxt (GRHS guards rhs) -- Glasgow extension is_standard_guard [] = True is_standard_guard [L _ (ExprStmt _ _ _)] = True - is_standard_guard other = False + is_standard_guard _ = False \end{code} %************************************************************************ @@ -830,39 +801,33 @@ rnGRHS' ctxt (GRHS guards rhs) %************************************************************************ \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 (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 +misplacedSigErr :: LSig Name -> RnM () +misplacedSigErr (L loc sig) + = 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}