X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnBinds.lhs;h=1d17c7b4cc85329819ce38598cf698b4be37b3f8;hb=e4db45612e3efa59251239e1e0b8a0440783b966;hp=628f67e9d91ce9456de01d39f3514d53f5eef358;hpb=e8687b3cb725bcc7d6cd38aa9bd71b2ba5a763f1;p=ghc-hetmet.git diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 628f67e..1d17c7b 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -20,11 +20,9 @@ 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" - import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) import HsSyn @@ -36,21 +34,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 +49,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 +164,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 +188,7 @@ rnTopBindsRHS bound_names binds = rnTopBinds :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) rnTopBinds b = - do nl <- rnTopBindsLHS emptyUFM b + do nl <- rnTopBindsLHS emptyFsEnv b let bound_names = map unLoc (collectHsValBinders nl) bindLocalNames bound_names $ rnTopBindsRHS bound_names nl @@ -261,8 +250,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 +261,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 +318,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 +331,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 +353,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,26 +408,24 @@ 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') + addLocErr (L name_loc name) (dupFixityDecl loc') ; return env} } @@ -437,8 +435,8 @@ pprFixEnv env (nameEnvElts env) 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] --------------------- @@ -832,7 +830,7 @@ rnGRHS' ctxt (GRHS guards rhs) \begin{code} 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 @@ -841,28 +839,28 @@ dupSigDeclErr sigs@(L loc sig : _) unknownSigErr (L loc sig) = do { mod <- getModule ; addErrAt loc $ - vcat [sep [ptext SLIT("Misplaced") <+> what_it_is <> colon, ppr sig], + 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") + = 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") + = ptext (sLit "You cannot give a type signature for an imported value") extra_stuff mod other = empty 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 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 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}