Fix lookupGlobalOccRn_maybe sometimes reporting an error

In some cases it was possible for lookupGlobalOccRn_maybe to return an
error, when it should be returning a Nothing. If it called
lookupExactOcc_either when there were no matching GlobalRdrElts in the
otherwise case, it would return an error message. This could be caused
when lookupThName_maybe in Template Haskell was looking in different
namespaces (thRdrNameGuesses), guessing different namespaces that the
name wasn't guaranteed to be found in.

However, by addressing this some more accurate errors were being lost in
the conversion to Maybes. So some of the lookup* functions have been
shuffled about so that errors should always be ignored in
lookup*_maybes, and propagated otherwise.

This fixes #18263

6 files changed, 136 insertions, 62 deletions

diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index 7ef776cc99..062a60088d 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -15,7 +15,7 @@ module GHC.Rename.Env (
         lookupLocalOccThLvl_maybe, lookupLocalOccRn,
         lookupTypeOccRn,
         lookupGlobalOccRn, lookupGlobalOccRn_maybe,
-        lookupOccRn_overloaded, lookupGlobalOccRn_overloaded, lookupExactOcc,
+        lookupOccRn_overloaded, lookupGlobalOccRn_overloaded,
 
         ChildLookupResult(..),
         lookupSubBndrOcc_helper,
@@ -237,16 +237,6 @@ terribly efficient, but there seems to be no better way.
 -- Can be made to not be exposed
 -- Only used unwrapped in rnAnnProvenance
 lookupTopBndrRn :: RdrName -> RnM Name
-lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n
-                       case nopt of
-                         Just n' -> return n'
-                         Nothing -> do traceRn "lookupTopBndrRn fail" (ppr n)
-                                       unboundName WL_LocalTop n
-
-lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)
-lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn
-
-lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name)
 -- Look up a top-level source-code binder.   We may be looking up an unqualified 'f',
 -- and there may be several imported 'f's too, which must not confuse us.
 -- For example, this is OK:
@@ -257,14 +247,8 @@ lookupTopBndrRn_maybe :: RdrName -> RnM (Maybe Name)
 --
 -- A separate function (importsFromLocalDecls) reports duplicate top level
 -- decls, so here it's safe just to choose an arbitrary one.
---
--- There should never be a qualified name in a binding position in Haskell,
--- but there can be if we have read in an external-Core file.
--- The Haskell parser checks for the illegal qualified name in Haskell
--- source files, so we don't need to do so here.
-
-lookupTopBndrRn_maybe rdr_name =
-  lookupExactOrOrig rdr_name Just $
+lookupTopBndrRn rdr_name =
+  lookupExactOrOrig rdr_name id $
     do  {  -- Check for operators in type or class declarations
            -- See Note [Type and class operator definitions]
           let occ = rdrNameOcc rdr_name
@@ -274,25 +258,19 @@ lookupTopBndrRn_maybe rdr_name =
 
         ; env <- getGlobalRdrEnv
         ; case filter isLocalGRE (lookupGRE_RdrName rdr_name env) of
-            [gre] -> return (Just (gre_name gre))
-            _     -> return Nothing  -- Ambiguous (can't happen) or unbound
+            [gre] -> return (gre_name gre)
+            _     -> do -- Ambiguous (can't happen) or unbound
+                        traceRn "lookupTopBndrRN fail" (ppr rdr_name)
+                        unboundName WL_LocalTop rdr_name
     }
 
------------------------------------------------
--- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].
--- This adds an error if the name cannot be found.
-lookupExactOcc :: Name -> RnM Name
-lookupExactOcc name
-  = do { result <- lookupExactOcc_either name
-       ; case result of
-           Left err -> do { addErr err
-                          ; return name }
-           Right name' -> return name' }
+lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)
+lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn
 
 -- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].
--- This never adds an error, but it may return one.
+-- This never adds an error, but it may return one, see
+-- Note [Errors in lookup functions]
 lookupExactOcc_either :: Name -> RnM (Either MsgDoc Name)
--- See Note [Looking up Exact RdrNames]
 lookupExactOcc_either name
   | Just thing <- wiredInNameTyThing_maybe name
   , Just tycon <- case thing of
@@ -333,16 +311,11 @@ lookupExactOcc_either name
                             ; th_topnames <- readTcRef th_topnames_var
                             ; if name `elemNameSet` th_topnames
                               then return (Right name)
-                              else return (Left exact_nm_err)
+                              else return (Left (exactNameErr name))
                             }
                        }
            gres -> return (Left (sameNameErr gres))   -- Ugh!  See Note [Template Haskell ambiguity]
        }
-  where
-    exact_nm_err = hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))
-                      2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), "
-                              , text "perhaps via newName, but did not bind it"
-                              , text "If that's it, then -ddump-splices might be useful" ])
 
 sameNameErr :: [GlobalRdrElt] -> MsgDoc
 sameNameErr [] = panic "addSameNameErr: empty list"
@@ -429,15 +402,67 @@ lookupConstructorFields con_name
 
 
 -- In CPS style as `RnM r` is monadic
+-- Reports an error if the name is an Exact or Orig and it can't find the name
+-- Otherwise if it is not an Exact or Orig, returns k
 lookupExactOrOrig :: RdrName -> (Name -> r) -> RnM r -> RnM r
 lookupExactOrOrig rdr_name res k
+  = do { men <- lookupExactOrOrig_base rdr_name
+       ; case men of
+          FoundExactOrOrig n -> return (res n)
+          ExactOrOrigError e ->
+            do { addErr e
+               ; return (res (mkUnboundNameRdr rdr_name)) }
+          NotExactOrOrig     -> k }
+
+-- Variant of 'lookupExactOrOrig' that does not report an error
+-- See Note [Errors in lookup functions]
+-- Calls k if the name is neither an Exact nor Orig
+lookupExactOrOrig_maybe :: RdrName -> (Maybe Name -> r) -> RnM r -> RnM r
+lookupExactOrOrig_maybe rdr_name res k
+  = do { men <- lookupExactOrOrig_base rdr_name
+       ; case men of
+           FoundExactOrOrig n -> return (res (Just n))
+           ExactOrOrigError _ -> return (res Nothing)
+           NotExactOrOrig     -> k }
+
+data ExactOrOrigResult = FoundExactOrOrig Name -- ^ Found an Exact Or Orig Name
+                       | ExactOrOrigError MsgDoc -- ^ The RdrName was an Exact
+                                                 -- or Orig, but there was an
+                                                 -- error looking up the Name
+                       | NotExactOrOrig -- ^ The RdrName is neither an Exact nor
+                                        -- Orig
+
+-- Does the actual looking up an Exact or Orig name, see 'ExactOrOrigResult'
+lookupExactOrOrig_base :: RdrName -> RnM ExactOrOrigResult
+lookupExactOrOrig_base rdr_name
   | Just n <- isExact_maybe rdr_name   -- This happens in derived code
-  = res <$> lookupExactOcc n
+  = cvtEither <$> lookupExactOcc_either n
   | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
-  = res <$> lookupOrig rdr_mod rdr_occ
-  | otherwise = k
+  = FoundExactOrOrig <$> lookupOrig rdr_mod rdr_occ
+  | otherwise = return NotExactOrOrig
+  where
+    cvtEither (Left e)  = ExactOrOrigError e
+    cvtEither (Right n) = FoundExactOrOrig n
+
+
+{- Note [Errors in lookup functions]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Many of these lookup functions will attach an error if it can't find the Name it
+is trying to lookup. However there are also _maybe and _either variants for many
+of these functions.
 
+These variants should *not* attach any errors, as there are
+places where we want to attempt looking up a name, but it's not the end of the
+world if we don't find it.
 
+For example, see lookupThName_maybe: It calls lookupGlobalOccRn_maybe multiple
+times for varying names in different namespaces. lookupGlobalOccRn_maybe should
+therefore never attach an error, instead just return a Nothing.
+
+For these _maybe/_either variant functions then, avoid calling further lookup
+functions that can attach errors and instead call their _maybe/_either
+counterparts.
+-}
 
 -----------------------------------------------
 -- | Look up an occurrence of a field in record construction or pattern
@@ -920,7 +945,7 @@ lookupLocalOccRn rdr_name
            Just name -> return name
            Nothing   -> unboundName WL_LocalOnly rdr_name }
 
--- lookupPromotedOccRn looks up an optionally promoted RdrName.
+-- lookupTypeOccRn looks up an optionally promoted RdrName.
 lookupTypeOccRn :: RdrName -> RnM Name
 -- see Note [Demotion]
 lookupTypeOccRn rdr_name
@@ -1034,29 +1059,38 @@ lookupOccRn_overloaded overload_ok
 
 lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name)
 -- Looks up a RdrName occurrence in the top-level
---   environment, including using lookupQualifiedNameGHCi
---   for the GHCi case
+-- environment, including using lookupQualifiedNameGHCi
+-- for the GHCi case, but first tries to find an Exact or Orig name.
 -- No filter function; does not report an error on failure
+-- See Note [Errors in lookup functions]
 -- Uses addUsedRdrName to record use and deprecations
 lookupGlobalOccRn_maybe rdr_name =
-  lookupExactOrOrig rdr_name Just $
-    runMaybeT . msum . map MaybeT $
-      [ fmap gre_name <$> lookupGreRn_maybe rdr_name
-      , listToMaybe <$> lookupQualifiedNameGHCi rdr_name ]
-                      -- This test is not expensive,
-                      -- and only happens for failed lookups
+  lookupExactOrOrig_maybe rdr_name id (lookupGlobalOccRn_base rdr_name)
 
 lookupGlobalOccRn :: RdrName -> RnM Name
 -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global
 -- environment.  Adds an error message if the RdrName is not in scope.
 -- You usually want to use "lookupOccRn" which also looks in the local
 -- environment.
-lookupGlobalOccRn rdr_name
-  = do { mb_name <- lookupGlobalOccRn_maybe rdr_name
-       ; case mb_name of
-           Just n  -> return n
-           Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)
-                         ; unboundName WL_Global rdr_name } }
+lookupGlobalOccRn rdr_name =
+  lookupExactOrOrig rdr_name id $ do
+    mn <- lookupGlobalOccRn_base rdr_name
+    case mn of
+      Just n -> return n
+      Nothing -> do { traceRn "lookupGlobalOccRn" (ppr rdr_name)
+                    ; unboundName WL_Global rdr_name }
+
+-- Looks up a RdrName occurence in the GlobalRdrEnv and with
+-- lookupQualifiedNameGHCi. Does not try to find an Exact or Orig name first.
+-- lookupQualifiedNameGHCi here is used when we're in GHCi and a name like
+-- 'Data.Map.elems' is typed, even if you didn't import Data.Map
+lookupGlobalOccRn_base :: RdrName -> RnM (Maybe Name)
+lookupGlobalOccRn_base rdr_name =
+  runMaybeT . msum . map MaybeT $
+    [ fmap gre_name <$> lookupGreRn_maybe rdr_name
+    , listToMaybe <$> lookupQualifiedNameGHCi rdr_name ]
+                      -- This test is not expensive,
+                      -- and only happens for failed lookups
 
 lookupInfoOccRn :: RdrName -> RnM [Name]
 -- lookupInfoOccRn is intended for use in GHCi's ":info" command
@@ -1086,7 +1120,7 @@ lookupInfoOccRn rdr_name =
 lookupGlobalOccRn_overloaded :: Bool -> RdrName
                              -> RnM (Maybe (Either Name [Name]))
 lookupGlobalOccRn_overloaded overload_ok rdr_name =
-  lookupExactOrOrig rdr_name (Just . Left) $
+  lookupExactOrOrig_maybe rdr_name (fmap Left) $
      do  { res <- lookupGreRn_helper rdr_name
          ; case res of
                 GreNotFound  -> return Nothing
diff --git a/compiler/GHC/Rename/Unbound.hs b/compiler/GHC/Rename/Unbound.hs
index d37c7d62c0..f97d52aac1 100644
--- a/compiler/GHC/Rename/Unbound.hs
+++ b/compiler/GHC/Rename/Unbound.hs
@@ -14,6 +14,7 @@ module GHC.Rename.Unbound
    , unboundName
    , unboundNameX
    , notInScopeErr
+   , exactNameErr
    )
 where
 
@@ -80,8 +81,10 @@ unboundNameX where_look rdr_name extra
 
 notInScopeErr :: RdrName -> SDoc
 notInScopeErr rdr_name
-  = hang (text "Not in scope:")
-       2 (what <+> quotes (ppr rdr_name))
+  = case isExact_maybe rdr_name of
+      Just name -> exactNameErr name
+      Nothing -> hang (text "Not in scope:")
+                  2 (what <+> quotes (ppr rdr_name))
   where
     what = pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name))
 
@@ -385,3 +388,10 @@ there are 2 cases, where we hide the last "no module is imported" line:
        and we have to check the current module in the last added entry of
        the HomePackageTable. (See test T15611b)
 -}
+
+exactNameErr :: Name -> SDoc
+exactNameErr name =
+  hang (text "The exact Name" <+> quotes (ppr name) <+> ptext (sLit "is not in scope"))
+    2 (vcat [ text "Probable cause: you used a unique Template Haskell name (NameU), "
+            , text "perhaps via newName, but did not bind it"
+            , text "If that's it, then -ddump-splices might be useful" ])
diff --git a/compiler/GHC/Types/Name/Reader.hs b/compiler/GHC/Types/Name/Reader.hs
index c1e675a19e..8cbff02459 100644
--- a/compiler/GHC/Types/Name/Reader.hs
+++ b/compiler/GHC/Types/Name/Reader.hs
@@ -182,8 +182,8 @@ rdrNameSpace = occNameSpace . rdrNameOcc
 demoteRdrName :: RdrName -> Maybe RdrName
 demoteRdrName (Unqual occ) = fmap Unqual (demoteOccName occ)
 demoteRdrName (Qual m occ) = fmap (Qual m) (demoteOccName occ)
-demoteRdrName (Orig _ _) = panic "demoteRdrName"
-demoteRdrName (Exact _) = panic "demoteRdrName"
+demoteRdrName (Orig _ _) = Nothing
+demoteRdrName (Exact _) = Nothing
 
         -- These two are the basic constructors
 mkRdrUnqual :: OccName -> RdrName
diff --git a/testsuite/tests/quotes/T18263.hs b/testsuite/tests/quotes/T18263.hs
new file mode 100644
index 0000000000..10e923480b
--- /dev/null
+++ b/testsuite/tests/quotes/T18263.hs
@@ -0,0 +1,26 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+{-
+This is to test that we don't get the error:
+
+    The exact Name ‘x_aFi’ is not in scope
+        Probable cause: you used a unique Template Haskell name (NameU),
+        perhaps via newName, but did not bind it
+        If that's it, then -ddump-splices might be useful
+
+When looking up something with 'lookupGlobalOccRn_maybe', which is called by
+'lookupThName'. This can happen when using a gensymmed name via newName.
+
+This should still fail to compile though, as reify should complain that "x"
+isn't in the type environment, albeit with one less error.
+-}
+
+module T18263 where
+
+import Language.Haskell.TH
+import Language.Haskell.TH.Syntax
+
+do
+  n <- newName "x"
+  addModFinalizer $ reify n >>= runIO . print
+  [d| $(varP n) = 42 |]
diff --git a/testsuite/tests/quotes/T18263.stderr b/testsuite/tests/quotes/T18263.stderr
new file mode 100644
index 0000000000..023432c85b
--- /dev/null
+++ b/testsuite/tests/quotes/T18263.stderr
@@ -0,0 +1,3 @@
+
+T18263.hs:1:1:
+    ‘x’ is not in the type environment at a reify
diff --git a/testsuite/tests/quotes/all.T b/testsuite/tests/quotes/all.T
index fe2a8e5e54..3f20d2982c 100644
--- a/testsuite/tests/quotes/all.T
+++ b/testsuite/tests/quotes/all.T
@@ -18,6 +18,7 @@ test('T10384', normal, compile_fail, [''])
 test('T16384', req_th, compile, [''])
 test('T17857', normal, compile, [''])
 test('T18103', normal, compile, [''])
+test('T18263', normal, compile_fail, [''])
 
 test('TH_tf2', normal, compile, ['-v0'])
 test('TH_ppr1', normal, compile_and_run, [''])