From: unknown Date: Wed, 13 Apr 2011 08:18:39 +0000 (+0100) Subject: Merge branch 'master' of c:/code/HEAD-git/. into ghc-generics X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;ds=sidebyside;h=8419203b7eb5aa4bb13f8d1263632de4d10a4048;hp=-c;p=ghc-hetmet.git Merge branch 'master' of c:/code/HEAD-git/. into ghc-generics --- 8419203b7eb5aa4bb13f8d1263632de4d10a4048 diff --combined compiler/hsSyn/HsUtils.lhs index 4fbd13a,13f3cd7..ad0f30f --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@@ -27,7 -27,7 +27,7 @@@ module HsUtils nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, - -- Bindigns + -- Bindings mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, -- Literals @@@ -61,7 -61,10 +61,10 @@@ collectSigTysFromPats, collectSigTysFromPat, hsTyClDeclBinders, hsTyClDeclsBinders, - hsForeignDeclsBinders, hsGroupBinders + hsForeignDeclsBinders, hsGroupBinders, + + -- Collecting implicit binders + lStmtsImplicits, hsValBindsImplicits, lPatImplicits ) where import HsDecls @@@ -81,8 -84,11 +84,11 @@@ import NameSe import BasicTypes import SrcLoc import FastString + import Outputable import Util import Bag + + import Data.Either \end{code} @@@ -617,6 -623,81 +623,81 @@@ hsConDeclsBinders con %************************************************************************ %* * + Collecting binders the user did not write + %* * + %************************************************************************ + + The job of this family of functions is to run through binding sites and find the set of all Names + that were defined "implicitly", without being explicitly written by the user. + + The main purpose is to find names introduced by record wildcards so that we can avoid + warning the user when they don't use those names (#4404) + + \begin{code} + lStmtsImplicits :: [LStmtLR Name idR] -> NameSet + lStmtsImplicits = hs_lstmts + where + hs_lstmts :: [LStmtLR Name idR] -> NameSet + hs_lstmts = foldr (\stmt rest -> unionNameSets (hs_stmt (unLoc stmt)) rest) emptyNameSet + + hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat + hs_stmt (LetStmt binds) = hs_local_binds binds + hs_stmt (ExprStmt _ _ _) = emptyNameSet + hs_stmt (ParStmt xs) = hs_lstmts $ concatMap fst xs + + hs_stmt (TransformStmt stmts _ _ _) = hs_lstmts stmts + hs_stmt (GroupStmt stmts _ _ _) = hs_lstmts stmts + hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss + + hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds + hs_local_binds (HsIPBinds _) = emptyNameSet + hs_local_binds EmptyLocalBinds = emptyNameSet + + hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet + hsValBindsImplicits (ValBindsOut binds _) + = unionManyNameSets [foldBag unionNameSets (hs_bind . unLoc) emptyNameSet hs_binds | (_rec, hs_binds) <- binds] + where + hs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat + hs_bind _ = emptyNameSet + hsValBindsImplicits (ValBindsIn {}) = pprPanic "hsValBindsImplicits: ValBindsIn" empty + + lPatImplicits :: LPat Name -> NameSet + lPatImplicits = hs_lpat + where + hs_lpat (L _ pat) = hs_pat pat + + hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSets` rest) emptyNameSet + + hs_pat (LazyPat pat) = hs_lpat pat + hs_pat (BangPat pat) = hs_lpat pat + hs_pat (AsPat _ pat) = hs_lpat pat + hs_pat (ViewPat _ pat _) = hs_lpat pat + hs_pat (ParPat pat) = hs_lpat pat + hs_pat (ListPat pats _) = hs_lpats pats + hs_pat (PArrPat pats _) = hs_lpats pats + hs_pat (TuplePat pats _ _) = hs_lpats pats + + hs_pat (SigPatIn pat _) = hs_lpat pat + hs_pat (SigPatOut pat _) = hs_lpat pat + hs_pat (CoPat _ pat _) = hs_pat pat + + hs_pat (ConPatIn _ ps) = details ps + hs_pat (ConPatOut {pat_args=ps}) = details ps + + hs_pat _ = emptyNameSet + + details (PrefixCon ps) = hs_lpats ps + details (RecCon fs) = hs_lpats explicit `unionNameSets` mkNameSet (collectPatsBinders implicit) + where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat + | (i, fld) <- [0..] `zip` rec_flds fs + , let pat = hsRecFieldArg fld + pat_explicit = maybe True (i<) (rec_dotdot fs)] + details (InfixCon p1 p2) = hs_lpat p1 `unionNameSets` hs_lpat p2 + \end{code} + + + %************************************************************************ + %* * Collecting type signatures from patterns %* * %************************************************************************ diff --combined compiler/rename/RnBinds.lhs index 03dfa08,6c57cb2..ee30f46 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@@ -357,7 -357,9 +357,9 @@@ rnLocalValBindsAndThen binds@(ValBindsI -- let x = x in 3 -- should report 'x' unused ; let real_uses = findUses dus result_fvs - ; warnUnusedLocalBinds bound_names real_uses + -- 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: @@@ -586,20 -588,8 +588,20 @@@ rnMethodBinds :: Name -- Class nam -> RnM (LHsBinds Name, FreeVars) rnMethodBinds cls sig_fn gen_tyvars binds - = foldlM do_one (emptyBag,emptyFVs) (bagToList binds) + = do { checkDupRdrNames meth_names + -- Check that the same method is not given twice in the + -- same instance decl instance C T where + -- f x = ... + -- g y = ... + -- f x = ... + -- We must use checkDupRdrNames because the Name of the + -- method is the Name of the class selector, whose SrcSpan + -- points to the class declaration; and we use rnMethodBinds + -- for instance decls too + + ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) } where + meth_names = collectMethodBinders binds do_one (binds,fvs) bind = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) } @@@ -675,12 -665,7 +677,12 @@@ renameSigs mb_names ok_sig sig -- Check for duplicates on RdrName version, -- because renamed version has unboundName for -- not-in-scope binders, which gives bogus dup-sig errors - + -- NB: in a class decl, a 'generic' sig is not considered + -- equal to an ordinary sig, so we allow, say + -- class C a where + -- op :: a -> a + -- generic op :: Eq a => a -> a + ; sigs' <- mapM (wrapLocM (renameSig mb_names)) sigs ; let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs' @@@ -707,11 -692,6 +709,11 @@@ renameSig mb_names sig@(TypeSig v ty ; new_ty <- rnHsSigType (quotes (ppr v)) ty ; return (TypeSig new_v new_ty) } +renameSig mb_names sig@(GenericSig v ty) + = do { new_v <- lookupSigOccRn mb_names sig v + ; new_ty <- rnHsSigType (quotes (ppr v)) ty + ; return (GenericSig new_v new_ty) } -- JPM: ? + renameSig _ (SpecInstSig ty) = do { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty ; return (SpecInstSig new_ty) } diff --combined compiler/typecheck/TcRnDriver.lhs index d429a78,23c2e67..46852c6 --- a/compiler/typecheck/TcRnDriver.lhs +++ b/compiler/typecheck/TcRnDriver.lhs @@@ -9,8 -9,9 +9,9 @@@ module TcRnDriver #ifdef GHCI tcRnStmt, tcRnExpr, tcRnType, tcRnLookupRdrName, - getModuleExports, + getModuleExports, #endif + tcRnImports, tcRnLookupName, tcRnGetInfo, tcRnModule, @@@ -299,7 -300,7 +300,7 @@@ tcRnExtCore hsc_env (HsExtCore this_mo -- any mutually recursive types are done right -- Just discard the auxiliary bindings; they are generated -- only for Haskell source code, and should already be in Core - (tcg_env, _aux_binds, _dm_ids) <- tcTyAndClassDecls emptyModDetails rn_decls ; + (tcg_env, _aux_binds, _dm_ids, _) <- tcTyAndClassDecls emptyModDetails rn_decls ; setGblEnv tcg_env $ do { -- Make the new type env available to stuff slurped from interface files @@@ -500,7 -501,7 +501,7 @@@ tcRnHsBootDecls decl -- Typecheck type/class decls ; traceTc "Tc2" empty - ; (tcg_env, aux_binds, dm_ids) + ; (tcg_env, aux_binds, dm_ids, _) <- tcTyAndClassDecls emptyModDetails tycl_decls ; setGblEnv tcg_env $ tcExtendIdEnv dm_ids $ do { @@@ -847,7 -848,7 +848,7 @@@ tcTopSrcDecls boot_detail -- The latter come in via tycl_decls traceTc "Tc2" empty ; - (tcg_env, aux_binds, dm_ids) <- tcTyAndClassDecls boot_details tycl_decls ; + (tcg_env, aux_binds, dm_ids, kc_decls) <- tcTyAndClassDecls boot_details tycl_decls ; -- If there are any errors, tcTyAndClassDecls fails here setGblEnv tcg_env $ @@@ -885,9 -886,8 +886,9 @@@ setLclTypeEnv tcl_env $ do { -- Environment doesn't change now -- Second pass over class and instance declarations, + -- now using the kind-checked decls traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ; + inst_binds <- tcInstDecls2 kc_decls inst_infos ; -- Foreign exports traceTc "Tc7" empty ;