[commit: ghc] master: Implement sequential name lookup properly (1829d26)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/1829d265662ca8d052df3e5df1aa1137b19e39ce/ghc

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

commit 1829d265662ca8d052df3e5df1aa1137b19e39ce
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


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

1829d265662ca8d052df3e5df1aa1137b19e39ce
 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 2da1862..1389e74 100644
--- a/compiler/typecheck/TcRnExports.hs
+++ b/compiler/typecheck/TcRnExports.hs
@@ -445,7 +445,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
@@ -461,6 +461,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
@@ -580,19 +591,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, [''])