Implement sequential name lookup properly
authorMatthew Pickering <matthewtpickering@gmail.com>
Thu, 4 May 2017 18:15:43 +0000 (14:15 -0400)
committerBen Gamari <ben@smart-cactus.org>
Thu, 4 May 2017 22:20:45 +0000 (18:20 -0400)
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

compiler/typecheck/TcRnExports.hs
testsuite/tests/module/T13622.hs [new file with mode: 0644]
testsuite/tests/module/all.T

index 2da1862..1389e74 100644 (file)
@@ -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 (file)
index 0000000..037283e
--- /dev/null
@@ -0,0 +1,5 @@
+module Bug (Bits(Bits)) where
+
+import qualified Data.Bits as Bits
+
+newtype Bits = Bits Int
index 6d05c77..5404f19 100644 (file)
@@ -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, [''])