[commit: ghc] master: Fix #8607. (e4afeed)
git at git.haskell.org
git at git.haskell.org
Fri Dec 27 03:39:38 UTC 2013
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/e4afeedc5b8ac0f48cbeac09aa702c8d10433cdb/ghc
>---------------------------------------------------------------
commit e4afeedc5b8ac0f48cbeac09aa702c8d10433cdb
Author: Richard Eisenberg <eir at cis.upenn.edu>
Date: Thu Dec 26 22:34:03 2013 -0500
Fix #8607.
The solution (after many false starts) is to change the behavior of
hsLTyClDeclBinders. The idea is that the locations of the names that
the parser generates should really be the names' locations, unlike
what was done in 1745779... But, when the renamer is creating Names
from the RdrNames, the locations stored in the Names should be the
declarations' locations. This is now achieved in hsLTyClDeclBinders,
which returns [Located name], but the location is that of the
*declaration*, not the name itself.
>---------------------------------------------------------------
e4afeedc5b8ac0f48cbeac09aa702c8d10433cdb
compiler/hsSyn/HsUtils.lhs | 52 +++++++++++++++++++++++--------------------
compiler/rename/RnEnv.lhs | 1 -
compiler/rename/RnNames.lhs | 10 ++++++---
3 files changed, 35 insertions(+), 28 deletions(-)
diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs
index bdbb5d4..bdc77c0 100644
--- a/compiler/hsSyn/HsUtils.lhs
+++ b/compiler/hsSyn/HsUtils.lhs
@@ -68,7 +68,7 @@ module HsUtils(
collectLStmtsBinders, collectStmtsBinders,
collectLStmtBinders, collectStmtBinders,
- hsLTyClDeclBinders, hsTyClDeclBinders, hsTyClDeclsBinders,
+ hsLTyClDeclBinders, hsTyClDeclsBinders,
hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
-- Collecting implicit binders
@@ -690,26 +690,25 @@ hsTyClDeclsBinders tycl_decls inst_decls
-------------------
hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
--- ^ Returns all the /binding/ names of the decl, along with their SrcLocs.
+-- ^ Returns all the /binding/ names of the decl.
-- The first one is guaranteed to be the name of the decl. For record fields
-- mentioned in multiple constructors, the SrcLoc will be from the first
--- occurence. We use the equality to filter out duplicate field names
-hsLTyClDeclBinders (L _ d) = hsTyClDeclBinders d
-
--------------------
-hsTyClDeclBinders :: Eq name => TyClDecl name -> [Located name]
-hsTyClDeclBinders (FamDecl { tcdFam = FamilyDecl { fdLName = name} }) = [name]
-hsTyClDeclBinders (ForeignType {tcdLName = name}) = [name]
-hsTyClDeclBinders (SynDecl {tcdLName = name}) = [name]
-
-hsTyClDeclBinders (ClassDecl { tcdLName = cls_name, tcdSigs = sigs
- , tcdATs = ats })
- = cls_name :
- map (fdLName . unLoc) ats ++
- [n | L _ (TypeSig ns _) <- sigs, n <- ns]
-
-hsTyClDeclBinders (DataDecl { tcdLName = name, tcdDataDefn = defn })
- = name : hsDataDefnBinders defn
+-- occurence. We use the equality to filter out duplicate field names.
+-- The @SrcLoc at s are the locations of the /declaration/, not just the name.
+
+-- The re-mangling of the SrcLocs here are to keep good error messages while
+-- avoiding #8607.
+hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
+ = [L loc name]
+hsLTyClDeclBinders (L loc (ForeignType { tcdLName = L _ name })) = [L loc name]
+hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) = [L loc name]
+hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name
+ , tcdSigs = sigs, tcdATs = ats }))
+ = L loc cls_name :
+ [ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
+ [ L mem_loc mem_name | L mem_loc (TypeSig ns _) <- sigs, L _ mem_name <- ns ]
+hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn }))
+ = L loc name : hsDataDefnBinders defn
-------------------
hsInstDeclBinders :: Eq name => InstDecl name -> [Located name]
@@ -719,32 +718,37 @@ hsInstDeclBinders (DataFamInstD { dfid_inst = fi }) = hsDataFamInstBinders fi
hsInstDeclBinders (TyFamInstD {}) = []
-------------------
+-- the SrcLoc returned are for the whole declarations, not just the names
hsDataFamInstBinders :: Eq name => DataFamInstDecl name -> [Located name]
hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
= hsDataDefnBinders defn
-- There can't be repeated symbols because only data instances have binders
-------------------
+-- the SrcLoc returned are for the whole declarations, not just the names
hsDataDefnBinders :: Eq name => HsDataDefn name -> [Located name]
hsDataDefnBinders (HsDataDefn { dd_cons = cons }) = hsConDeclsBinders cons
-- See Note [Binders in family instances]
-------------------
hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name]
- -- See hsTyClDeclBinders for what this does
+ -- See hsLTyClDeclBinders for what this does
-- The function is boringly complicated because of the records
-- And since we only have equality, we have to be a little careful
hsConDeclsBinders cons
= snd (foldl do_one ([], []) cons)
where
- do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname, con_details = RecCon flds }))
- = (map unLoc new_flds ++ flds_seen, lname : new_flds ++ acc)
+ do_one (flds_seen, acc) (L loc (ConDecl { con_name = L _ name
+ , con_details = RecCon flds }))
+ = (map unLoc new_flds ++ flds_seen, L loc name : new_flds ++ acc)
where
+ -- don't re-mangle the location of field names, because we don't
+ -- have a record of the full location of the field declaration anyway
new_flds = filterOut (\f -> unLoc f `elem` flds_seen)
(map cd_fld_name flds)
- do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname }))
- = (flds_seen, lname:acc)
+ do_one (flds_seen, acc) (L loc (ConDecl { con_name = L _ name }))
+ = (flds_seen, L loc name : acc)
\end{code}
Note [Binders in family instances]
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index f7dcdc8..c49652b 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -134,7 +134,6 @@ newTopSrcBinder (L loc rdr_name)
-- have an arbitrary mixture of external core definitions in a single module,
-- (apart from module-initialisation issues, perhaps).
; newGlobalBinder rdr_mod rdr_occ loc }
- --TODO, should pass the whole span
| otherwise
= do { unless (not (isQual rdr_name))
diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs
index 93a2396..64e38f5 100644
--- a/compiler/rename/RnNames.lhs
+++ b/compiler/rename/RnNames.lhs
@@ -500,19 +500,23 @@ getLocalNonValBinders fixity_env
; return (envs, new_bndrs) } }
where
for_hs_bndrs :: [Located RdrName]
- for_hs_bndrs = [nm | L _ (ForeignImport nm _ _ _) <- foreign_decls]
+ for_hs_bndrs = [ L decl_loc (unLoc nm)
+ | L decl_loc (ForeignImport nm _ _ _) <- foreign_decls]
-- In a hs-boot file, the value binders come from the
-- *signatures*, and there should be no foreign binders
- hs_boot_sig_bndrs = [n | L _ (TypeSig ns _) <- val_sigs, n <- ns]
+ hs_boot_sig_bndrs = [ L decl_loc (unLoc n)
+ | L decl_loc (TypeSig ns _) <- val_sigs, n <- ns]
ValBindsIn _ val_sigs = val_binds
+ -- the SrcSpan attached to the input should be the span of the
+ -- declaration, not just the name
new_simple :: Located RdrName -> RnM AvailInfo
new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name
; return (Avail nm) }
new_tc tc_decl -- NOT for type/data instances
- = do { let bndrs = hsTyClDeclBinders (unLoc tc_decl)
+ = do { let bndrs = hsLTyClDeclBinders tc_decl
; names@(main_name : _) <- mapM newTopSrcBinder bndrs
; return (AvailTC main_name names) }
More information about the ghc-commits
mailing list