X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnBinds.lhs;h=08b54c552218f66d65506aa55242ef441e0a63cc;hb=479f9fcbe056864fd5daff01d0e00d4a432b3658;hp=cae7ef0236f0959140464b98e532eeb7ec024607;hpb=6a05ec5ef5373f61b7f9f5bdc344483417fa801b;p=ghc-hetmet.git diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index cae7ef0..08b54c5 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -9,22 +9,13 @@ 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 + makeMiniFixityEnv, MiniFixityEnv ) where -#include "HsVersions.h" - import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) import HsSyn @@ -32,37 +23,27 @@ import RdrHsSyn import RnHsSyn import TcRnMonad import RnTypes ( rnHsSigType, rnLHsType, rnHsTypeFVs,checkPrecMatch) -import RnPat (rnPatsAndThen_LocalRightwards, rnPat_LocalRec, rnPat_TopRec, - NameMaker, localNameMaker, topNameMaker, applyNameMaker, +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, - 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 Bag import Outputable +import FastString import Maybes ( orElse ) import Util ( filterOut ) -import Monad ( foldM ) +import Monad ( foldM, unless ) \end{code} -- ToDo: Put the annotations into the monad, so that they arrive in the proper @@ -174,12 +155,11 @@ 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 True) (bindersAndDoc binds) fix_env binds + (uncurry $ rnValBindsLHSFromDoc (topRecNameMaker fix_env)) (bindersAndDoc binds) binds rnTopBindsRHS :: [Name] -- the names bound by these binds -> HsValBindsLR Name RdrName @@ -199,7 +179,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 @@ -211,6 +191,7 @@ rnTopBindsBoot (ValBindsIn mbinds sigs) = do { checkErr (isEmptyLHsBinds mbinds) (bindsInHsBootFile mbinds) ; sigs' <- renameSigs okHsBootSig sigs ; return (ValBindsOut [] sigs', usesOnly (hsSigsFVs sigs')) } +rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b) \end{code} @@ -235,19 +216,20 @@ rnLocalBindsAndThen (HsValBinds val_binds) thing_inside = 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} @@ -261,8 +243,7 @@ rnIPBind (IPBind n expr) \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 +254,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) @@ -282,10 +262,7 @@ 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) + 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. @@ -297,7 +274,7 @@ rnValBindsLHSFromDoc_Local boundNames doc fix_env binds = do -- import A(f) -- g = let f = ... in f -- should. - rnValBindsLHSFromDoc False boundNames doc fix_env binds + rnValBindsLHSFromDoc (localRecNameMaker fix_env) boundNames doc binds bindersAndDoc :: HsValBinds RdrName -> ([Located RdrName], SDoc) bindersAndDoc binds = @@ -311,18 +288,16 @@ bindersAndDoc 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 +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 - -> 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 topP original_bndrs doc fix_env binds@(ValBindsIn mbinds sigs) - = do +rnValBindsLHSFromDoc topP _original_bndrs doc (ValBindsIn mbinds sigs) = do -- rename the LHSes - mbinds' <- mapBagM (rnBindLHS topP doc fix_env) mbinds + mbinds' <- mapBagM (rnBindLHS topP doc) mbinds return $ ValBindsIn mbinds' sigs +rnValBindsLHSFromDoc _ _ _ b = pprPanic "rnValBindsLHSFromDoc" (ppr b) -- assumes the LHS vars are in scope -- general version used both from the top-level and for local things @@ -335,8 +310,10 @@ rnValBindsRHSGen :: (FreeVars -> FreeVars) -- for trimming free var sets -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -rnValBindsRHSGen trim bound_names binds@(ValBindsIn mbinds sigs) - = do -- rename the sigs +rnValBindsRHSGen trim _bound_names (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 @@ -346,14 +323,16 @@ rnValBindsRHSGen trim bound_names binds@(ValBindsIn mbinds sigs) -- 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) + return (valbind', valbind'_dus) --- wrapper for local binds +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 +-- 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) @@ -370,48 +349,54 @@ 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 - in do - -- (A) create the local fixity environment - new_fixities <- makeMiniFixityEnv [L loc sig | L loc (FixSig sig) <- sigs] + -- (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 $ 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' - let - -- the variables used in the val binds are: - -- (1) the uses of the 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 (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' } - -- 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 @@ -420,60 +405,51 @@ 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} } -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; @@ -484,35 +460,38 @@ rnBindLHS topP doc fix_env (L loc (PatBind { pat_lhs = pat, -- 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, _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 + })) } + +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 + -- processing the LHS + bind_fvs=pat_fvs })) = setSrcSpan loc $ do {let bndrs = collectPatBinders pat @@ -551,6 +530,8 @@ rnBind sig_fn fun_tick = Nothing }), [plain_name], fvs) } + +rnBind _ _ b = pprPanic "rnBind" (ppr b) --------------------- depAnalBinds :: Bag (LHsBind Name, [Name], Uses) @@ -573,7 +554,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) @@ -638,26 +619,31 @@ rnMethodBinds cls sig_fn gen_tyvars binds (bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind return (bind' `unionBags` binds, fvs_bind `plusFV` fvs) +rnMethodBind :: Name + -> (Name -> [Name]) + -> [Name] + -> LHsBindLR RdrName RdrName + -> RnM (Bag (LHsBindLR Name Name), FreeVars) rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = inf, fun_matches = MatchGroup matches _ })) - = 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 <- 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 })), + 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) @@ -672,9 +658,11 @@ rnMethodBind cls sig_fn gen_tyvars (L loc (FunBind { fun_id = name, fun_infix = -- 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 _ _ _ mbind@(L _ (PatBind _ _ _ _)) = do + addLocErr mbind methodBindErr + return (emptyBag, emptyFVs) + +rnMethodBind _ _ _ b = pprPanic "rnMethodBind" (ppr b) \end{code} @@ -698,31 +686,30 @@ signatures. We'd only need this if we wanted to report unused tyvars. \begin{code} renameSigs :: (LSig Name -> Bool) -> [LSig RdrName] -> RnM [LSig Name] -- Renames the signatures and performs error checks -renameSigs ok_sig sigs +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 +rename_sigs sigs = mapM (wrapLocM renameSig) 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_sigs ok_sig sigs = do -- 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') } + -- (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 + _ -> False -- We use lookupLocatedSigOccRn in the signatures, which is a little bit unsatisfactory -- because this won't work for: @@ -735,27 +722,27 @@ check_sigs ok_sig sigs 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 (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)) \end{code} @@ -767,32 +754,33 @@ renameSig (FixSig (FixitySig v f)) \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' ctxt match@(Match pats maybe_rhs_sig grhss) +rnMatch' :: HsMatchContext Name -> Match RdrName -> RnM (Match Name, FreeVars) +rnMatch' ctxt (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 + 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',_) -> - rnGRHSs ctxt grhss `thenM` \ (grhss', grhss_fvs) -> + rnPatsAndThen_LocalRightwards ctxt pats $ \ pats' -> do + (grhss', grhss_fvs) <- rnGRHSs ctxt grhss - returnM (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs) + return (Match pats' maybe_rhs_sig' grhss', grhss_fvs `plusFV` ty_fvs) -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs where rhs_sig_tys = case maybe_rhs_sig of @@ -812,19 +800,20 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) 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) } @@ -834,7 +823,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} %************************************************************************ @@ -844,39 +833,45 @@ rnGRHS' ctxt (GRHS guards rhs) %************************************************************************ \begin{code} +dupSigDeclErr :: [LSig Name] -> 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 Name -> RnM () 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 + extra_stuff _ _ = empty +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}