[commit: ghc] ghc-8.2: Implement sequential name lookup properly (0c84569)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.2
Link       : http://ghc.haskell.org/trac/ghc/changeset/0c845697e054b5e30e76a801c7ebc78238c8268a/ghc

>---------------------------------------------------------------

commit 0c845697e054b5e30e76a801c7ebc78238c8268a
Author: Matthew Pickering <matthewtpickering at gmail.com>
Date:   Thu May 4 14:15:43 2017 -0400

    Implement sequential name lookup properly
    
    Previously we would run all the monadic actions and then
    combine their results. This caused problems if later actions
    raised errors but earlier lookups suceeded. We only want to run later
    lookups if the earlier ones fail.
    
    Fixes #13622
    
    Reviewers: RyanGlScott, austin, bgamari, simonpj
    
    Reviewed By: simonpj
    
    Subscribers: simonpj, rwbarton, thomie
    
    GHC Trac Issues: #13622
    
    Differential Revision: https://phabricator.haskell.org/D3515
    
    (cherry picked from commit 1829d265662ca8d052df3e5df1aa1137b19e39ce)


>---------------------------------------------------------------

0c845697e054b5e30e76a801c7ebc78238c8268a
 compiler/typecheck/TcRnExports.hs | 26 +++++++++++++++++++-------
 testsuite/tests/module/T13622.hs  |  5 +++++
 testsuite/tests/module/all.T      |  1 +
 3 files changed, 25 insertions(+), 7 deletions(-)

diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs
index 322de93..fa4b4bc 100644
--- a/compiler/typecheck/TcRnExports.hs
+++ b/compiler/typecheck/TcRnExports.hs
@@ -440,7 +440,7 @@ lookupChildrenExport parent rdr_items =
           let bareName = unLoc n
               lkup v = lookupExportChild parent (setRdrNameSpace bareName v)
 
-          name <-  fmap mconcat . mapM lkup $
+          name <-  tryChildLookupResult $ map lkup $
                     (choosePossibleNamespaces (rdrNameSpace bareName))
 
           -- Default to data constructors for slightly better error
@@ -456,6 +456,17 @@ lookupChildrenExport parent rdr_items =
             FoundName name -> return $ Left (L (getLoc n) name)
             NameErr err_msg -> reportError err_msg >> failM
 
+tryChildLookupResult :: [RnM ChildLookupResult] -> RnM ChildLookupResult
+tryChildLookupResult [x] = x
+tryChildLookupResult (x:xs) = do
+  res <- x
+  case res of
+    FoundFL {} -> return res
+    FoundName {} -> return res
+    NameErr {}   -> return res
+    _ -> tryChildLookupResult xs
+tryChildLookupResult _ = panic "tryChildLookupResult:empty list"
+
 
 
 -- | Also captures the current context
@@ -575,19 +586,20 @@ data DisambigInfo
 instance Monoid DisambigInfo where
   mempty = NoOccurrence
   -- This is the key line: We prefer disambiguated occurrences to other
-  -- names.
-  UniqueOccurrence _ `mappend` DisambiguatedOccurrence g' = DisambiguatedOccurrence g'
-  DisambiguatedOccurrence g' `mappend` UniqueOccurrence _ = DisambiguatedOccurrence g'
+  -- names. Notice that two disambiguated occurences are not ambiguous as
+  -- there is an internal invariant that a list of `DisambigInfo` arises
+  -- from a list of GREs which all have the same OccName. Thus, if we ever
+  -- have two DisambiguatedOccurences then they must have arisen from the
+  -- same GRE and hence it's safe to discard one.
+  _ `mappend` DisambiguatedOccurrence g' = DisambiguatedOccurrence g'
+  DisambiguatedOccurrence g' `mappend` _ = DisambiguatedOccurrence g'
 
 
   NoOccurrence `mappend` m = m
   m `mappend` NoOccurrence = m
   UniqueOccurrence g `mappend` UniqueOccurrence g' = AmbiguousOccurrence [g, g']
   UniqueOccurrence g `mappend` AmbiguousOccurrence gs = AmbiguousOccurrence (g:gs)
-  DisambiguatedOccurrence g `mappend` DisambiguatedOccurrence g'  = AmbiguousOccurrence [g, g']
-  DisambiguatedOccurrence g `mappend` AmbiguousOccurrence gs = AmbiguousOccurrence (g:gs)
   AmbiguousOccurrence gs `mappend` UniqueOccurrence g' = AmbiguousOccurrence (g':gs)
-  AmbiguousOccurrence gs `mappend` DisambiguatedOccurrence g' = AmbiguousOccurrence (g':gs)
   AmbiguousOccurrence gs `mappend` AmbiguousOccurrence gs' = AmbiguousOccurrence (gs ++ gs')
 
 
diff --git a/testsuite/tests/module/T13622.hs b/testsuite/tests/module/T13622.hs
new file mode 100644
index 0000000..037283e
--- /dev/null
+++ b/testsuite/tests/module/T13622.hs
@@ -0,0 +1,5 @@
+module Bug (Bits(Bits)) where
+
+import qualified Data.Bits as Bits
+
+newtype Bits = Bits Int
diff --git a/testsuite/tests/module/all.T b/testsuite/tests/module/all.T
index 6d05c77..5404f19 100644
--- a/testsuite/tests/module/all.T
+++ b/testsuite/tests/module/all.T
@@ -283,4 +283,5 @@ test('T11970A', [], multimod_compile, ['T11970A','-Wunused-imports'])
 test('T11970B', normal, compile_fail, [''])
 test('MultiExport', normal, compile, [''])
 test('T13528', normal, compile, [''])
+test('T13622', normal, compile, [''])