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

3 files changed, 25 insertions, 7 deletions

diff --git a/compiler/typecheck/TcRnExports.hs b/compiler/typecheck/TcRnExports.hs
index 2da1862f98..1389e745df 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 0000000000..037283ee57
--- /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 6d05c77a9e..5404f19e4a 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, [''])