X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnBinds.lhs;h=2ae46bf0d27d6623b5044bbe4b91031069107b15;hp=ad2a6b370e95c25c59f3fb1ff1a023e005f79d19;hb=c1500e4888be2341c0b6e6897f494766c86feba0;hpb=d5934bbb856aa0aa620c9b2e0fa51c90a1a5a048 diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index ad2a6b3..2ae46bf 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -9,44 +9,41 @@ 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} -module RnBinds ( - rnTopBinds, - rnLocalBindsAndThen, rnValBindsAndThen, rnValBinds, trimWith, - rnMethodBinds, renameSigs, mkSigTvFn, - rnMatchGroup, rnGRHSs +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, MiniFixityEnv ) where -#include "HsVersions.h" - import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) import HsSyn import RdrHsSyn import RnHsSyn import TcRnMonad -import RnTypes ( rnHsSigType, rnLHsType, rnHsTypeFVs, - rnLPat, rnPatsAndThen, patSigErr, checkPrecMatch ) -import RnEnv ( bindLocatedLocalsRn, lookupLocatedBndrRn, - lookupLocatedInstDeclBndr, newIPNameRn, - lookupLocatedSigOccRn, bindPatSigTyVarsFV, - bindLocalFixities, bindSigTyVarsFV, - warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, - ) +import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch) +import RnPat (rnPatsAndThen_LocalRightwards, rnBindPat, + NameMaker, localRecNameMaker, topRecNameMaker, applyNameMaker + ) + +import RnEnv +import PrelNames ( mkUnboundName ) import DynFlags ( DynFlag(..) ) -import Name ( Name, nameOccName, nameSrcLoc ) +import Name import NameEnv import NameSet -import PrelNames ( isUnboundName ) import RdrName ( RdrName, rdrNameOcc ) -import SrcLoc ( mkSrcSpan, Located(..), unLoc ) +import SrcLoc import ListSetOps ( findDupsEq ) import BasicTypes ( RecFlag(..) ) import Digraph ( SCC(..), stronglyConnComp ) import Bag import Outputable +import FastString +import Data.List ( partition ) 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 @@ -155,43 +152,46 @@ it expects the global environment to contain bindings for the binders %* * %************************************************************************ -@rnTopMonoBinds@ assumes that the environment already -contains bindings for the binders of this particular binding. - \begin{code} -rnTopBinds :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) - --- The binders of the binding are in scope already; --- the top level scope resolution does that - -rnTopBinds binds - = do { is_boot <- tcIsHsBoot - ; if is_boot then rnTopBindsBoot binds - else rnTopBindsSrc binds } - -rnTopBindsBoot :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) +-- for top-level bindings, we need to make top-level names, +-- so we have a different entry point than for local bindings +rnTopBindsLHS :: MiniFixityEnv + -> HsValBinds RdrName + -> RnM (HsValBindsLR Name RdrName) +rnTopBindsLHS fix_env binds = + (uncurry $ rnValBindsLHSFromDoc (topRecNameMaker fix_env)) (bindersAndDoc binds) binds + +rnTopBindsRHS :: [Name] -- the names bound by these binds + -> HsValBindsLR Name RdrName + -> RnM (HsValBinds Name, DefUses) +rnTopBindsRHS bound_names binds = + do { is_boot <- tcIsHsBoot + ; if is_boot + 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, +-- or anything else in the scope of the left +-- +-- never used when there are fixity declarations +rnTopBinds :: HsValBinds RdrName + -> RnM (HsValBinds Name, DefUses) +rnTopBinds b = + do nl <- rnTopBindsLHS emptyFsEnv b + let bound_names = map unLoc (collectHsValBinders nl) + bindLocalNames bound_names $ rnTopBindsRHS bound_names nl + + +rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -- A hs-boot file has no bindings. -- 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')) } - -rnTopBindsSrc :: HsValBinds RdrName -> RnM (HsValBinds Name, DefUses) -rnTopBindsSrc binds@(ValBindsIn mbinds _) - = do { (binds', dus) <- rnValBinds noTrim binds - - -- Warn about missing signatures, - ; let { ValBindsOut _ sigs' = binds' - ; ty_sig_vars = mkNameSet [ unLoc n | L _ (TypeSig n _) <- sigs'] - ; un_sigd_bndrs = duDefs dus `minusNameSet` ty_sig_vars } - - ; warn_missing_sigs <- doptM Opt_WarnMissingSigs - ; ifM (warn_missing_sigs) - (mappM_ missingSigWarn (nameSetToList un_sigd_bndrs)) - - ; return (binds', dus) - } +rnTopBindsBoot b = pprPanic "rnTopBindsBoot" (ppr b) \end{code} @@ -203,33 +203,33 @@ rnTopBindsSrc binds@(ValBindsIn mbinds _) %********************************************************* \begin{code} -rnLocalBindsAndThen - :: HsLocalBinds RdrName - -> (HsLocalBinds Name -> RnM (result, FreeVars)) - -> RnM (result, FreeVars) --- This version (a) assumes that the binding vars are not already in scope --- (b) removes the binders from the free vars of the thing inside +rnLocalBindsAndThen :: HsLocalBinds RdrName + -> (HsLocalBinds Name -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) +-- This version (a) assumes that the binding vars are *not* already in scope +-- (b) removes the binders from the free vars of the thing inside -- The parser doesn't produce ThenBinds rnLocalBindsAndThen EmptyLocalBinds thing_inside = thing_inside EmptyLocalBinds 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) - -------------- -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) -> + thing_inside (HsValBinds val_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 :: 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 RdrName -> RnM (IPBind Name, FreeVars) +rnIPBind (IPBind n expr) = do + name <- newIPNameRn n + (expr',fvExpr) <- rnLExpr expr return (IPBind name expr', fvExpr) \end{code} @@ -241,68 +241,295 @@ rnIPBind (IPBind n expr) %************************************************************************ \begin{code} -rnValBindsAndThen :: HsValBinds RdrName - -> (HsValBinds Name -> RnM (result, FreeVars)) - -> RnM (result, FreeVars) - -rnValBindsAndThen binds@(ValBindsIn mbinds sigs) thing_inside - = -- Extract all the binders in this group, and extend the - -- current scope, inventing new names for the new binders - -- This also checks that the names form a set - bindLocatedLocalsRn doc mbinders_w_srclocs $ \ bndrs -> - - -- Then install local fixity declarations - -- Notice that they scope over thing_inside too - bindLocalFixities [sig | L _ (FixSig sig) <- sigs ] $ - - -- Do the business - rnValBinds (trimWith bndrs) binds `thenM` \ (binds, bind_dus) -> - - -- Now do the "thing inside" - thing_inside binds `thenM` \ (result,result_fvs) -> - - -- Final error checking +-- wrapper for local binds +-- creates the documentation info and calls the helper below +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 + -> MiniFixityEnv + -> 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 - all_uses = duUses bind_dus `plusFV` result_fvs - -- duUses: It's important to return all the uses, not the 'real uses' - -- used for warning about unused bindings. 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 - - unused_bndrs = [ b | b <- bndrs, not (b `elemNameSet` all_uses)] + -- the unrenamed bndrs for error checking and reporting + orig = collectHsValBinders binds + doc = text "In the binding group for:" <+> pprWithCommas ppr (map unLoc orig) in - warnUnusedLocalBinds unused_bndrs `thenM_` + (orig, doc) + +-- 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 (ValBindsIn mbinds sigs) = do + -- rename the LHSes + mbinds' <- mapBagM (rnBindLHS topP doc) mbinds + return $ ValBindsIn mbinds' sigs +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 +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 + -> HsValBindsLR Name RdrName + -> RnM (HsValBinds Name, DefUses) + +rnValBindsRHSGen trim bound_names (ValBindsIn mbinds sigs) = do + -- rename the sigs + env <- getGblEnv + traceRn (ptext (sLit "Rename sigs") <+> ppr (tcg_rdr_env env)) + sigs' <- renameSigs (Just (mkNameSet bound_names)) okBindSig 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) + 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; +-- 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 - returnM (result, delListFromNameSet all_uses bndrs) - where - mbinders_w_srclocs = collectHsBindLocatedBinders mbinds - doc = text "In the binding group for:" - <+> pprWithCommas ppr (map unLoc mbinders_w_srclocs) + +-- 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 + = do { let (original_bndrs, doc) = bindersAndDoc binds + + -- (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' + + -- 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 + -- 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 + +rnValBindsAndThen bs _ = pprPanic "rnValBindsAndThen" (ppr bs) + + +-- Process the fixity declarations, making a FastString -> (Located Fixity) map +-- (We keep the location around for reporting duplicate fixity declarations.) +-- +-- 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 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 { fs = occNameFS (rdrNameOcc name) + ; fix_item = L loc fixity }; + + 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') + ; return 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] --------------------- -rnValBinds :: (FreeVars -> FreeVars) - -> HsValBinds RdrName - -> RnM (HsValBinds Name, DefUses) --- Assumes the binders of the binding are in scope already -rnValBinds trim (ValBindsIn mbinds sigs) - = do { sigs' <- rename_sigs sigs +-- renaming a single bind + +rnBindLHS :: NameMaker + -> SDoc + -> 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 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) <- 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 _ (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 _ 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 + + ; (grhss', fvs) <- rnGRHSs PatBindRhs grhss + -- No scoped type variables for pattern bindings - ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds + ; return (L loc (PatBind { pat_lhs = pat, + pat_rhs = grhss', + pat_rhs_ty = placeHolderType, + bind_fvs = trim fvs }), + bndrs, pat_fvs `plusFV` fvs) } - ; let (binds', bind_dus) = depAnalBinds binds_w_dus +rnBind sig_fn + trim + (L loc (FunBind { fun_id = name, + fun_infix = inf, + fun_matches = matches, + -- no pattern FVs + bind_fvs = _ + })) + -- invariant: no free vars here when it's a FunBind + = setSrcSpan loc $ + do { let plain_name = unLoc name - -- We do the check-sigs after renaming the bindings, - -- so that we have convenient access to the binders - ; check_sigs (okBindSig (duDefs bind_dus)) sigs' + ; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ + -- bindSigTyVars tests for Opt_ScopedTyVars + rnMatchGroup (FunRhs plain_name inf) matches - ; return (ValBindsOut binds' sigs', - usesOnly (hsSigsFVs sigs') `plusDU` bind_dus) } + ; checkPrecMatch inf plain_name matches' + ; return (L loc (FunBind { fun_id = name, + fun_infix = inf, + fun_matches = matches', + bind_fvs = trim fvs, + fun_co_fn = idHsWrapper, + fun_tick = Nothing }), + [plain_name], fvs) + } +rnBind _ _ b = pprPanic "rnBind" (ppr b) + --------------------- depAnalBinds :: Bag (LHsBind Name, [Name], Uses) -> ([(RecFlag, LHsBinds Name)], DefUses) @@ -324,7 +551,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) @@ -358,49 +585,6 @@ mkSigTvFn sigs (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs] -- Note the pattern-match on "Explicit"; we only bind -- type variables from signatures with an explicit top-level for-all - --- The trimming function trims the free vars we attach to a --- binding so that it stays reasonably small -noTrim :: FreeVars -> FreeVars -noTrim fvs = fvs -- Used at top level - -trimWith :: [Name] -> FreeVars -> FreeVars --- Nested bindings; trim by intersection with the names bound here -trimWith bndrs = intersectNameSet (mkNameSet bndrs) - ---------------------- -rnBind :: (Name -> [Name]) -- Signature tyvar function - -> (FreeVars -> FreeVars) -- Trimming function for rhs free vars - -> LHsBind RdrName - -> RnM (LHsBind Name, [Name], Uses) -rnBind sig_fn trim (L loc (PatBind { pat_lhs = pat, pat_rhs = grhss })) - = setSrcSpan loc $ - do { (pat', pat_fvs) <- rnLPat pat - - ; 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 })) - = setSrcSpan loc $ - do { new_name <- lookupLocatedBndrRn name - ; let plain_name = unLoc new_name - - ; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ - -- bindSigTyVars tests for Opt_ScopedTyVars - rnMatchGroup (FunRhs plain_name) matches - - ; checkPrecMatch inf plain_name matches' - - ; return (L loc (FunBind { fun_id = new_name, fun_infix = inf, fun_matches = matches', - bind_fvs = trim fvs, fun_co_fn = idHsWrapper, fun_tick = Nothing }), - [plain_name], fvs) - } \end{code} @@ -432,40 +616,50 @@ 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 $ - lookupLocatedInstDeclBndr 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 })), - 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) rn_match sel_name match@(L _ (Match (L _ (TypePat ty) : _) _ _)) = extendTyVarEnvFVRn gen_tvs $ - rnMatch (FunRhs sel_name) match + rnMatch (FunRhs sel_name inf) 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) match + rn_match sel_name match = rnMatch (FunRhs sel_name inf) 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 _ _ _ mbind@(L _ (PatBind _ _ _ _)) = do + addLocErr mbind methodBindErr + return (emptyBag, emptyFVs) + +rnMethodBind _ _ _ b = pprPanic "rnMethodBind" (ppr b) \end{code} @@ -480,42 +674,26 @@ rnMethodBind cls sig_fn gen_tyvars mbind@(L loc (PatBind other_pat _ _ _)) \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' } +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' } ---------------------- -rename_sigs :: [LSig RdrName] -> RnM [LSig Name] -rename_sigs sigs = mappM (wrapLocM renameSig) - (filter (not . isFixityLSig) sigs) - -- Remove fixity sigs which have been dealt with already - ----------------------- -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 { 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 #-} @@ -524,25 +702,77 @@ check_sigs ok_sig sigs -- 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 :: Maybe NameSet -> Sig RdrName -> RnM (Sig Name) +-- FixitySig is renamed elsewhere. +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)) } + +-- lookupSigOccRn is used for type signatures and pragmas +-- Is this valid? +-- module A +-- import M( f ) +-- f :: Int -> Int +-- f x = x +-- It's clear that the 'f' in the signature must refer to A.f +-- The Haskell98 report does not stipulate this, but it will! +-- So we must treat the 'f' in the signature in the same way +-- as the binding occurrence of 'f', using lookupBndrRn +-- +-- However, consider this case: +-- import M( f ) +-- f :: Int -> Int +-- g x = x +-- We don't want to say 'f' is out of scope; instead, we want to +-- return the imported 'f', so that later on the reanamer will +-- correctly report "misplaced type sig". + +lookupSigOccRn :: Maybe NameSet -> Sig RdrName -> Located RdrName -> RnM (Located Name) +lookupSigOccRn mb_names sig (L loc v) + = do { mb_n <- lookupBndrRn_maybe v + ; case mb_n of { + Just n -> case mb_names of { + Nothing -> return (L loc n) ; + Just ns | n `elemNameSet` ns -> return (L loc n) + | otherwise -> bale_out_with local_msg } ; + + Nothing -> do + { mb_n <- lookupGreRn_maybe v + ; case mb_n of + Just _ -> bale_out_with import_msg + Nothing -> bale_out_with empty + } }} + where + bale_out_with msg + = do { addErr (sep [ ptext (sLit "The") <+> hsSigDoc sig + <+> ptext (sLit "for") <+> quotes (ppr v) + , nest 2 $ ptext (sLit "lacks an accompanying binding")] + $$ nest 2 msg) + ; return (L loc (mkUnboundName v)) } + + local_msg = parens $ ptext (sLit "The") <+> hsSigDoc sig <+> ptext (sLit "must be given where") + <+> quotes (ppr v) <+> ptext (sLit "is declared") + + import_msg = parens $ ptext (sLit "You cannot give a") <+> hsSigDoc sig + <+> ptext (sLit "an imported value") \end{code} @@ -554,37 +784,35 @@ renameSig (InlineSig v s) \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_GlasgowExts `thenM` \ opt_GlasgowExts -> - (case maybe_rhs_sig of - Nothing -> returnM (Nothing, emptyFVs) - Just ty | opt_GlasgowExts -> 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 - rnPatsAndThen 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 ty -> addLocErr ty (resSigErr ctxt match) + + + -- 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' 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} @@ -598,19 +826,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 { opt_GlasgowExts <- doptM Opt_GlasgowExts + = do { pattern_guards_allowed <- doptM Opt_PatternGuards ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $ rnLExpr rhs - ; checkM (opt_GlasgowExts || is_standard_guard guards') + ; unless (pattern_guards_allowed || is_standard_guard guards') (addWarn (nonStdGuardErr guards')) ; return (GRHS guards' rhs', fvs) } @@ -620,7 +849,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} %************************************************************************ @@ -630,35 +859,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 :: LSig RdrName -> RnM () unknownSigErr (L loc sig) = addErrAt loc $ - sep [ptext SLIT("Misplaced") <+> what_it_is <> colon, ppr sig] - where - what_it_is = hsSigDoc sig - -missingSigWarn var - = addWarnAt (mkSrcSpan loc loc) $ - sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)] - where - loc = nameSrcLoc var -- TODO: make a proper span + 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 (-fglasgow-exts to suppress this message)")) + = hang (ptext (sLit "accepting non-standard pattern guards (use -XPatternGuards to suppress this message)")) 4 (interpp'SP guards) \end{code}