Tidy up the treatment of signatures (incl fixity)

This fixes Trac #6120.  I've added comments to explain.
Turns out there was another lurking bug, also fixed,
and tested in (an extended version of) th/T2713.

3 files changed, 83 insertions, 42 deletions

diff --git a/compiler/rename/RnBinds.lhs b/compiler/rename/RnBinds.lhs
index e1001eca15..536d83b344 100644
--- a/compiler/rename/RnBinds.lhs
+++ b/compiler/rename/RnBinds.lhs
@@ -170,13 +170,13 @@ rnTopBindsLHS :: MiniFixityEnv
 rnTopBindsLHS fix_env binds
   = rnValBindsLHS (topRecNameMaker fix_env) binds
 
-rnTopBindsRHS :: HsValBindsLR Name RdrName 
+rnTopBindsRHS :: NameSet -> HsValBindsLR Name RdrName 
               -> RnM (HsValBinds Name, DefUses)
-rnTopBindsRHS binds
+rnTopBindsRHS bound_names binds
   = do { is_boot <- tcIsHsBoot
        ; if is_boot 
          then rnTopBindsBoot binds
-         else rnValBindsRHS TopSigCtxt binds }
+         else rnValBindsRHS (TopSigCtxt bound_names False) binds }
 
 rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
 -- A hs-boot file has no bindings. 
@@ -696,8 +696,8 @@ renameSig _ (SpecInstSig ty)
 -- then the SPECIALISE pragma is ambiguous, unlike all other signatures
 renameSig ctxt sig@(SpecSig v ty inl)
   = do	{ new_v <- case ctxt of 
-                     TopSigCtxt -> lookupLocatedOccRn v
-                     _          -> lookupSigOccRn ctxt sig v
+                     TopSigCtxt {} -> lookupLocatedOccRn v
+                     _             -> lookupSigOccRn ctxt sig v
 	; (new_ty, fvs) <- rnHsSigType (quotes (ppr v)) ty
 	; return (SpecSig new_v new_ty inl, fvs) }
 
@@ -723,14 +723,14 @@ okHsSig ctxt (L _ sig)
      (FixSig {}, InstDeclCtxt {}) -> False
      (FixSig {}, _)               -> True
 
-     (IdSig {}, TopSigCtxt)      -> True
+     (IdSig {}, TopSigCtxt {})   -> True
      (IdSig {}, InstDeclCtxt {}) -> True
      (IdSig {}, _)               -> False
 
      (InlineSig {}, HsBootCtxt) -> False
      (InlineSig {}, _)          -> True
 
-     (SpecSig {}, TopSigCtxt)       -> True
+     (SpecSig {}, TopSigCtxt {})    -> True
      (SpecSig {}, LocalBindCtxt {}) -> True
      (SpecSig {}, InstDeclCtxt {})  -> True
      (SpecSig {}, _)                -> False
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index b1f393baaf..2f1de923c2 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -837,13 +837,36 @@ We don't want to say 'f' is out of scope; instead, we want to
 return the imported 'f', so that later on the reanamer will
 correctly report "misplaced type sig".
 
+Note [Signatures for top level things]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+data HsSigCtxt = ... | TopSigCtxt NameSet Bool | ....
+
+* The NameSet says what is bound in this group of bindings.
+  We can't use isLocalGRE from the GlobalRdrEnv, because of this:
+       f x = x
+       $( ...some TH splice... )
+       f :: Int -> Int
+  When we encounter the signature for 'f', the binding for 'f'
+  will be in the GlobalRdrEnv, and will be a LocalDef. Yet the
+  signature is mis-placed
+
+* The Bool says whether the signature is ok for a class method
+  or record selector.  Consider
+      infix 3 `f`          -- Yes, ok
+      f :: C a => a -> a   -- No, not ok
+      class C a where
+        f :: a -> a
+
 \begin{code}
 data HsSigCtxt 
-  = HsBootCtxt		     -- Top level of a hs-boot file
-  | TopSigCtxt		     -- At top level
+  = TopSigCtxt NameSet Bool  -- At top level, binding these names
+                             -- See Note [Signatures for top level things]
+                             -- Bool <=> ok to give sig for
+                             --          class method or record selctor
   | LocalBindCtxt NameSet    -- In a local binding, binding these names
   | ClsDeclCtxt   Name	     -- Class decl for this class
   | InstDeclCtxt  Name	     -- Intsance decl for this class
+  | HsBootCtxt		     -- Top level of a hs-boot file
 
 lookupSigOccRn :: HsSigCtxt
 	       -> Sig RdrName
@@ -875,11 +898,11 @@ lookupBindGroupOcc ctxt what rdr_name
 
   | otherwise
   = case ctxt of 
-      HsBootCtxt       -> lookup_top		    
-      TopSigCtxt       -> lookup_top
-      LocalBindCtxt ns -> lookup_group ns
-      ClsDeclCtxt  cls -> lookup_cls_op cls
-      InstDeclCtxt cls -> lookup_cls_op cls
+      HsBootCtxt            -> lookup_top (const True)       True
+      TopSigCtxt ns meth_ok -> lookup_top (`elemNameSet` ns) meth_ok
+      LocalBindCtxt ns 	    -> lookup_group ns
+      ClsDeclCtxt  cls 	    -> lookup_cls_op cls
+      InstDeclCtxt cls 	    -> lookup_cls_op cls
   where
     lookup_cls_op cls
       = do { env <- getGlobalRdrEnv 
@@ -893,21 +916,22 @@ lookupBindGroupOcc ctxt what rdr_name
       where
         doc = ptext (sLit "method of class") <+> quotes (ppr cls)
 
-    lookup_top
+    lookup_top keep_me meth_ok
       = do { env <- getGlobalRdrEnv 
-           ; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
-           ; case filter isLocalGRE gres of
-               [] | null gres -> bale_out_with empty
-                  | otherwise -> bale_out_with (bad_msg (ptext (sLit "an imported value")))
+           ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
+           ; case filter (keep_me . gre_name) all_gres of
+               [] | null all_gres -> bale_out_with empty
+                  | otherwise -> bale_out_with local_msg
                (gre:_) 
-                  | ParentIs {} <- gre_par gre
-		  -> bale_out_with (bad_msg (ptext (sLit "a record selector or class method")))
+                  | ParentIs {} <- gre_par gre 
+                  , not meth_ok
+		  -> bale_out_with sub_msg
 		  | otherwise
                   -> return (Right (gre_name gre)) }
 
-    lookup_group bound_names
-      = do { mb_name <- lookupOccRn_maybe rdr_name
-           ; case mb_name of
+    lookup_group bound_names  -- Look in the local envt (not top level)
+      = do { local_env <- getLocalRdrEnv
+           ; case lookupLocalRdrEnv local_env rdr_name of
                Just n  
                  | n `elemNameSet` bound_names -> return (Right n)
                  | otherwise                   -> bale_out_with local_msg
@@ -922,31 +946,31 @@ lookupBindGroupOcc ctxt what rdr_name
     local_msg = parens $ ptext (sLit "The")  <+> what <+> ptext (sLit "must be given where")
   			   <+> quotes (ppr rdr_name) <+> ptext (sLit "is declared")
 
-    bad_msg thing = parens $ ptext (sLit "You cannot give a") <+> what
-    			  <+> ptext (sLit "for") <+> thing
+    sub_msg = parens $ ptext (sLit "You cannot give a") <+> what
+     	               <+> ptext (sLit "for a record selector or class method")
 
 
 ---------------
-lookupLocalTcNames :: NameSet -> SDoc -> RdrName -> RnM [Name]
+lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [Name]
 -- GHC extension: look up both the tycon and data con or variable.
--- Used for top-level fixity signatures. Complain if neither is in scope.
+-- Used for top-level fixity signatures and deprecations. 
+-- Complain if neither is in scope.
 -- See Note [Fixity signature lookup]
-lookupLocalTcNames bndr_set what rdr_name
-  | Just n <- isExact_maybe rdr_name	
-	-- Special case for (:), which doesn't get into the GlobalRdrEnv
-  = do { n' <- lookupExactOcc n; return [n'] }	-- For this we don't need to try the tycon too
-  | otherwise
+lookupLocalTcNames ctxt what rdr_name
   = do { mb_gres <- mapM lookup (dataTcOccs rdr_name)
        ; let (errs, names) = splitEithers mb_gres
        ; when (null names) $ addErr (head errs) -- Bleat about one only
        ; return names }
   where
-    lookup = lookupBindGroupOcc (LocalBindCtxt bndr_set) what
+    lookup = lookupBindGroupOcc ctxt what
 
 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.
 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
@@ -956,6 +980,17 @@ dataTcOccs rdr_name
     rdr_name_tc = setRdrNameSpace rdr_name tcName
 \end{code}
 
+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
+   :info []
+This parses as the Exact RdrName for nilDataCon, but we also want
+the list type constructor.
+
+Note that setRdrNameSpace on an Exact name requires the Name to be External,
+which it always is for built in syntax.
 
 %*********************************************************
 %*							*
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index e2ad3e0b89..595f4653d3 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -114,9 +114,9 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds   = val_decls,
    --     It uses the fixity env from (A) to bind fixities for view patterns.
    new_lhs <- rnTopBindsLHS local_fix_env val_decls ;
    -- bind the LHSes (and their fixities) in the global rdr environment
-   let { val_binders  = collectHsValBinders new_lhs ;
-         all_bndr_set = addListToNameSet tc_bndrs val_binders ;
-         val_avails   = map Avail val_binders  } ;
+   let { val_binders = collectHsValBinders new_lhs ;
+         all_bndrs   = addListToNameSet tc_bndrs val_binders ;
+         val_avails  = map Avail val_binders  } ;
    (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
    traceRn (ptext (sLit "Val binders") <+> (ppr val_binders)) ;
    setEnvs (tcg_env, tcl_env) $ do {
@@ -138,19 +138,19 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds   = val_decls,
 
    -- (F) Rename Value declarations right-hand sides
    traceRn (text "Start rnmono") ;
-   (rn_val_decls, bind_dus) <- rnTopBindsRHS new_lhs ;
+   (rn_val_decls, bind_dus) <- rnTopBindsRHS all_bndrs new_lhs ;
    traceRn (text "finish rnmono" <+> ppr rn_val_decls) ;
 
    -- (G) Rename Fixity and deprecations
    
    -- Rename fixity declarations and error if we try to
    -- fix something from another module (duplicates were checked in (A))
-   rn_fix_decls <- rnSrcFixityDecls all_bndr_set fix_decls ;
+   rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ;
 
    -- Rename deprec decls;
    -- check for duplicates and ensure that deprecated things are defined locally
    -- at the moment, we don't keep these around past renaming
-   rn_warns <- rnSrcWarnDecls all_bndr_set warn_decls ;
+   rn_warns <- rnSrcWarnDecls all_bndrs warn_decls ;
 
    -- (H) Rename Everything else
 
@@ -260,6 +260,9 @@ rnSrcFixityDecls bndr_set fix_decls
   = do fix_decls <- mapM rn_decl fix_decls
        return (concat fix_decls)
   where
+    sig_ctxt = TopSigCtxt bndr_set True  
+       -- True <=> can give fixity for class decls and record selectors
+
     rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
         -- GHC extension: look up both the tycon and data con 
 	-- for con-like things; hence returning a list
@@ -268,7 +271,7 @@ rnSrcFixityDecls bndr_set fix_decls
     rn_decl (L loc (FixitySig (L name_loc rdr_name) fixity))
       = setSrcSpan name_loc $
                     -- this lookup will fail if the definition isn't local
-        do names <- lookupLocalTcNames bndr_set what rdr_name
+        do names <- lookupLocalTcNames sig_ctxt what rdr_name
            return [ L loc (FixitySig (L name_loc name) fixity)
                   | name <- names ]
     what = ptext (sLit "fixity signature")
@@ -301,9 +304,12 @@ rnSrcWarnDecls bndr_set decls
        ; pairs_s <- mapM (addLocM rn_deprec) decls
        ; return (WarnSome ((concat pairs_s))) }
  where
+   sig_ctxt = TopSigCtxt bndr_set True
+      -- True <=> Can give deprecations for class ops and record sels
+
    rn_deprec (Warning rdr_name txt)
        -- ensures that the names are defined locally
-     = do { names <- lookupLocalTcNames bndr_set what rdr_name
+     = do { names <- lookupLocalTcNames sig_ctxt what rdr_name
           ; return [(nameOccName name, txt) | name <- names] }
    
    what = ptext (sLit "deprecation")