Treat pattern-synonym binders more consistently

Pattern-synonyms are in value declarations, but were being
bound by getLocalNonValBinders.  This seemed odd, and indeed
staightening it out allowed me to remove a field from
TopSigCtxt.

The main changes are in RnSource.rnSrcDecls.

Nice.

6 files changed, 45 insertions, 54 deletions

diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs
index b1c8036bc1..f4737e7bdb 100644
--- a/compiler/hsSyn/HsUtils.hs
+++ b/compiler/hsSyn/HsUtils.hs
@@ -780,10 +780,11 @@ hsForeignDeclsBinders foreign_decls
     | L decl_loc (ForeignImport (L _ n) _ _ _) <- foreign_decls]
 
 -------------------
-hsPatSynBinders :: LHsBindsLR idL idR -> [Located idL]
+hsPatSynBinders :: HsValBinds RdrName -> [Located RdrName]
 -- Collect pattern-synonym binders only, not Ids
 -- See Note [SrcSpan for binders]
-hsPatSynBinders binds = foldrBag addPatSynBndr [] binds
+hsPatSynBinders (ValBindsIn binds _) = foldrBag addPatSynBndr [] binds
+hsPatSynBinders _ = panic "hsPatSynBinders"
 
 addPatSynBndr :: LHsBindLR idL idR -> [Located idL] -> [Located idL]
 -- See Note [SrcSpan for binders]
diff --git a/compiler/rename/RnBinds.hs b/compiler/rename/RnBinds.hs
index beda054423..f1a18d6e0d 100644
--- a/compiler/rename/RnBinds.hs
+++ b/compiler/rename/RnBinds.hs
@@ -176,7 +176,7 @@ rnTopBindsRHS bound_names binds
   = do { is_boot <- tcIsHsBootOrSig
        ; if is_boot
          then rnTopBindsBoot binds
-         else rnValBindsRHS (TopSigCtxt bound_names False) binds }
+         else rnValBindsRHS (TopSigCtxt bound_names) binds }
 
 rnTopBindsBoot :: HsValBindsLR Name RdrName -> RnM (HsValBinds Name, DefUses)
 -- A hs-boot file has no bindings.
@@ -442,7 +442,7 @@ rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })
 rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname })
   | isTopRecNameMaker name_maker
   = do { addLocM checkConName rdrname
-       ; name <- lookupLocatedTopBndrRn rdrname   -- Should be bound at top level already
+       ; name <- lookupLocatedTopBndrRn rdrname   -- Should be in scope already
        ; return (PatSynBind psb{ psb_id = name }) }
 
   | otherwise  -- Pattern synonym, not at top level
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs
index 28da6cb413..0b877959e3 100644
--- a/compiler/rename/RnEnv.hs
+++ b/compiler/rename/RnEnv.hs
@@ -1038,7 +1038,7 @@ correctly report "misplaced type sig".
 
 Note [Signatures for top level things]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-data HsSigCtxt = ... | TopSigCtxt NameSet Bool | ....
+data HsSigCtxt = ... | TopSigCtxt NameSet | ....
 
 * The NameSet says what is bound in this group of bindings.
   We can't use isLocalGRE from the GlobalRdrEnv, because of this:
@@ -1049,8 +1049,10 @@ data HsSigCtxt = ... | TopSigCtxt NameSet Bool | ....
   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
+* For type signatures the NameSet should be the names bound by the
+  value bindings; for fixity declarations, the NameSet should also
+  include class sigs and record selectors
+
       infix 3 `f`          -- Yes, ok
       f :: C a => a -> a   -- No, not ok
       class C a where
@@ -1058,10 +1060,8 @@ data HsSigCtxt = ... | TopSigCtxt NameSet Bool | ....
 -}
 
 data HsSigCtxt
-  = TopSigCtxt NameSet Bool  -- At top level, binding these names
+  = TopSigCtxt NameSet       -- 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
@@ -1107,12 +1107,12 @@ lookupBindGroupOcc ctxt what rdr_name
 
   | otherwise
   = case ctxt of
-      HsBootCtxt            -> lookup_top (const True)       True
-      TopSigCtxt ns meth_ok -> lookup_top (`elemNameSet` ns) meth_ok
-      RoleAnnotCtxt ns      -> lookup_top (`elemNameSet` ns) False
-      LocalBindCtxt ns      -> lookup_group ns
-      ClsDeclCtxt  cls      -> lookup_cls_op cls
-      InstDeclCtxt cls      -> lookup_cls_op cls
+      HsBootCtxt       -> lookup_top (const True)
+      TopSigCtxt ns    -> lookup_top (`elemNameSet` ns)
+      RoleAnnotCtxt ns -> lookup_top (`elemNameSet` ns)
+      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
@@ -1126,18 +1126,13 @@ lookupBindGroupOcc ctxt what rdr_name
       where
         doc = ptext (sLit "method of class") <+> quotes (ppr cls)
 
-    lookup_top keep_me meth_ok
+    lookup_top keep_me
       = do { env <- getGlobalRdrEnv
            ; let all_gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name)
            ; case filter (keep_me . gre_name) all_gres of
                [] | null all_gres -> bale_out_with Outputable.empty
-                  | otherwise -> bale_out_with local_msg
-               (gre:_)
-                  | ParentIs {} <- gre_par gre
-                  , not meth_ok
-                  -> bale_out_with sub_msg
-                  | otherwise
-                  -> return (Right (gre_name gre)) }
+                  | otherwise     -> bale_out_with local_msg
+               (gre:_)            -> return (Right (gre_name gre)) }
 
     lookup_group bound_names  -- Look in the local envt (not top level)
       = do { local_env <- getLocalRdrEnv
@@ -1156,9 +1151,6 @@ 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")
 
-    sub_msg = parens $ ptext (sLit "You cannot give a") <+> what
-                       <+> ptext (sLit "for a record selector or class method")
-
 
 ---------------
 lookupLocalTcNames :: HsSigCtxt -> SDoc -> RdrName -> RnM [Name]
diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs
index 7ed96711b0..b692f47cd7 100644
--- a/compiler/rename/RnNames.hs
+++ b/compiler/rename/RnNames.hs
@@ -526,8 +526,7 @@ getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName
 --      * class decls (including class ops)
 --      * associated types
 --      * foreign imports
---      * pattern synonyms
---      * value signatures (in hs-boot files)
+--      * value signatures (in hs-boot files only)
 
 getLocalNonValBinders fixity_env
      (HsGroup { hs_valds  = binds,
@@ -551,7 +550,7 @@ getLocalNonValBinders fixity_env
           --    type sigs in case of a hs-boot file only
         ; is_boot <- tcIsHsBootOrSig
         ; let val_bndrs | is_boot   = hs_boot_sig_bndrs
-                        | otherwise = for_hs_bndrs ++ patsyn_hs_bndrs
+                        | otherwise = for_hs_bndrs
         ; val_avails <- mapM new_simple val_bndrs
 
         ; let avails    = nti_avails ++ val_avails
@@ -561,14 +560,11 @@ getLocalNonValBinders fixity_env
         ; envs <- extendGlobalRdrEnvRn avails fixity_env
         ; return (envs, new_bndrs) } }
   where
-    ValBindsIn val_binds val_sigs = binds
+    ValBindsIn _val_binds val_sigs = binds
 
     for_hs_bndrs :: [Located RdrName]
     for_hs_bndrs = hsForeignDeclsBinders foreign_decls
 
-    patsyn_hs_bndrs :: [Located RdrName]
-    patsyn_hs_bndrs = hsPatSynBinders val_binds
-
     -- In a hs-boot file, the value binders come from the
     --  *signatures*, and there should be no foreign binders
     hs_boot_sig_bndrs = [ L decl_loc (unLoc n)
diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs
index 3b745af25d..f5ffcd7c04 100644
--- a/compiler/rename/RnSource.hs
+++ b/compiler/rename/RnSource.hs
@@ -100,9 +100,6 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds   = val_decls,
    --          because they do not have value declarations.
    --          Aso step (C) depends on datacons and record fields
    --
-   --        * Pattern synonyms, because they (and data constructors)
-   --          are needed for rnTopBindLHS (Trac #9889)
-   --
    --        * For hs-boot files, include the value signatures
    --          Again, they have no value declarations
    --
@@ -117,20 +114,25 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds   = val_decls,
    --     scope from (B) above
    inNewEnv (extendRecordFieldEnv tycl_decls inst_decls) $ \ _ -> do {
 
-   -- (D) Rename the left-hand sides of the value bindings.
+   -- (D1) Bring pattern synonyms into scope.
+   --      Need to do this before (D2) because rnTopBindsLHS
+   --      looks up those pattern synonyms (Trac #9889)
+   pat_syn_bndrs <- mapM newTopSrcBinder (hsPatSynBinders val_decls) ;
+   tc_envs <- extendGlobalRdrEnvRn (map Avail pat_syn_bndrs) local_fix_env ;
+   setEnvs tc_envs $ do {
+
+   -- (D2) Rename the left-hand sides of the value bindings.
    --     This depends on everything from (B) being in scope,
    --     and on (C) for resolving record wild cards.
    --     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 = collectHsIdBinders new_lhs ;
-                       -- Not pattern-synonym binders, because we did
-                       -- them in step (B)
-         all_bndrs   = extendNameSetList tc_bndrs val_binders ;
-         val_avails  = map Avail val_binders  } ;
-   traceRn (text "rnSrcDecls" <+> ppr val_avails) ;
-   (tcg_env, tcl_env) <- extendGlobalRdrEnvRn val_avails local_fix_env ;
-   setEnvs (tcg_env, tcl_env) $ do {
+
+   -- Bind the LHSes (and their fixities) in the global rdr environment
+   let { id_bndrs = collectHsIdBinders new_lhs } ;  -- Excludes pattern-synonym binders
+                                                    -- They are already in scope
+   traceRn (text "rnSrcDecls" <+> ppr id_bndrs) ;
+   tc_envs <- extendGlobalRdrEnvRn (map Avail id_bndrs) local_fix_env ;
+   setEnvs tc_envs $ do {
 
    --  Now everything is in scope, as the remaining renaming assumes.
 
@@ -149,13 +151,15 @@ 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 all_bndrs new_lhs ;
+   let { val_bndr_set = mkNameSet id_bndrs `unionNameSet` mkNameSet pat_syn_bndrs } ;
+   (rn_val_decls, bind_dus) <- rnTopBindsRHS val_bndr_set 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))
+   let { all_bndrs = tc_bndrs `unionNameSet` val_bndr_set } ;
    rn_fix_decls <- rnSrcFixityDecls all_bndrs fix_decls ;
 
    -- Rename deprec decls;
@@ -214,7 +218,7 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds   = val_decls,
    traceRn (text "finish rnSrc" <+> ppr rn_group) ;
    traceRn (text "finish Dus" <+> ppr src_dus ) ;
    return (final_tcg_env, rn_group)
-                    }}}}
+                    }}}}}
 
 -- some utils because we do this a bunch above
 -- compute and install the new env
@@ -271,8 +275,7 @@ 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
+    sig_ctxt = TopSigCtxt bndr_set
 
     rn_decl :: LFixitySig RdrName -> RnM [LFixitySig Name]
         -- GHC extension: look up both the tycon and data con
@@ -321,8 +324,7 @@ rnSrcWarnDecls bndr_set decls'
  where
    decls = concatMap (\(L _ d) -> wd_warnings d) decls'
 
-   sig_ctxt = TopSigCtxt bndr_set True
-      -- True <=> Can give deprecations for class ops and record sels
+   sig_ctxt = TopSigCtxt bndr_set
 
    rn_deprec (Warning rdr_names txt)
        -- ensures that the names are defined locally
diff --git a/compiler/typecheck/TcDeriv.hs b/compiler/typecheck/TcDeriv.hs
index b8aa1bf93f..96a4a33fb0 100644
--- a/compiler/typecheck/TcDeriv.hs
+++ b/compiler/typecheck/TcDeriv.hs
@@ -523,7 +523,7 @@ renameDeriv is_boot inst_infos bagBinds
         ; let bndrs = collectHsValBinders rn_aux_lhs
         ; envs <- extendGlobalRdrEnvRn (map Avail bndrs) emptyFsEnv ;
         ; setEnvs envs $
-    do  { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs) False) rn_aux_lhs
+    do  { (rn_aux, dus_aux) <- rnValBindsRHS (TopSigCtxt (mkNameSet bndrs)) rn_aux_lhs
         ; (rn_inst_infos, fvs_insts) <- mapAndUnzipM rn_inst_info inst_infos
         ; return (listToBag rn_inst_infos, rn_aux,
                   dus_aux `plusDU` usesOnly (plusFVs fvs_insts)) } }