X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=compiler%2Frename%2FRnBinds.lhs;h=7c7046e6d1d8d2940738adec4be190071b576285;hb=a27c5f77da8b3b3f00f9902b69a504460f234e8c;hp=628f67e9d91ce9456de01d39f3514d53f5eef358;hpb=e8687b3cb725bcc7d6cd38aa9bd71b2ba5a763f1;p=ghc-hetmet.git diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 628f67e..7c7046e 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -20,7 +20,7 @@ module RnBinds (rnTopBinds, rnTopBindsLHS, rnTopBindsRHS, -- use these for top-l rnLocalBindsAndThen, rnValBindsLHS, rnValBindsRHS, -- or these for local bindings rnMethodBinds, renameSigs, mkSigTvFn, rnMatchGroup, rnGRHSs, - makeMiniFixityEnv + makeMiniFixityEnv, MiniFixityEnv ) where #include "HsVersions.h" @@ -36,21 +36,12 @@ import RnPat (rnPatsAndThen_LocalRightwards, rnBindPat, NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker, patSigErr) -import RnEnv ( lookupLocatedBndrRn, - lookupInstDeclBndr, newIPNameRn, - lookupLocatedSigOccRn, bindPatSigTyVarsFV, - bindLocalFixities, bindSigTyVarsFV, - warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, - bindLocatedLocalsFV, bindLocalNames, bindLocalNamesFV, - bindLocalNamesFV_WithFixities, - bindLocatedLocalsRn, - checkDupAndShadowedRdrNames - ) +import RnEnv import DynFlags ( DynFlag(..) ) import HscTypes (FixItem(..)) import Name import NameEnv -import UniqFM +import LazyUniqFM import NameSet import PrelNames ( isUnboundName ) import RdrName ( RdrName, rdrNameOcc ) @@ -60,6 +51,7 @@ import BasicTypes ( RecFlag(..) ) import Digraph ( SCC(..), stronglyConnComp ) import Bag import Outputable +import FastString import Maybes ( orElse ) import Util ( filterOut ) import Monad ( foldM, unless ) @@ -174,8 +166,7 @@ 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 = @@ -199,7 +190,7 @@ rnTopBindsRHS bound_names binds = rnTopBinds :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) rnTopBinds b = - do nl <- rnTopBindsLHS emptyUFM b + do nl <- rnTopBindsLHS emptyOccEnv b let bound_names = map unLoc (collectHsValBinders nl) bindLocalNames bound_names $ rnTopBindsRHS bound_names nl @@ -261,8 +252,7 @@ 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 +rnValBindsLHS :: MiniFixityEnv -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) rnValBindsLHS fix_env binds = @@ -273,8 +263,7 @@ rnValBindsLHS fix_env binds = -- 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 + -> MiniFixityEnv -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) @@ -331,6 +320,8 @@ rnValBindsRHSGen :: (FreeVars -> FreeVars) -- for trimming free var sets rnValBindsRHSGen trim bound_names binds@(ValBindsIn mbinds sigs) = do -- rename the sigs + env <- getGblEnv + traceRn (ptext SLIT("Rename sigs") <+> ppr (tcg_rdr_env env)) sigs' <- rename_sigs sigs -- rename the RHSes binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds @@ -342,12 +333,12 @@ rnValBindsRHSGen trim bound_names binds@(ValBindsIn mbinds sigs) = do check_sigs (okBindSig (duDefs anal_dus)) sigs' return (valbind', valbind'_dus) --- wrapper for local binds +-- 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 +-- 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) @@ -364,42 +355,53 @@ rnValBindsRHS bound_names binds = rnValBindsAndThen :: HsValBinds RdrName -> (HsValBinds Name -> RnM (result, FreeVars)) -> RnM (result, FreeVars) -rnValBindsAndThen binds@(ValBindsIn _ sigs) thing_inside = - let - (original_bndrs, doc) = bindersAndDoc binds +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] - 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 - -- (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 - -- 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' - -- (C) do the RHS and thing inside - (binds', dus) <- rnValBindsRHS 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 + ; let + -- The variables "used" in the val binds are: + -- (1) the uses of the binds (duUses) -- (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 = duUses 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, - -- the bound names are pruned out of all_uses - -- by the bindLocalNamesFV call above - all_uses) + ; return (result, all_uses) }} + -- The bound names are pruned out of all_uses + -- by the bindLocalNamesFV call above + -- Process the fixity declarations, making a FastString -> (Located Fixity) map @@ -408,11 +410,10 @@ 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 emptyOccEnv decls where add_one env (L loc (FixitySig (L name_loc name) fixity)) = do { -- this fixity decl is a duplicate iff @@ -420,14 +421,13 @@ makeMiniFixityEnv decls = foldlM add_one emptyUFM decls -- (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}; - case lookupUFM env curKey of - Nothing -> return $ addToUFM env curKey fix_item + case lookupOccEnv env occ of + Nothing -> return $ extendOccEnv env occ fix_item Just (L loc' _) -> do { setSrcSpan loc $ - addLocErr (L name_loc name) (dupFixityDecl loc') + addLocErr (L name_loc name) (dupFixityDecl loc') ; return env} }