[commit: ghc] ghc-8.2: Renamer now preserves location for IEThingWith list items (a153d2f)
git at git.haskell.org
git at git.haskell.org
Tue Sep 19 21:10:35 UTC 2017
Repository : ssh://git@git.haskell.org/ghc
On branch : ghc-8.2
Link : http://ghc.haskell.org/trac/ghc/changeset/a153d2f26263181440156380559a90ab792d8260/ghc
>---------------------------------------------------------------
commit a153d2f26263181440156380559a90ab792d8260
Author: Alan Zimmerman <alan.zimm at gmail.com>
Date: Fri Sep 15 14:35:51 2017 -0400
Renamer now preserves location for IEThingWith list items
Prior to this, in the RenamedSource for
module Renaming.RenameInExportedType
(
MyType (NT)
) where
data MyType = MT Int | NT
The (NT) was given the location of MyType earlier on the line in the
export list.
Also the location was discarded for any field labels, and replaced with
a `noLoc`.
Test Plan: ./validate
Reviewers: bgamari, austin
Reviewed By: bgamari
Subscribers: rwbarton, thomie
GHC Trac Issues: #14189
Differential Revision: https://phabricator.haskell.org/D3968
(cherry picked from commit 9498c50ef5af2680305e0aaea6f32439cacc3da0)
>---------------------------------------------------------------
a153d2f26263181440156380559a90ab792d8260
compiler/typecheck/TcRnExports.hs | 35 +++++----
testsuite/tests/parser/should_compile/T14189.hs | 6 ++
.../tests/parser/should_compile/T14189.stderr | 89 ++++++++++++++++++++++
testsuite/tests/parser/should_compile/all.T | 1 +
4 files changed, 115 insertions(+), 16 deletions(-)
diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs
index fa4b4bc..851d848 100644
--- a/compiler/typecheck/TcRnExports.hs
+++ b/compiler/typecheck/TcRnExports.hs
@@ -293,11 +293,10 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
NoIEWildcard -> return (lname, [], [])
IEWildcard _ -> lookup_ie_all ie l
let name = unLoc lname
- subs' = map (replaceLWrappedName l . unLoc) subs
- return (IEThingWith (replaceLWrappedName l name) wc subs'
- (map noLoc (flds ++ all_flds)),
+ return (IEThingWith (replaceLWrappedName l name) wc subs
+ (flds ++ (map noLoc all_flds)),
AvailTC name (name : avails ++ all_avail)
- (flds ++ all_flds))
+ (map unLoc flds ++ all_flds))
@@ -305,16 +304,17 @@ exports_from_avail (Just (L _ rdr_items)) rdr_env imports this_mod
lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier
lookup_ie_with :: LIEWrappedName RdrName -> [LIEWrappedName RdrName]
- -> RnM (Located Name, [Located Name], [Name], [FieldLabel])
+ -> RnM (Located Name, [LIEWrappedName Name], [Name],
+ [Located FieldLabel])
lookup_ie_with (L l rdr) sub_rdrs
= do name <- lookupGlobalOccRn $ ieWrappedName rdr
- (non_flds, flds) <- lookupChildrenExport name
- (map ieLWrappedName sub_rdrs)
+ (non_flds, flds) <- lookupChildrenExport name sub_rdrs
if isUnboundName name
then return (L l name, [], [name], [])
else return (L l name, non_flds
- , map unLoc non_flds
- , map unLoc flds)
+ , map (ieWrappedName . unLoc) non_flds
+ , flds)
+
lookup_ie_all :: IE RdrName -> LIEWrappedName RdrName
-> RnM (Located Name, [Name], [FieldLabel])
lookup_ie_all ie (L l rdr) =
@@ -417,8 +417,8 @@ instance Monoid ChildLookupResult where
FoundName n1 `mappend` _ = FoundName n1
FoundFL fls `mappend` _ = FoundFL fls
-lookupChildrenExport :: Name -> [Located RdrName]
- -> RnM ([Located Name], [Located FieldLabel])
+lookupChildrenExport :: Name -> [LIEWrappedName RdrName]
+ -> RnM ([LIEWrappedName Name], [Located FieldLabel])
lookupChildrenExport parent rdr_items =
do
xs <- mapAndReportM doOne rdr_items
@@ -433,11 +433,11 @@ lookupChildrenExport parent rdr_items =
| ns == tcName = [dataName, tcName]
| otherwise = [ns]
-- Process an individual child
- doOne :: Located RdrName
- -> RnM (Either (Located Name) (Located FieldLabel))
+ doOne :: LIEWrappedName RdrName
+ -> RnM (Either (LIEWrappedName Name) (Located FieldLabel))
doOne n = do
- let bareName = unLoc n
+ let bareName = (ieWrappedName . unLoc) n
lkup v = lookupExportChild parent (setRdrNameSpace bareName v)
name <- tryChildLookupResult $ map lkup $
@@ -451,9 +451,12 @@ lookupChildrenExport parent rdr_items =
else setRdrNameSpace bareName dataName
case name of
- NameNotFound -> Left . L (getLoc n) <$> reportUnboundName unboundName
+ NameNotFound -> do { ub <- reportUnboundName unboundName
+ ; let l = getLoc n
+ ; return (Left (L l (IEName (L l ub))))}
+
FoundFL fls -> return $ Right (L (getLoc n) fls)
- FoundName name -> return $ Left (L (getLoc n) name)
+ FoundName name -> return $ Left (replaceLWrappedName n name)
NameErr err_msg -> reportError err_msg >> failM
tryChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult
diff --git a/testsuite/tests/parser/should_compile/T14189.hs b/testsuite/tests/parser/should_compile/T14189.hs
new file mode 100644
index 0000000..c26ebd7
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T14189.hs
@@ -0,0 +1,6 @@
+module T14189
+ (
+ MyType (f,NT)
+ ) where
+
+data MyType = MT Int | NT | F { f :: Int }
diff --git a/testsuite/tests/parser/should_compile/T14189.stderr b/testsuite/tests/parser/should_compile/T14189.stderr
new file mode 100644
index 0000000..a2c7d92
--- /dev/null
+++ b/testsuite/tests/parser/should_compile/T14189.stderr
@@ -0,0 +1,89 @@
+
+==================== Renamer ====================
+
+(HsGroup
+ (ValBindsOut
+ []
+ [])
+ []
+ [
+ (TyClGroup
+ [
+ ({ T14189.hs:6:1-42 }
+ (DataDecl
+ ({ T14189.hs:6:6-11 }{Name: main:T14189.MyType{tc}})
+ (HsQTvs
+ []
+ [] {NameSet:
+ []})
+ (Prefix)
+ (HsDataDefn
+ (DataType)
+ ({ <no location info> }
+ [])
+ (Nothing)
+ (Nothing)
+ [
+ ({ T14189.hs:6:15-20 }
+ (ConDeclH98
+ ({ T14189.hs:6:15-16 }{Name: main:T14189.MT{d}})
+ (Nothing)
+ (Just
+ ({ <no location info> }
+ []))
+ (PrefixCon
+ [
+ ({ T14189.hs:6:18-20 }
+ (HsTyVar
+ (NotPromoted)
+ ({ T14189.hs:6:18-20 }{Name: ghc-prim:GHC.Types.Int{(w) tc}})))])
+ (Nothing))),
+ ({ T14189.hs:6:24-25 }
+ (ConDeclH98
+ ({ T14189.hs:6:24-25 }{Name: main:T14189.NT{d}})
+ (Nothing)
+ (Just
+ ({ <no location info> }
+ []))
+ (PrefixCon
+ [])
+ (Nothing))),
+ ({ T14189.hs:6:29-42 }
+ (ConDeclH98
+ ({ T14189.hs:6:29 }{Name: main:T14189.F{d}})
+ (Nothing)
+ (Just
+ ({ <no location info> }
+ []))
+ (RecCon
+ ({ T14189.hs:6:31-42 }
+ [
+ ({ T14189.hs:6:33-40 }
+ (ConDeclField
+ [
+ ({ T14189.hs:6:33 }
+ (FieldOcc
+ ({ T14189.hs:6:33 }
+ (Unqual {OccName: f})) {Name: main:T14189.f{v}}))]
+ ({ T14189.hs:6:38-40 }
+ (HsTyVar
+ (NotPromoted)
+ ({ T14189.hs:6:38-40 }{Name: ghc-prim:GHC.Types.Int{(w) tc}})))
+ (Nothing)))]))
+ (Nothing)))]
+ ({ <no location info> }
+ []))
+ (True) {NameSet:
+ [{Name: ghc-prim:GHC.Types.Int{(w) tc}}]}))]
+ []
+ [])]
+ []
+ []
+ []
+ []
+ []
+ []
+ []
+ []
+ [])
+
diff --git a/testsuite/tests/parser/should_compile/all.T b/testsuite/tests/parser/should_compile/all.T
index 2059979..597da02 100644
--- a/testsuite/tests/parser/should_compile/all.T
+++ b/testsuite/tests/parser/should_compile/all.T
@@ -107,3 +107,4 @@ test('T10582', expect_broken(10582), compile, [''])
test('DumpParsedAst', normal, compile, ['-dsuppress-uniques -ddump-parsed-ast'])
test('DumpRenamedAst', normal, compile, ['-dsuppress-uniques -ddump-rn-ast'])
test('DumpTypecheckedAst', normal, compile, ['-dsuppress-uniques -ddump-tc-ast'])
+test('T14189', normal, compile, ['-dsuppress-uniques -ddump-rn-ast'])
More information about the ghc-commits
mailing list