Commit df8b00e0 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

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.
parent 1b62d143
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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
......
......@@ -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'
......
......@@ -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)
......
......@@ -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}