From df8b00e014ad8280354dd3fab6e6df0a52377627 Mon Sep 17 00:00:00 2001 From: "simonpj@microsoft.com" Date: Thu, 5 Nov 2009 16:55:25 +0000 Subject: [PATCH] Fix Trac #3640, plus associated refactoring In fixing this bug (to do with record puns), I had the usual rush of blood to the head, and I did quite a bit of refactoring in the way that duplicate/shadowed names are reported. I think the result is shorter as well as clearer. In one place I found it convenient for the renamer to use the ErrCtxt carried in the monad. (The renamer used not to have such a context, but years ago the typechecker and renamer monads became one, so now it does.) So now it's availble if you want it in future. --- compiler/rename/RnBinds.lhs | 123 ++++++++++++++++---------------------- compiler/rename/RnEnv.lhs | 93 ++++++++++++++-------------- compiler/rename/RnExpr.lhs | 19 +++--- compiler/rename/RnPat.lhs | 4 +- compiler/rename/RnSource.lhs | 63 +++++++++---------- compiler/rename/RnTypes.lhs | 2 +- compiler/typecheck/TcRnMonad.lhs | 79 ++++++++++++++---------- 7 files changed, 182 insertions(+), 201 deletions(-) diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs index 12432a3..876f25a 100644 --- a/compiler/rename/RnBinds.lhs +++ b/compiler/rename/RnBinds.lhs @@ -158,9 +158,8 @@ rnTopBindsLHS :: MiniFixityEnv -> HsValBinds RdrName -> RnM (HsValBindsLR Name RdrName) rnTopBindsLHS fix_env binds - = do { let (boundNames,doc) = bindersAndDoc binds - ; mod <- getModule - ; rnValBindsLHSFromDoc (topRecNameMaker mod fix_env) boundNames doc binds } + = do { mod <- getModule + ; rnValBindsLHSFromDoc (topRecNameMaker mod fix_env) binds } rnTopBindsRHS :: NameSet -- Names bound by these binds -> HsValBindsLR Name RdrName @@ -241,63 +240,46 @@ rnIPBind (IPBind n expr) = do %************************************************************************ \begin{code} --- wrapper for local binds --- creates the documentation info and calls the helper below +-- Renaming local binding gropus +-- Does duplicate/shadow check 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 - -- the unrenamed bndrs for error checking and reporting - orig = collectHsValBinders binds - doc = text "In the binding group for:" <+> pprWithCommas ppr (map unLoc orig) - in - (orig, doc) + -> RnM ([Name], HsValBindsLR Name RdrName) +rnValBindsLHS 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. + -- + -- 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. + ; binds' <- rnValBindsLHSFromDoc (localRecNameMaker fix_env) binds + ; let bound_names = map unLoc $ collectHsValBinders binds' + ; envs <- getRdrEnvs + ; checkDupAndShadowedNames envs bound_names + ; return (bound_names, 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 :: 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) +rnValBindsLHSFromDoc topP (ValBindsIn mbinds sigs) + = do { mbinds' <- mapBagM (rnBindLHS topP doc) mbinds + ; return $ ValBindsIn mbinds' sigs } + where + bndrs = collectHsBindBinders mbinds + doc = text "In the binding group for:" <+> pprWithCommas ppr bndrs + +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 @@ -310,16 +292,16 @@ rnValBindsRHSGen :: (FreeVars -> FreeVars) -- for trimming free var sets -> HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses) -rnValBindsRHSGen trim bound_names (ValBindsIn mbinds sigs) = do - -- rename the sigs - sigs' <- renameSigs (Just bound_names) okBindSig sigs - -- rename the RHSes - binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds - case depAnalBinds binds_w_dus of - (anal_binds, anal_dus) -> - do let valbind' = ValBindsOut anal_binds sigs' - valbind'_dus = usesOnly (hsSigsFVs sigs') `plusDU` anal_dus - return (valbind', valbind'_dus) +rnValBindsRHSGen trim bound_names (ValBindsIn mbinds sigs) + = do { -- rename the sigs + sigs' <- renameSigs (Just bound_names) okBindSig sigs + -- rename the RHSes + ; binds_w_dus <- mapBagM (rnBind (mkSigTvFn sigs') trim) mbinds + ; case depAnalBinds binds_w_dus of + (anal_binds, anal_dus) -> do + { let valbind' = ValBindsOut anal_binds sigs' + valbind'_dus = usesOnly (hsSigsFVs sigs') `plusDU` anal_dus + ; return (valbind', valbind'_dus) }} rnValBindsRHSGen _ _ b = pprPanic "rnValBindsRHSGen" (ppr b) @@ -346,14 +328,11 @@ 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] + = 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 + ; (bound_names, new_lhs) <- rnValBindsLHS new_fixities binds -- ...and bring them (and their fixities) into scope ; bindLocalNamesFV_WithFixities bound_names new_fixities $ do @@ -418,7 +397,7 @@ makeMiniFixityEnv decls = foldlM add_one emptyFsEnv decls Nothing -> return $ extendFsEnv env fs fix_item Just (L loc' _) -> do { setSrcSpan loc $ - addLocErr (L name_loc name) (dupFixityDecl loc') + addErrAt name_loc (dupFixityDecl loc' name) ; return env} } @@ -670,8 +649,8 @@ 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 _ _ _ mbind@(L _ (PatBind _ _ _ _)) = do - addLocErr mbind methodBindErr +rnMethodBind _ _ _ (L loc bind@(PatBind {})) = do + addErrAt loc (methodBindErr bind) return (emptyBag, emptyFVs) rnMethodBind _ _ _ b = pprPanic "rnMethodBind" (ppr b) @@ -765,8 +744,7 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) = do { -- Result type signatures are no longer supported case maybe_rhs_sig of Nothing -> return () - Just ty -> addLocErr ty (resSigErr ctxt match) - + Just (L loc ty) -> addErrAt loc (resSigErr ctxt match ty) -- Now the main event -- note that there are no local ficity decls for matches @@ -775,7 +753,6 @@ rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) ; return (Match pats' Nothing grhss', grhss_fvs) }} -- The bindPatSigTyVarsFV and rnPatsAndThen will remove the bound FVs - where resSigErr :: HsMatchContext Name -> Match RdrName -> HsType RdrName -> SDoc resSigErr ctxt match ty diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs index 20d2218..c81d701 100644 --- a/compiler/rename/RnEnv.lhs +++ b/compiler/rename/RnEnv.lhs @@ -25,8 +25,8 @@ module RnEnv ( bindSigTyVarsFV, bindPatSigTyVars, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, - checkDupRdrNames, checkDupNames, checkShadowedNames, - checkDupAndShadowedRdrNames, + checkDupRdrNames, checkDupAndShadowedRdrNames, + checkDupAndShadowedNames, mapFvRn, mapFvRnCPS, warnUnusedMatches, warnUnusedModules, warnUnusedImports, warnUnusedTopBinds, warnUnusedLocalBinds, @@ -795,20 +795,11 @@ newLocalBndrsRn :: [Located RdrName] -> RnM [Name] newLocalBndrsRn = mapM newLocalBndrRn --------------------- -checkDupAndShadowedRdrNames :: SDoc -> [Located RdrName] -> RnM () -checkDupAndShadowedRdrNames doc loc_rdr_names - = do { checkDupRdrNames doc loc_rdr_names - ; envs <- getRdrEnvs - ; checkShadowedNames doc envs - [(loc,rdrNameOcc rdr) | L loc rdr <- loc_rdr_names] } - ---------------------- -bindLocatedLocalsRn :: SDoc -- Documentation string for error message - -> [Located RdrName] +bindLocatedLocalsRn :: [Located RdrName] -> ([Name] -> RnM a) -> RnM a -bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope - = do { checkDupAndShadowedRdrNames doc_str rdr_names_w_loc +bindLocatedLocalsRn rdr_names_w_loc enclosed_scope + = do { checkDupAndShadowedRdrNames rdr_names_w_loc -- Make fresh Names and extend the environment ; names <- newLocalBndrsRn rdr_names_w_loc @@ -835,20 +826,20 @@ bindLocalNamesFV names enclosed_scope ------------------------------------- -- binLocalsFVRn is the same as bindLocalsRn -- except that it deals with free vars -bindLocatedLocalsFV :: SDoc -> [Located RdrName] +bindLocatedLocalsFV :: [Located RdrName] -> ([Name] -> RnM (a,FreeVars)) -> RnM (a, FreeVars) -bindLocatedLocalsFV doc rdr_names enclosed_scope - = bindLocatedLocalsRn doc rdr_names $ \ names -> +bindLocatedLocalsFV rdr_names enclosed_scope + = bindLocatedLocalsRn rdr_names $ \ names -> enclosed_scope names `thenM` \ (thing, fvs) -> return (thing, delListFromNameSet fvs names) ------------------------------------- -bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName] +bindTyVarsRn :: [LHsTyVarBndr RdrName] -> ([LHsTyVarBndr Name] -> RnM a) -> RnM a -- Haskell-98 binding of type variables; e.g. within a data type decl -bindTyVarsRn doc_str tyvar_names enclosed_scope - = bindLocatedLocalsRn doc_str located_tyvars $ \ names -> +bindTyVarsRn tyvar_names enclosed_scope + = bindLocatedLocalsRn located_tyvars $ \ names -> do { kind_sigs_ok <- doptM Opt_KindSignatures ; unless (null kinded_tyvars || kind_sigs_ok) (mapM_ (addErr . kindSigErr) kinded_tyvars) @@ -875,9 +866,7 @@ bindPatSigTyVars tys thing_inside -- f (x :: t) (y :: t) = .... -- We don't want to complain about binding t twice! - ; bindLocatedLocalsRn doc_sig nubbed_tvs thing_inside }} - where - doc_sig = text "In a pattern type-signature" + ; bindLocatedLocalsRn nubbed_tvs thing_inside }} bindPatSigTyVarsFV :: [LHsType RdrName] -> RnM (a, FreeVars) @@ -902,30 +891,42 @@ extendTyVarEnvFVRn :: [Name] -> RnM (a, FreeVars) -> RnM (a, FreeVars) extendTyVarEnvFVRn tyvars thing_inside = bindLocalNamesFV tyvars thing_inside ------------------------------------- -checkDupRdrNames :: SDoc - -> [Located RdrName] - -> RnM () -checkDupRdrNames doc_str rdr_names_w_loc +checkDupRdrNames :: [Located RdrName] -> RnM () +checkDupRdrNames rdr_names_w_loc = -- Check for duplicated names in a binding group - mapM_ (dupNamesErr getLoc doc_str) dups + mapM_ (dupNamesErr getLoc) dups where (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc -checkDupNames :: SDoc - -> [Name] - -> RnM () -checkDupNames doc_str names +checkDupNames :: [Name] -> RnM () +checkDupNames names = -- Check for duplicated names in a binding group - mapM_ (dupNamesErr nameSrcSpan doc_str) dups + mapM_ (dupNamesErr nameSrcSpan) dups where (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names +--------------------- +checkDupAndShadowedRdrNames :: [Located RdrName] -> RnM () +checkDupAndShadowedRdrNames loc_rdr_names + = do { checkDupRdrNames loc_rdr_names + ; envs <- getRdrEnvs + ; checkShadowedOccs envs loc_occs } + where + loc_occs = [(loc,rdrNameOcc rdr) | L loc rdr <- loc_rdr_names] + +checkDupAndShadowedNames :: (GlobalRdrEnv, LocalRdrEnv) -> [Name] -> RnM () +checkDupAndShadowedNames envs names + = do { checkDupNames names + ; checkShadowedOccs envs loc_occs } + where + loc_occs = [(nameSrcSpan name, nameOccName name) | name <- names] + ------------------------------------- -checkShadowedNames :: SDoc -> (GlobalRdrEnv, LocalRdrEnv) -> [(SrcSpan,OccName)] -> RnM () -checkShadowedNames doc_str (global_env,local_env) loc_rdr_names +checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) -> [(SrcSpan,OccName)] -> RnM () +checkShadowedOccs (global_env,local_env) loc_occs = ifOptM Opt_WarnNameShadowing $ - do { traceRn (text "shadow" <+> ppr loc_rdr_names) - ; mapM_ check_shadow loc_rdr_names } + do { traceRn (text "shadow" <+> ppr loc_occs) + ; mapM_ check_shadow loc_occs } where check_shadow (loc, occ) | startsWithUnderscore occ = return () -- Do not report shadowing for "_x" @@ -935,7 +936,7 @@ checkShadowedNames doc_str (global_env,local_env) loc_rdr_names ; complain (map pprNameProvenance gres') } where complain [] = return () - complain pp_locs = addWarnAt loc (shadowedNameWarn doc_str occ pp_locs) + complain pp_locs = addWarnAt loc (shadowedNameWarn occ pp_locs) mb_local = lookupLocalRdrOcc local_env occ gres = lookupGRE_RdrName (mkRdrUnqual occ) global_env -- Make an Unqualified RdrName and look that up, so that @@ -1070,12 +1071,11 @@ addNameClashErrRn rdr_name names msgs = [ptext (sLit " or") <+> mk_ref np | np <- nps] mk_ref gre = quotes (ppr (gre_name gre)) <> comma <+> pprNameProvenance gre -shadowedNameWarn :: SDoc -> OccName -> [SDoc] -> SDoc -shadowedNameWarn doc occ shadowed_locs +shadowedNameWarn :: OccName -> [SDoc] -> SDoc +shadowedNameWarn occ shadowed_locs = sep [ptext (sLit "This binding for") <+> quotes (ppr occ) <+> ptext (sLit "shadows the existing binding") <> plural shadowed_locs, nest 2 (vcat shadowed_locs)] - $$ doc unknownNameErr :: RdrName -> SDoc unknownNameErr rdr_name @@ -1102,18 +1102,15 @@ badOrigBinding name = ptext (sLit "Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) -- The rdrNameOcc is because we don't want to print Prelude.(,) -dupNamesErr :: Outputable n => (n -> SrcSpan) -> SDoc -> [n] -> RnM () -dupNamesErr get_loc descriptor names +dupNamesErr :: Outputable n => (n -> SrcSpan) -> [n] -> RnM () +dupNamesErr get_loc names = addErrAt big_loc $ vcat [ptext (sLit "Conflicting definitions for") <+> quotes (ppr (head names)), - locations, descriptor] + locations] where locs = map get_loc names big_loc = foldr1 combineSrcSpans locs - one_line = isOneLineSpan big_loc - locations | one_line = empty - | otherwise = ptext (sLit "Bound at:") <+> - vcat (map ppr (sortLe (<=) locs)) + locations = ptext (sLit "Bound at:") <+> vcat (map ppr (sortLe (<=) locs)) kindSigErr :: Outputable a => a -> SDoc kindSigErr thing diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs index 4ce7182..a269dd5 100644 --- a/compiler/rename/RnExpr.lhs +++ b/compiler/rename/RnExpr.lhs @@ -950,7 +950,7 @@ rn_rec_stmt_lhs _ (L _ (LetStmt binds@(HsIPBinds _))) = failWith (badIpBinds (ptext (sLit "an mdo expression")) binds) rn_rec_stmt_lhs fix_env (L loc (LetStmt (HsValBinds binds))) - = do binds' <- rnValBindsLHS fix_env binds + = do (_bound_names, binds') <- rnValBindsLHS fix_env binds return [(L loc (LetStmt (HsValBinds binds')), -- Warning: this is bogus; see function invariant emptyFVs @@ -975,15 +975,14 @@ rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds)) rn_rec_stmts_lhs :: MiniFixityEnv -> [LStmt RdrName] -> RnM [(LStmtLR Name RdrName, FreeVars)] -rn_rec_stmts_lhs fix_env stmts = - let boundNames = collectLStmtsBinders stmts - doc = text "In a recursive mdo-expression" - in do - -- First do error checking: we need to check for dups here because we - -- don't bind all of the variables from the Stmt at once - -- with bindLocatedLocals. - checkDupRdrNames doc boundNames - mapM (rn_rec_stmt_lhs fix_env) stmts `thenM` \ ls -> return (concat ls) +rn_rec_stmts_lhs fix_env stmts + = do { let boundNames = collectLStmtsBinders stmts + -- First do error checking: we need to check for dups here because we + -- don't bind all of the variables from the Stmt at once + -- with bindLocatedLocals. + ; checkDupRdrNames boundNames + ; ls <- mapM (rn_rec_stmt_lhs fix_env) stmts + ; return (concat ls) } -- right-hand-sides diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 6ab4890..6367255 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -220,9 +220,7 @@ rnPats ctxt pats thing_inside -- Nor can we check incrementally for shadowing, else we'll -- complain *twice* about duplicates e.g. f (x,x) = ... ; let names = collectPatsBinders pats' - ; checkDupNames doc_pat names - ; checkShadowedNames doc_pat envs_before - [(nameSrcSpan name, nameOccName name) | name <- names] + ; addErrCtxt doc_pat $ checkDupAndShadowedNames envs_before names ; thing_inside pats' } } where doc_pat = ptext (sLit "In") <+> pprMatchContext ctxt diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 6b49391..9842d45 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -299,9 +299,10 @@ rnSrcWarnDecls _bound_names [] rnSrcWarnDecls bound_names decls = do { -- check for duplicates - ; mapM_ (\ (lrdr:lrdr':_) -> addLocErr lrdr (dupWarnDecl lrdr')) warn_rdr_dups - ; mapM (addLocM rn_deprec) decls `thenM` \ pairs_s -> - return (WarnSome ((concat pairs_s))) } + ; mapM_ (\ (L loc rdr:lrdr':_) -> addErrAt loc (dupWarnDecl lrdr' rdr)) + warn_rdr_dups + ; pairs_s <- mapM (addLocM rn_deprec) decls + ; return (WarnSome ((concat pairs_s))) } where rn_deprec (Warning rdr_name txt) -- ensures that the names are defined locally @@ -400,11 +401,10 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- The typechecker (not the renamer) checks that all -- the bindings are for the right class let - meth_doc = text "In the bindings in an instance declaration" meth_names = collectHsBindLocatedBinders mbinds (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty') in - checkDupRdrNames meth_doc meth_names `thenM_` + checkDupRdrNames meth_names `thenM_` -- Check that the same method is not given twice in the -- same instance decl instance C T where -- f x = ... @@ -424,10 +424,9 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- The typechecker (not the renamer) checks that all -- the declarations are for the right class let - at_doc = text "In the associated types of an instance declaration" at_names = map (head . tyClDeclNames . unLoc) ats in - checkDupRdrNames at_doc at_names `thenM_` + checkDupRdrNames at_names `thenM_` -- See notes with checkDupRdrNames for methods, above rnATInsts ats `thenM` \ (ats', at_fvs) -> @@ -521,7 +520,7 @@ standaloneDerivErr rnHsRuleDecl :: RuleDecl RdrName -> RnM (RuleDecl Name, FreeVars) rnHsRuleDecl (HsRule rule_name act vars lhs _fv_lhs rhs _fv_rhs) = bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $ - bindLocatedLocalsFV doc (map get_var vars) $ \ ids -> + bindLocatedLocalsFV (map get_var vars) $ \ ids -> do { (vars', fv_vars) <- mapFvRn rn_var (vars `zip` ids) -- NB: The binders in a rule are always Ids -- We don't (yet) support type variables @@ -661,7 +660,7 @@ rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, ; checkTc (h98_style || null (unLoc context)) (badGadtStupidTheta tycon) ; (tyvars', context', typats', derivs', deriv_fvs) - <- bindTyVarsRn data_doc tyvars $ \ tyvars' -> do + <- bindTyVarsRn tyvars $ \ tyvars' -> do -- Checks for distinct tyvars { typats' <- rnTyPats data_doc typatsMaybe ; context' <- rnContext data_doc context @@ -703,21 +702,21 @@ rnTyClDecl tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, -- "type" and "type instance" declarations rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdTyPats = typatsMaybe, tcdSynRhs = ty}) - = do { bindTyVarsRn syn_doc tyvars $ \ tyvars' -> do - -- Checks for distinct tyvars - { name' <- if isFamInstDecl tydecl - then lookupLocatedOccRn name -- may be imported family - else lookupLocatedTopBndrRn name - ; typats' <- rnTyPats syn_doc typatsMaybe - ; (ty', fvs) <- rnHsTypeFVs syn_doc ty - ; return (TySynonym {tcdLName = name', tcdTyVars = tyvars', - tcdTyPats = typats', tcdSynRhs = ty'}, - delFVs (map hsLTyVarName tyvars') $ - fvs `plusFV` - (if isFamInstDecl tydecl - then unitFV (unLoc name') -- type instance => use - else emptyFVs)) - } } + = bindTyVarsRn tyvars $ \ tyvars' -> do + { -- Checks for distinct tyvars + name' <- if isFamInstDecl tydecl + then lookupLocatedOccRn name -- may be imported family + else lookupLocatedTopBndrRn name + ; typats' <- rnTyPats syn_doc typatsMaybe + ; (ty', fvs) <- rnHsTypeFVs syn_doc ty + ; return (TySynonym { tcdLName = name', tcdTyVars = tyvars' + , tcdTyPats = typats', tcdSynRhs = ty'}, + delFVs (map hsLTyVarName tyvars') $ + fvs `plusFV` + (if isFamInstDecl tydecl + then unitFV (unLoc name') -- type instance => use + else emptyFVs)) + } where syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) @@ -728,7 +727,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, -- Tyvars scope over superclass context and method signatures ; (tyvars', context', fds', ats', ats_fvs, sigs') - <- bindTyVarsRn cls_doc tyvars $ \ tyvars' -> do + <- bindTyVarsRn tyvars $ \ tyvars' -> do -- Checks for distinct tyvars { context' <- rnContext cls_doc context ; fds' <- rnFds cls_doc fds @@ -742,7 +741,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs] - ; checkDupRdrNames sig_doc sig_rdr_names_w_locs + ; checkDupRdrNames sig_rdr_names_w_locs -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. -- The renamer *could* check this for class decls, but can't @@ -782,7 +781,6 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, ats_fvs) } where cls_doc = text "In the declaration for class" <+> ppr cname - sig_doc = text "In the signatures for class" <+> ppr cname badGadtStupidTheta :: Located RdrName -> SDoc badGadtStupidTheta _ @@ -834,7 +832,7 @@ rnConDecl decl@(ConDecl { con_name = name, con_qvars = tvs ; mb_doc' <- rnMbLHsDoc mb_doc - ; bindTyVarsRn doc new_tvs $ \new_tyvars -> do + ; bindTyVarsRn new_tvs $ \new_tyvars -> do { new_context <- rnContext doc cxt ; new_details <- rnConDeclDetails doc details ; (new_details', new_res_ty) <- rnConResult doc new_details res_ty @@ -892,7 +890,7 @@ rnConDeclDetails doc (RecCon fields) -- are usage occurences for associated types. -- rnFamily :: TyClDecl RdrName - -> (SDoc -> [LHsTyVarBndr RdrName] -> + -> ([LHsTyVarBndr RdrName] -> ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) -> RnM (TyClDecl Name, FreeVars)) -> RnM (TyClDecl Name, FreeVars) @@ -900,7 +898,7 @@ rnFamily :: TyClDecl RdrName rnFamily (tydecl@TyFamily {tcdFlavour = flavour, tcdLName = tycon, tcdTyVars = tyvars}) bindIdxVars = - do { bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do { + do { bindIdxVars tyvars $ \tyvars' -> do { ; tycon' <- lookupLocatedTopBndrRn tycon ; return (TyFamily {tcdFlavour = flavour, tcdLName = tycon', tcdTyVars = tyvars', tcdKind = tcdKind tydecl}, @@ -908,9 +906,6 @@ rnFamily (tydecl@TyFamily {tcdFlavour = flavour, } } rnFamily d _ = pprPanic "rnFamily" (ppr d) -family_doc :: Located RdrName -> SDoc -family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon) - -- Rename associated type declarations (in classes) -- -- * This can be family declarations and (default) type instances @@ -925,7 +920,7 @@ rnATs ats = mapFvRn (wrapLocFstM rn_at) ats rnTyClDecl tydecl rn_at _ = panic "RnSource.rnATs: invalid TyClDecl" - lookupIdxVars _ tyvars cont = + lookupIdxVars tyvars cont = do { checkForDups tyvars; ; tyvars' <- mapM lookupIdxVar tyvars ; cont tyvars' diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 62b778d..b739d6d 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -213,7 +213,7 @@ rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty -- of kind *. rnForAll doc exp forall_tyvars ctxt ty - = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> do + = bindTyVarsRn forall_tyvars $ \ new_tyvars -> do new_ctxt <- rnContext doc ctxt new_ty <- rnLHsType doc ty return (HsForAllTy exp new_tyvars new_ctxt new_ty) diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs index ad74133..90028bd 100644 --- a/compiler/typecheck/TcRnMonad.lhs +++ b/compiler/typecheck/TcRnMonad.lhs @@ -454,6 +454,7 @@ wrapLocSndM fn (L loc a) = return (b, L loc c) \end{code} +Reporting errors \begin{code} getErrsVar :: TcRn (TcRef Messages) @@ -468,49 +469,26 @@ addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg } failWith :: Message -> TcRn a failWith msg = addErr msg >> failM -addLocErr :: Located e -> (e -> Message) -> TcRn () -addLocErr (L loc e) fn = addErrAt loc (fn e) - addErrAt :: SrcSpan -> Message -> TcRn () -addErrAt loc msg = addLongErrAt loc msg empty - -addLongErrAt :: SrcSpan -> Message -> Message -> TcRn () -addLongErrAt loc msg extra - = do { traceTc (ptext (sLit "Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; - errs_var <- getErrsVar ; - rdr_env <- getGlobalRdrEnv ; - dflags <- getDOpts ; - let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ; - (warns, errs) <- readMutVar errs_var ; - writeMutVar errs_var (warns, errs `snocBag` err) } +-- addErrAt is mainly (exclusively?) used by the renamer, where +-- tidying is not an issue, but it's all lazy so the extra +-- work doesn't matter +addErrAt loc msg = do { ctxt <- getErrCtxt + ; tidy_env <- tcInitTidyEnv + ; err_info <- mkErrInfo tidy_env ctxt + ; addLongErrAt loc msg err_info } addErrs :: [(SrcSpan,Message)] -> TcRn () addErrs msgs = mapM_ add msgs where add (loc,msg) = addErrAt loc msg -addReport :: Message -> Message -> TcRn () -addReport msg extra_info = do loc <- getSrcSpanM; addReportAt loc msg extra_info - -addReportAt :: SrcSpan -> Message -> Message -> TcRn () -addReportAt loc msg extra_info - = do { errs_var <- getErrsVar ; - rdr_env <- getGlobalRdrEnv ; - dflags <- getDOpts ; - let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env) - msg extra_info } ; - (warns, errs) <- readMutVar errs_var ; - writeMutVar errs_var (warns `snocBag` warn, errs) } - addWarn :: Message -> TcRn () addWarn msg = addReport (ptext (sLit "Warning:") <+> msg) empty addWarnAt :: SrcSpan -> Message -> TcRn () addWarnAt loc msg = addReportAt loc (ptext (sLit "Warning:") <+> msg) empty -addLocWarn :: Located e -> (e -> Message) -> TcRn () -addLocWarn (L loc e) fn = addReportAt loc (fn e) empty - checkErr :: Bool -> Message -> TcRn () -- Add the error if the bool is False checkErr ok msg = unless ok (addErr msg) @@ -542,6 +520,38 @@ discardWarnings thing_inside \end{code} +%************************************************************************ +%* * + Shared error message stuff: renamer and typechecker +%* * +%************************************************************************ + +\begin{code} +addReport :: Message -> Message -> TcRn () +addReport msg extra_info = do loc <- getSrcSpanM; addReportAt loc msg extra_info + +addReportAt :: SrcSpan -> Message -> Message -> TcRn () +addReportAt loc msg extra_info + = do { errs_var <- getErrsVar ; + rdr_env <- getGlobalRdrEnv ; + dflags <- getDOpts ; + let { warn = mkLongWarnMsg loc (mkPrintUnqualified dflags rdr_env) + msg extra_info } ; + (warns, errs) <- readMutVar errs_var ; + writeMutVar errs_var (warns `snocBag` warn, errs) } + +addLongErrAt :: SrcSpan -> Message -> Message -> TcRn () +addLongErrAt loc msg extra + = do { traceTc (ptext (sLit "Adding error:") <+> (mkLocMessage loc (msg $$ extra))) ; + errs_var <- getErrsVar ; + rdr_env <- getGlobalRdrEnv ; + dflags <- getDOpts ; + let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ; + (warns, errs) <- readMutVar errs_var ; + writeMutVar errs_var (warns, errs `snocBag` err) } +\end{code} + + \begin{code} try_m :: TcRn r -> TcRn (Either IOEnvFailure r) -- Does try_m, with a debug-trace on failure @@ -674,8 +684,7 @@ failIfErrsM = ifErrsM failM (return ()) %************************************************************************ %* * - Context management and error message generation - for the type checker + Context management for the type checker %* * %************************************************************************ @@ -720,6 +729,12 @@ setInstCtxt (InstLoc _ src_loc ctxt) thing_inside = setSrcSpan src_loc (setErrCtxt ctxt thing_inside) \end{code} +%************************************************************************ +%* * + Error message generation (type checker) +%* * +%************************************************************************ + The addErrTc functions add an error message, but do not cause failure. The 'M' variants pass a TidyEnv that has already been used to tidy up the message; we then use it to tidy the context messages -- 1.7.10.4