Renamer now preserves location for IEThingWith list items
authorAlan Zimmerman <alan.zimm@gmail.com>
Fri, 15 Sep 2017 18:35:51 +0000 (14:35 -0400)
committerBen Gamari <ben@smart-cactus.org>
Fri, 15 Sep 2017 18:35:52 +0000 (14:35 -0400)
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

compiler/typecheck/TcRnExports.hs
testsuite/tests/parser/should_compile/T14189.hs [new file with mode: 0644]
testsuite/tests/parser/should_compile/T14189.stderr [new file with mode: 0644]
testsuite/tests/parser/should_compile/all.T

index 7f677a4..fd099d0 100644 (file)
@@ -302,28 +302,27 @@ 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))
 
 
     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 GhcPs -> LIEWrappedName RdrName
                   -> RnM (Located Name, [Name], [FieldLabel])
     lookup_ie_all ie (L l rdr) =
@@ -404,8 +403,8 @@ isDoc _ = False
 
 
 
-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
@@ -420,11 +419,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 = lookupSubBndrOcc_helper False True
                         parent (setRdrNameSpace bareName v)
 
@@ -446,9 +445,11 @@ lookupChildrenExport parent rdr_items =
           traceRn "lookupChildrenExport" (ppr name')
 
           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 _p name -> return $ Left (L (getLoc n) name)
+            FoundName _p name -> return $ Left (replaceLWrappedName n name)
             NameErr err_msg -> reportError err_msg >> failM
             IncorrectParent p g td gs -> do
               mkDcErrMsg p g td gs >>= reportError
diff --git a/testsuite/tests/parser/should_compile/T14189.hs b/testsuite/tests/parser/should_compile/T14189.hs
new file mode 100644 (file)
index 0000000..c26ebd7
--- /dev/null
@@ -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 (file)
index 0000000..53e4a6f
--- /dev/null
@@ -0,0 +1,135 @@
+
+==================== Renamer ====================
+
+(Just
+ ((,,,)
+  (HsGroup
+   (ValBindsOut
+    []
+    [])
+   []
+   [(TyClGroup
+     [({ T14189.hs:6:1-42 }
+       (DataDecl
+        ({ T14189.hs:6:6-11 }
+         {Name: T14189.MyType})
+        (HsQTvs
+         []
+         []
+         {NameSet:
+          []})
+        (Prefix)
+        (HsDataDefn
+         (DataType)
+         ({ <no location info> }
+          [])
+         (Nothing)
+         (Nothing)
+         [({ T14189.hs:6:15-20 }
+           (ConDeclH98
+            ({ T14189.hs:6:15-16 }
+             {Name: T14189.MT})
+            (Nothing)
+            (Just
+             ({ <no location info> }
+              []))
+            (PrefixCon
+             [({ T14189.hs:6:18-20 }
+               (HsTyVar
+                (NotPromoted)
+                ({ T14189.hs:6:18-20 }
+                 {Name: GHC.Types.Int})))])
+            (Nothing)))
+         ,({ T14189.hs:6:24-25 }
+           (ConDeclH98
+            ({ T14189.hs:6:24-25 }
+             {Name: T14189.NT})
+            (Nothing)
+            (Just
+             ({ <no location info> }
+              []))
+            (PrefixCon
+             [])
+            (Nothing)))
+         ,({ T14189.hs:6:29-42 }
+           (ConDeclH98
+            ({ T14189.hs:6:29 }
+             {Name: T14189.F})
+            (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: T14189.f}))]
+                 ({ T14189.hs:6:38-40 }
+                  (HsTyVar
+                   (NotPromoted)
+                   ({ T14189.hs:6:38-40 }
+                    {Name: GHC.Types.Int})))
+                 (Nothing)))]))
+            (Nothing)))]
+         ({ <no location info> }
+          []))
+        (True)
+        {NameSet:
+         [{Name: GHC.Types.Int}]}))]
+     []
+     [])]
+   []
+   []
+   []
+   []
+   []
+   []
+   []
+   []
+   [])
+  [({ T14189.hs:1:8-13 }
+    (ImportDecl
+     (NoSourceText)
+     ({ T14189.hs:1:8-13 }
+      {ModuleName: Prelude})
+     (Nothing)
+     (False)
+     (False)
+     (False)
+     (True)
+     (Nothing)
+     (Nothing)))]
+  (Just
+   [((,)
+     ({ T14189.hs:3:3-15 }
+      (IEThingWith
+       ({ T14189.hs:3:3-8 }
+        (IEName
+         ({ T14189.hs:3:3-8 }
+          {Name: T14189.MyType})))
+       (NoIEWildcard)
+       [({ T14189.hs:3:13-14 }
+         (IEName
+          ({ T14189.hs:3:13-14 }
+           {Name: T14189.NT})))]
+       [({ T14189.hs:3:11 }
+         (FieldLabel
+          {FastString: "f"}
+          (False)
+          {Name: T14189.f}))]))
+     [(AvailTC
+       {Name: T14189.MyType}
+       [{Name: T14189.MyType}
+       ,{Name: T14189.NT}]
+       [(FieldLabel
+         {FastString: "f"}
+         (False)
+         {Name: T14189.f})])])])
+  (Nothing)))
+
+
index a9d6830..c008bd4 100644 (file)
@@ -108,3 +108,4 @@ test('DumpParsedAst',      normal, compile, ['-dsuppress-uniques -ddump-parsed-a
 test('DumpRenamedAst',     normal, compile, ['-dsuppress-uniques -ddump-rn-ast'])
 test('DumpTypecheckedAst', normal, compile, ['-dsuppress-uniques -ddump-tc-ast'])
 test('T13747', normal, compile, [''])
+test('T14189',     normal, compile, ['-dsuppress-uniques -ddump-rn-ast'])