Fix #9066.

When splicing in a fixity declaration, look for both term-level things
and type-level things. This requires some changes elsewhere in the
code to allow for more flexibility when looking up Exact names, which
can be assigned the wrong namespace during fixity declaration
conversion.

See the ticket for more info.

4 files changed, 58 insertions, 30 deletions

diff --git a/compiler/basicTypes/RdrName.lhs b/compiler/basicTypes/RdrName.lhs
index d4afaf10fc..b9e3fcbd6a 100644
--- a/compiler/basicTypes/RdrName.lhs
+++ b/compiler/basicTypes/RdrName.lhs
@@ -157,9 +157,14 @@ setRdrNameSpace :: RdrName -> NameSpace -> RdrName
 setRdrNameSpace (Unqual occ) ns = Unqual (setOccNameSpace ns occ)
 setRdrNameSpace (Qual m occ) ns = Qual m (setOccNameSpace ns occ)
 setRdrNameSpace (Orig m occ) ns = Orig m (setOccNameSpace ns occ)
-setRdrNameSpace (Exact n)    ns = ASSERT( isExternalName n )
-                                  Orig (nameModule n)
-                                       (setOccNameSpace ns (nameOccName n))
+setRdrNameSpace (Exact n)    ns
+  | isExternalName n
+  = Orig (nameModule n) occ
+  | otherwise   -- This can happen when quoting and then splicing a fixity
+                -- declaration for a type
+  = Exact $ mkSystemNameAt (nameUnique n) occ (nameSrcSpan n)
+  where
+    occ = setOccNameSpace ns (nameOccName n)
 
 -- demoteRdrName lowers the NameSpace of RdrName.
 -- see Note [Demotion] in OccName
diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 43d9bfb4e9..6cff928b3c 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -172,7 +172,11 @@ cvtDec (TH.SigD nm typ)
         ; returnJustL $ Hs.SigD (TypeSig [nm'] ty') }
 
 cvtDec (TH.InfixD fx nm)
-  = do { nm' <- vNameL nm
+  -- fixity signatures are allowed for variables, constructors, and types
+  -- the renamer automatically looks for types during renaming, even when
+  -- the RdrName says it's a variable or a constructor. So, just assume
+  -- it's a variable or constructor and proceed.
+  = do { nm' <- vcNameL nm
        ; returnJustL (Hs.SigD (FixSig (FixitySig nm' (cvtFixity fx)))) }
 
 cvtDec (PragmaD prag)
@@ -521,7 +525,7 @@ cvtPragmaD (AnnP target exp)
            n' <- tconName n
            return (TypeAnnProvenance  n')
          ValueAnnotation n -> do
-           n' <- if isVarName n then vName n else cName n
+           n' <- vcName n
            return (ValueAnnProvenance n')
        ; returnJustL $ Hs.AnnD $ HsAnnotation target' exp'
        }
@@ -1071,9 +1075,10 @@ cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value =
 --------------------------------------------------------------------
 
 -- variable names
-vNameL, cNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
-vName,  cName,  tName,  tconName  :: TH.Name -> CvtM RdrName
+vNameL, cNameL, vcNameL, tconNameL :: TH.Name -> CvtM (Located RdrName)
+vName,  cName,  vcName,  tName,  tconName  :: TH.Name -> CvtM RdrName
 
+-- Variable names
 vNameL n = wrapL (vName n)
 vName n = cvtName OccName.varName n
 
@@ -1081,6 +1086,10 @@ vName n = cvtName OccName.varName n
 cNameL n = wrapL (cName n)
 cName n = cvtName OccName.dataName n
 
+-- Variable *or* constructor names; check by looking at the first char
+vcNameL n = wrapL (vcName n)
+vcName n = if isVarName n then vName n else cName n
+
 -- Type variable names
 tName n = cvtName OccName.tvName n
 
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index e33ed15808..0a73585976 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -309,9 +309,21 @@ lookupTopBndrRn_maybe 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
--- See Note [Looking up Exact RdrNames]
 lookupExactOcc name
+  = do { result <- lookupExactOcc_either name
+       ; case result of
+           Left err -> do { addErr err
+                          ; return name }
+           Right name' -> return name' }
+
+-- | Lookup an @Exact@ @RdrName@. See Note [Looking up Exact RdrNames].
+-- This never adds an error, but it may return one.
+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
                     ATyCon tc                 -> Just tc
@@ -319,10 +331,10 @@ lookupExactOcc name
                     _                         -> Nothing
   , isTupleTyCon tycon
   = do { checkTupSize (tyConArity tycon)
-       ; return name }
+       ; return (Right name) }
 
   | isExternalName name
-  = return name
+  = return (Right name)
 
   | otherwise
   = do { env <- getGlobalRdrEnv
@@ -337,23 +349,23 @@ lookupExactOcc name
        ; case gres of
            []    -> -- See Note [Splicing Exact names]
                     do { lcl_env <- getLocalRdrEnv
-                       ; unless (name `inLocalRdrEnvScope` lcl_env) $
+                       ; if name `inLocalRdrEnvScope` lcl_env
+                         then return (Right name)
+                         else
 #ifdef GHCI
                          do { th_topnames_var <- fmap tcg_th_topnames getGblEnv
                             ; th_topnames <- readTcRef th_topnames_var
-                            ; unless (name `elemNameSet` th_topnames)
-                                     (addErr exact_nm_err)
+                            ; if name `elemNameSet` th_topnames
+                              then return (Right name)
+                              else return (Left exact_nm_err)
                             }
 #else /* !GHCI */
-                         addErr exact_nm_err
+                         return (Left exact_nm_err)
 #endif /* !GHCI */
-                       ; return name
                        }
 
-           [gre]   -> return (gre_name gre)
-           (gre:_) -> do {addErr dup_nm_err
-                         ; return (gre_name gre)
-                         }
+           [gre]   -> return (Right (gre_name gre))
+           _       -> return (Left dup_nm_err)
            -- We can get more than one GRE here, if there are multiple 
            -- bindings for the same name. Sometimes they are caught later
            -- by findLocalDupsRdrEnv, like in this example (Trac #8932):
@@ -1034,10 +1046,11 @@ lookupBindGroupOcc :: HsSigCtxt
 -- See Note [Looking up signature names]
 lookupBindGroupOcc ctxt what rdr_name
   | Just n <- isExact_maybe rdr_name
-  = do { n' <- lookupExactOcc n
-       ; return (Right n') }  -- Maybe we should check the side conditions
-                              -- but it's a pain, and Exact things only show
-                              -- up when you know what you are doing
+  = lookupExactOcc_either n   -- allow for the possibility of missing Exacts;
+                              -- see Note [dataTcOccs and Exact Names]
+      -- Maybe we should check the side conditions
+      -- but it's a pain, and Exact things only show
+      -- up when you know what you are doing
 
   | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name
   = do { n' <- lookupOrig rdr_mod rdr_occ
@@ -1114,10 +1127,8 @@ lookupLocalTcNames ctxt what rdr_name
 dataTcOccs :: RdrName -> [RdrName]
 -- Return both the given name and the same name promoted to the TcClsName
 -- namespace.  This is useful when we aren't sure which we are looking at.
+-- See also Note [dataTcOccs and Exact Names]
 dataTcOccs rdr_name
-  | Just n <- isExact_maybe rdr_name
-  , not (isBuiltInSyntax n)   -- See Note [dataTcOccs and Exact Names]
-  = [rdr_name]
   | isDataOcc occ || isVarOcc occ
   = [rdr_name, rdr_name_tc]
   | otherwise
@@ -1130,8 +1141,12 @@ dataTcOccs rdr_name
 Note [dataTcOccs and Exact Names]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 Exact RdrNames can occur in code generated by Template Haskell, and generally
-those references are, well, exact, so it's wrong to return the TyClsName too.
-But there is an awkward exception for built-in syntax. Example in GHCi
+those references are, well, exact. However, the TH `Name` type isn't expressive
+enough to always track the correct namespace information, so we sometimes get
+the right Unique but wrong namespace. Thus, we still have to do the double-lookup
+for Exact RdrNames.
+
+There is also an awkward situation for built-in syntax. Example in GHCi
    :info []
 This parses as the Exact RdrName for nilDataCon, but we also want
 the list type constructor.
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 3d64060f01..342f5e3ed4 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -336,5 +336,4 @@ test('T8953', normal, compile, ['-v0'])
 test('T9084', normal, compile_fail, ['-v0'])
 test('T9738', normal, compile, ['-v0'])
 test('T9081', normal, compile, ['-v0'])
-test('T9066', expect_broken(9066), compile, ['-v0'])
-
+test('T9066', normal, compile, ['-v0'])