Fix #8607.
authorRichard Eisenberg <eir@cis.upenn.edu>
Fri, 27 Dec 2013 03:34:03 +0000 (22:34 -0500)
committerRichard Eisenberg <eir@cis.upenn.edu>
Fri, 27 Dec 2013 03:34:03 +0000 (22:34 -0500)
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.

compiler/hsSyn/HsUtils.lhs
compiler/rename/RnEnv.lhs
compiler/rename/RnNames.lhs

index bdbb5d4..bdc77c0 100644 (file)
@@ -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@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]
index f7dcdc8..c49652b 100644 (file)
@@ -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))
index 93a2396..64e38f5 100644 (file)
@@ -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) }