Pattern synonym names need to be in scope before renaming bindings (#9889)

I did a bit of refactoring at the same time, needless to say

compiler/hsSyn/HsBinds.hs

@@ -73,15 +73,24 @@ type HsLocalBinds id = HsLocalBindsLR id id
 -- or a 'where' clause
 data HsLocalBindsLR idL idR
   = HsValBinds (HsValBindsLR idL idR)
+         -- There should be no pattern synonyms in the HsValBindsLR
+         -- These are *local* (not top level) bindings
+         -- The parser accepts them, however, leaving the the
+         -- renamer to report them
+
   | HsIPBinds  (HsIPBinds idR)
+
   | EmptyLocalBinds
   deriving (Typeable)
+
 deriving instance (DataId idL, DataId idR)
   => Data (HsLocalBindsLR idL idR)
 
 type HsValBinds id = HsValBindsLR id id
 
 -- | Value bindings (not implicit parameters)
+-- Used for both top level and nested bindings
+-- May contain pattern synonym bindings
 data HsValBindsLR idL idR
   = -- | Before renaming RHS; idR is always RdrName
     -- Not dependency analysed
@@ -97,6 +106,7 @@ data HsValBindsLR idL idR
         [(RecFlag, LHsBinds idL)]
         [LSig Name]
   deriving (Typeable)
+
 deriving instance (DataId idL, DataId idR)
   => Data (HsValBindsLR idL idR)
 

compiler/hsSyn/HsUtils.hs

@@ -61,12 +61,13 @@ module HsUtils(
 
   -- Collecting binders
   collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
+  collectHsIdBinders,
   collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
   collectPatBinders, collectPatsBinders,
   collectLStmtsBinders, collectStmtsBinders,
   collectLStmtBinders, collectStmtBinders,
 
-  hsLTyClDeclBinders, hsTyClDeclsBinders,
+  hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynBinders,
   hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
 
   -- Collecting implicit binders
@@ -596,39 +597,48 @@ So these functions should not be applied to (HsSyn RdrName)
 
 ----------------- Bindings --------------------------
 collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
-collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
-collectLocalBinders (HsIPBinds _)   = []
-collectLocalBinders EmptyLocalBinds = []
+collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
+                                         -- No pattern synonyms here
+collectLocalBinders (HsIPBinds _)      = []
+collectLocalBinders EmptyLocalBinds    = []
 
-collectHsValBinders :: HsValBindsLR idL idR -> [idL]
-collectHsValBinders (ValBindsIn  binds _) = collectHsBindsBinders binds
-collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds
-  where
-   collect_one (_,binds) acc = collect_binds binds acc
+collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [idL]
+-- Collect Id binders only, or Ids + pattern synonmys, respectively
+collectHsIdBinders  = collect_hs_val_binders True
+collectHsValBinders = collect_hs_val_binders False
 
 collectHsBindBinders :: HsBindLR idL idR -> [idL]
-collectHsBindBinders b = collect_bind b []
-
-collect_bind :: HsBindLR idL idR -> [idL] -> [idL]
-collect_bind (PatBind { pat_lhs = p })    acc = collect_lpat p acc
-collect_bind (FunBind { fun_id = L _ f }) acc = f : acc
-collect_bind (VarBind { var_id = f })     acc = f : acc
-collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc
-  = map abe_poly dbinds ++ acc
-        -- ++ foldr collect_bind acc binds
-        -- I don't think we want the binders from the nested binds
-        -- The only time we collect binders from a typechecked
-        -- binding (hence see AbsBinds) is in zonking in TcHsSyn
-collect_bind (PatSynBind (PSB { psb_id = L _ ps })) acc = ps : acc
+-- Collect both Ids and pattern-synonym binders
+collectHsBindBinders b = collect_bind False b []
 
 collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
-collectHsBindsBinders binds = collect_binds binds []
+collectHsBindsBinders binds = collect_binds False binds []
 
 collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
-collectHsBindListBinders = foldr (collect_bind . unLoc) []
-
-collect_binds :: LHsBindsLR idL idR -> [idL] -> [idL]
-collect_binds binds acc = foldrBag (collect_bind . unLoc) acc binds
+-- Same as collectHsBindsBinders, but works over a list of bindings
+collectHsBindListBinders = foldr (collect_bind False . unLoc) []
+
+collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [idL]
+collect_hs_val_binders ps (ValBindsIn  binds _) = collect_binds     ps binds []
+collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds
+
+collect_out_binds :: Bool -> [(RecFlag, LHsBinds id)] -> [id]
+collect_out_binds ps = foldr (collect_binds ps . snd) []
+
+collect_binds :: Bool -> LHsBindsLR idL idR -> [idL] -> [idL]
+-- Collect Ids, or Ids + patter synonyms, depending on boolean flag
+collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds
+
+collect_bind :: Bool -> HsBindLR idL idR -> [idL] -> [idL]
+collect_bind _ (PatBind { pat_lhs = p })           acc = collect_lpat p acc
+collect_bind _ (FunBind { fun_id = L _ f })        acc = f : acc
+collect_bind _ (VarBind { var_id = f })            acc = f : acc
+collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
+        -- I don't think we want the binders from the abe_binds
+        -- The only time we collect binders from a typechecked
+        -- binding (hence see AbsBinds) is in zonking in TcHsSyn
+collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc =
+    if omitPatSyn then acc else ps : acc
 
 collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
 -- Used exclusively for the bindings of an instance decl which are all FunBinds
@@ -728,21 +738,18 @@ So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
 hsGroupBinders :: HsGroup Name -> [Name]
 hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
                           hs_instds = inst_decls, hs_fords = foreign_decls })
--- Collect the binders of a Group
   =  collectHsValBinders val_decls
-  ++ hsTyClDeclsBinders tycl_decls inst_decls
-  ++ hsForeignDeclsBinders foreign_decls
-
-hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name]
-hsForeignDeclsBinders foreign_decls
-  = [n | L _ (ForeignImport (L _ n) _ _ _) <- foreign_decls]
+  ++ hsTyClForeignBinders tycl_decls inst_decls foreign_decls
 
-hsTyClDeclsBinders :: [TyClGroup Name] -> [Located (InstDecl Name)] -> [Name]
+hsTyClForeignBinders :: [TyClGroup Name] -> [LInstDecl Name]
+                     -> [LForeignDecl Name] -> [Name]
 -- We need to look at instance declarations too,
 -- because their associated types may bind data constructors
-hsTyClDeclsBinders tycl_decls inst_decls
-  = map unLoc (concatMap (concatMap hsLTyClDeclBinders . group_tyclds) tycl_decls ++
-               concatMap (hsInstDeclBinders . unLoc) inst_decls)
+hsTyClForeignBinders tycl_decls inst_decls foreign_decls
+  = map unLoc $
+    hsForeignDeclsBinders foreign_decls ++
+    concatMap (concatMap hsLTyClDeclBinders . group_tyclds) tycl_decls ++
+    concatMap hsLInstDeclBinders inst_decls
 
 -------------------
 hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
@@ -751,11 +758,8 @@ hsLTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
 -- mentioned in multiple constructors, the SrcLoc will be from the first
 -- occurrence.  We use the equality to filter out duplicate field names.
 --
--- Each returned (Located name) is wrapped in a @SrcSpan@ of the whole
--- /declaration/, not just the name itself (which is how it appears in
--- the syntax tree).  This SrcSpan (for the entire declaration) is used
--- as the SrcSpan for the Name that is finally produced, and hence for
--- error messages.  (See Trac #8607.)
+-- Each returned (Located name) has a SrcSpan for the /whole/ declaration.
+-- See Note [SrcSpan for binders]
 
 hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
   = [L loc name]
@@ -769,11 +773,33 @@ hsLTyClDeclBinders (L loc (DataDecl    { tcdLName = L _ name, tcdDataDefn = defn
   = L loc name : hsDataDefnBinders defn
 
 -------------------
-hsInstDeclBinders :: Eq name => InstDecl name -> [Located name]
-hsInstDeclBinders (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } })
+hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name]
+-- See Note [SrcSpan for binders]
+hsForeignDeclsBinders foreign_decls
+  = [ L decl_loc n
+    | L decl_loc (ForeignImport (L _ n) _ _ _) <- foreign_decls]
+
+-------------------
+hsPatSynBinders :: LHsBindsLR idL idR -> [Located idL]
+-- Collect pattern-synonym binders only, not Ids
+-- See Note [SrcSpan for binders]
+hsPatSynBinders binds = foldrBag addPatSynBndr [] binds
+
+addPatSynBndr :: LHsBindLR idL idR -> [Located idL] -> [Located idL]
+-- See Note [SrcSpan for binders]
+addPatSynBndr bind pss
+  | L bind_loc (PatSynBind (PSB { psb_id = L _ n })) <- bind
+  = L bind_loc n : pss
+  | otherwise
+  = pss
+
+-------------------
+hsLInstDeclBinders :: Eq name => LInstDecl name -> [Located name]
+hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))
   = concatMap (hsDataFamInstBinders . unLoc) dfis
-hsInstDeclBinders (DataFamInstD { dfid_inst = fi }) = hsDataFamInstBinders fi
-hsInstDeclBinders (TyFamInstD {}) = []
+hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
+  = hsDataFamInstBinders fi
+hsLInstDeclBinders (L _ (TyFamInstD {})) = []
 
 -------------------
 -- the SrcLoc returned are for the whole declarations, not just the names
@@ -811,6 +837,16 @@ hsConDeclsBinders cons = go id cons
                 (map (L loc . unLoc) names) ++ go remSeen rs
 
 {-
+
+Note [SrcSpan for binders]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+When extracting the (Located RdrNme) for a binder, at least for the
+main name (the TyCon of a type declaration etc), we want to give it
+the @SrcSpan@ of the whole /declaration/, not just the name itself
+(which is how it appears in the syntax tree).  This SrcSpan (for the
+entire declaration) is used as the SrcSpan for the Name that is
+finally produced, and hence for error messages.  (See Trac #8607.)
+
 Note [Binders in family instances]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 In a type or data family instance declaration, the type

compiler/rename/RnBinds.hs

@@ -258,6 +258,9 @@ rnLocalValBindsLHS fix_env binds
          --   g = let f = ... in f
          -- should.
        ; let bound_names = collectHsValBinders binds'
+             -- There should be only Ids, but if there are any bogus
+             -- pattern synonyms, we'll collect them anyway, so that
+             -- we don't generate subsequent out-of-scope messages
        ; envs <- getRdrEnvs
        ; checkDupAndShadowedNames envs bound_names
 
@@ -431,22 +434,27 @@ rnBindLHS name_maker _ bind@(PatBind { pat_lhs = pat })
                 -- gets updated to the FVs of the whole bind
                 -- when doing the RHS below
 
-rnBindLHS name_maker _ bind@(FunBind { fun_id = name@(L nameLoc _) })
-  = do { newname <- applyNameMaker name_maker name
-       ; return (bind { fun_id = L nameLoc newname
+rnBindLHS name_maker _ bind@(FunBind { fun_id = rdr_name })
+  = do { name <- applyNameMaker name_maker rdr_name
+       ; return (bind { fun_id   = name
                       , bind_fvs = placeHolderNamesTc }) }
 
-rnBindLHS name_maker _ (PatSynBind psb@PSB{ psb_id = rdrname@(L nameLoc _) })
-  = do { unless (isTopRecNameMaker name_maker) $
-           addErr localPatternSynonymErr
-       ; addLocM checkConName rdrname
+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
+       ; return (PatSynBind psb{ psb_id = name }) }
+
+  | otherwise  -- Pattern synonym, not at top level
+  = do { addErr localPatternSynonymErr  -- Complain, but make up a fake
+                                        -- name so that we can carry on
        ; name <- applyNameMaker name_maker rdrname
-       ; return (PatSynBind psb{ psb_id = L nameLoc name }) }
+       ; return (PatSynBind psb{ psb_id = name }) }
   where
     localPatternSynonymErr :: SDoc
     localPatternSynonymErr
-      = hang (ptext (sLit "Illegal pattern synonym declaration"))
-           2 (ptext (sLit "Pattern synonym declarations are only valid in the top-level scope"))
+      = hang (ptext (sLit "Illegal pattern synonym declaration for") <+> quotes (ppr rdrname))
+           2 (ptext (sLit "Pattern synonym declarations are only valid at top level"))
 
 rnBindLHS _ _ b = pprPanic "rnBindHS" (ppr b)
 

compiler/rename/RnEnv.hs

@@ -260,7 +260,7 @@ lookupTopBndrRn :: RdrName -> RnM Name
 lookupTopBndrRn n = do nopt <- lookupTopBndrRn_maybe n
                        case nopt of
                          Just n' -> return n'
-                         Nothing -> do traceRn $ text "lookupTopBndrRn"
+                         Nothing -> do traceRn $ (text "lookupTopBndrRn fail" <+> ppr n)
                                        unboundName WL_LocalTop n
 
 lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name)

compiler/rename/RnNames.hs

@@ -491,14 +491,15 @@ getLocalNonValBinders :: MiniFixityEnv -> HsGroup RdrName
 -- Get all the top-level binders bound the group *except*
 -- for value bindings, which are treated separately
 -- Specifically we return AvailInfo for
---      type decls (incl constructors and record selectors)
---      class decls (including class ops)
---      associated types
---      foreign imports
---      (in hs-boot files) value signatures
+--      * type decls (incl constructors and record selectors)
+--      * class decls (including class ops)
+--      * associated types
+--      * foreign imports
+--      * pattern synonyms
+--      * value signatures (in hs-boot files)
 
 getLocalNonValBinders fixity_env
-     (HsGroup { hs_valds  = val_binds,
+     (HsGroup { hs_valds  = binds,
                 hs_tyclds = tycl_decls,
                 hs_instds = inst_decls,
                 hs_fords  = foreign_decls })
@@ -515,11 +516,11 @@ getLocalNonValBinders fixity_env
         ; nti_avails <- concatMapM new_assoc inst_decls
 
           -- Finish off with value binders:
-          --    foreign decls for an ordinary module
+          --    foreign decls and pattern synonyms for an ordinary module
           --    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
+                        | otherwise = for_hs_bndrs ++ patsyn_hs_bndrs
         ; val_avails <- mapM new_simple val_bndrs
 
         ; let avails    = nti_avails ++ val_avails
@@ -529,15 +530,18 @@ getLocalNonValBinders fixity_env
         ; envs <- extendGlobalRdrEnvRn avails fixity_env
         ; return (envs, new_bndrs) } }
   where
+    ValBindsIn val_binds val_sigs = binds
+
     for_hs_bndrs :: [Located RdrName]
-    for_hs_bndrs = [ L decl_loc (unLoc nm)
-                   | L decl_loc (ForeignImport nm _ _ _) <- foreign_decls]
+    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)
                         | L decl_loc (TypeSig ns _ _) <- val_sigs, n <- ns]
-    ValBindsIn _ val_sigs = val_binds
 
       -- the SrcSpan attached to the input should be the span of the
       -- declaration, not just the name

compiler/rename/RnPat.hs

@@ -212,6 +212,11 @@ rnHsSigCps :: HsWithBndrs RdrName (LHsType RdrName)
 rnHsSigCps sig
   = CpsRn (rnHsBndrSig PatCtx sig)
 
+newPatLName :: NameMaker -> Located RdrName -> CpsRn (Located Name)
+newPatLName name_maker rdr_name@(L loc _)
+  = do { name <- newPatName name_maker rdr_name
+       ; return (L loc name) }
+
 newPatName :: NameMaker -> Located RdrName -> CpsRn Name
 newPatName (LamMk report_unused) rdr_name
   = CpsRn (\ thing_inside ->
@@ -307,8 +312,9 @@ rnPat :: HsMatchContext Name -- for error messages
 rnPat ctxt pat thing_inside
   = rnPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat')
 
-applyNameMaker :: NameMaker -> Located RdrName -> RnM Name
-applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatName mk rdr); return n }
+applyNameMaker :: NameMaker -> Located RdrName -> RnM (Located Name)
+applyNameMaker mk rdr = do { (n, _fvs) <- runCps (newPatLName mk rdr)
+                           ; return n }
 
 -- ----------- Entry point 2: rnBindPat -------------------
 -- Binds local names; in a recursive scope that involves other bound vars
@@ -392,17 +398,17 @@ rnPatAndThen _ (NPat lit mb_neg _eq)
        ; return (NPat lit' mb_neg' eq') }
 
 rnPatAndThen mk (NPlusKPat rdr lit _ _)
-  = do { new_name <- newPatName mk rdr
+  = do { new_name <- newPatLName mk rdr
        ; lit'  <- liftCpsFV $ rnOverLit lit
        ; minus <- liftCpsFV $ lookupSyntaxName minusName
        ; ge    <- liftCpsFV $ lookupSyntaxName geName
-       ; return (NPlusKPat (L (nameSrcSpan new_name) new_name) lit' ge minus) }
+       ; return (NPlusKPat new_name lit' ge minus) }
                 -- The Report says that n+k patterns must be in Integral
 
 rnPatAndThen mk (AsPat rdr pat)
-  = do { new_name <- newPatName mk rdr
+  = do { new_name <- newPatLName mk rdr
        ; pat' <- rnLPatAndThen mk pat
-       ; return (AsPat (L (nameSrcSpan new_name) new_name) pat') }
+       ; return (AsPat new_name pat') }
 
 rnPatAndThen mk p@(ViewPat expr pat _ty)
   = do { liftCps $ do { vp_flag <- xoptM Opt_ViewPatterns

compiler/rename/RnSource.hs

@@ -94,9 +94,19 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds   = val_decls,
    local_fix_env <- makeMiniFixityEnv fix_decls ;
 
    -- (B) Bring top level binders (and their fixities) into scope,
-   --     *except* for the value bindings, which get brought in below.
-   --     However *do* include class ops, data constructors
-   --     And for hs-boot files *do* include the value signatures
+   --     *except* for the value bindings, which get done in step (D)
+   --     with collectHsIdBinders. However *do* include
+   --
+   --        * Class ops, data constructors, and record fields,
+   --          because they do not have value declarations.
+   --          Aso step (C) depends on datacons and record fields
+   --
+   --        * Pattern synonyms, becuase they (and data constructors)
+   --          are needed for rnTopBindLHS (Trac #9889)
+   --
+   --        * For hs-boot files, include the value signatures
+   --          Again, they have no value declarations
+   --
    (tc_envs, tc_bndrs) <- getLocalNonValBinders local_fix_env group ;
    setEnvs tc_envs $ do {
 
@@ -114,12 +124,13 @@ 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 ;
+   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 ;
-   traceRn (ptext (sLit "Val binders") <+> (ppr val_binders)) ;
    setEnvs (tcg_env, tcl_env) $ do {
 
    --  Now everything is in scope, as the remaining renaming assumes.
@@ -185,9 +196,8 @@ rnSrcDecls extra_deps group@(HsGroup { hs_valds   = val_decls,
                              hs_vects  = rn_vect_decls,
                              hs_docs   = rn_docs } ;
 
-        tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ;
-        ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ;
-        other_def  = (Just (mkNameSet tycl_bndrs `unionNameSet` mkNameSet ford_bndrs), emptyNameSet) ;
+        tcf_bndrs = hsTyClForeignBinders rn_tycl_decls rn_inst_decls rn_foreign_decls ;
+        other_def  = (Just (mkNameSet tcf_bndrs), emptyNameSet) ;
         other_fvs  = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4,
                               src_fvs5, src_fvs6, src_fvs7, src_fvs8,
                               src_fvs9] ;

compiler/typecheck/TcBinds.hs

@@ -362,9 +362,9 @@ tc_group top_lvl sig_fn prag_fn (NonRecursive, binds) thing_inside
         -- We want to keep non-recursive things non-recursive
         -- so that we desugar unlifted bindings correctly
   = do { let bind = case bagToList binds of
-                 [] -> panic "tc_group: empty list of binds"
                  [bind] -> bind
-                 _ -> panic "tc_group: NonRecursive binds is not a singleton bag"
+                 []     -> panic "tc_group: empty list of binds"
+                 _      -> panic "tc_group: NonRecursive binds is not a singleton bag"
        ; (bind', thing) <- tc_single top_lvl sig_fn prag_fn bind thing_inside
        ; return ( [(NonRecursive, bind')], thing) }
 
@@ -375,9 +375,7 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
         -- (This used to be optional, but isn't now.)
     do  { traceTc "tc_group rec" (pprLHsBinds binds)
         ; when hasPatSyn $ recursivePatSynErr binds
-        ; (binds1, _ids, thing) <- go sccs
-             -- Here is where we should do bindInstsOfLocalFuns
-             -- if we start having Methods again
+        ; (binds1, thing) <- go sccs
         ; return ([(Recursive, binds1)], thing) }
                 -- Rec them all together
   where
@@ -388,12 +386,12 @@ tc_group top_lvl sig_fn prag_fn (Recursive, binds) thing_inside
     sccs :: [SCC (LHsBind Name)]
     sccs = stronglyConnCompFromEdgedVertices (mkEdges sig_fn binds)
 
-    go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, [TcId], thing)
+    go :: [SCC (LHsBind Name)] -> TcM (LHsBinds TcId, thing)
     go (scc:sccs) = do  { (binds1, ids1, closed) <- tc_scc scc
-                        ; (binds2, ids2, thing)  <- tcExtendLetEnv top_lvl closed ids1 $
-                                                    go sccs
-                        ; return (binds1 `unionBags` binds2, ids1 ++ ids2, thing) }
-    go []         = do  { thing <- thing_inside; return (emptyBag, [], thing) }
+                        ; (binds2, thing) <- tcExtendLetEnv top_lvl closed ids1 $
+                                             go sccs
+                        ; return (binds1 `unionBags` binds2, thing) }
+    go []         = do  { thing <- thing_inside; return (emptyBag, thing) }
 
     tc_scc (AcyclicSCC bind) = tc_sub_group NonRecursive [bind]
     tc_scc (CyclicSCC binds) = tc_sub_group Recursive    binds
@@ -417,20 +415,14 @@ tc_single :: forall thing.
 tc_single _top_lvl sig_fn _prag_fn (L _ (PatSynBind psb@PSB{ psb_id = L _ name })) thing_inside
   = do { (pat_syn, aux_binds) <- tc_pat_syn_decl
        ; let tything = AConLike (PatSynCon pat_syn)
--- SLPJ: Why is this necessary?
---             implicit_ids = patSynMatcher pat_syn :
---                            maybeToList (patSynWorker pat_syn)
-
-       ; thing <- tcExtendGlobalEnv [tything] $
---                  tcExtendGlobalEnvImplicit (map AnId implicit_ids) $
-                  thing_inside
+       ; thing <- tcExtendGlobalEnv [tything] thing_inside
        ; return (aux_binds, thing)
        }
   where
     tc_pat_syn_decl = case sig_fn name of
-        Nothing -> tcInferPatSynDecl psb
+        Nothing                  -> tcInferPatSynDecl psb
         Just (TcPatSynInfo tpsi) -> tcCheckPatSynDecl psb tpsi
-        Just _  -> panic "tc_single"
+        Just                  _  -> panic "tc_single"
 
 tc_single top_lvl sig_fn prag_fn lbind thing_inside
   = do { (binds1, ids, closed) <- tcPolyBinds top_lvl sig_fn prag_fn
@@ -445,10 +437,9 @@ noCompleteSig Nothing    = True
 noCompleteSig (Just sig) = isPartialSig sig
 
 ------------------------
-mkEdges :: TcSigFun -> LHsBinds Name
-        -> [(LHsBind Name, BKey, [BKey])]
+mkEdges :: TcSigFun -> LHsBinds Name -> [Node BKey (LHsBind Name)]
 
-type BKey  = Int -- Just number off the bindings
+type BKey = Int -- Just number off the bindings
 
 mkEdges sig_fn binds
   = [ (bind, key, [key | n <- nameSetElems (bind_fvs (unLoc bind)),
@@ -463,24 +454,17 @@ mkEdges sig_fn binds
 
     key_map :: NameEnv BKey     -- Which binding it comes from
     key_map = mkNameEnv [(bndr, key) | (L _ bind, key) <- keyd_binds
-                                     , bndr <- bindersOfHsBind bind ]
-
-bindersOfHsBind :: HsBind Name -> [Name]
-bindersOfHsBind (PatBind { pat_lhs = pat })           = collectPatBinders pat
-bindersOfHsBind (FunBind { fun_id = L _ f })          = [f]
-bindersOfHsBind (PatSynBind PSB{ psb_id = L _ psyn }) = [psyn]
-bindersOfHsBind (AbsBinds {})                         = panic "bindersOfHsBind AbsBinds"
-bindersOfHsBind (VarBind {})                          = panic "bindersOfHsBind VarBind"
+                                     , bndr <- collectHsBindBinders bind ]
 
 ------------------------
 tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun
-            -> RecFlag       -- Whether the group is really recursive
-            -> RecFlag       -- Whether it's recursive after breaking
-                             -- dependencies based on type signatures
-            -> [LHsBind Name]
+            -> RecFlag         -- Whether the group is really recursive
+            -> RecFlag         -- Whether it's recursive after breaking
+                               -- dependencies based on type signatures
+            -> [LHsBind Name]  -- None are PatSynBind
             -> TcM (LHsBinds TcId, [TcId], TopLevelFlag)
 
--- Typechecks a single bunch of bindings all together,
+-- Typechecks a single bunch of values bindings all together,
 -- and generalises them.  The bunch may be only part of a recursive
 -- group, because we use type signatures to maximise polymorphism
 --
@@ -489,6 +473,7 @@ tcPolyBinds :: TopLevelFlag -> TcSigFun -> PragFun
 -- important.
 --
 -- Knows nothing about the scope of the bindings
+-- None of the bindings are pattern synonyms
 
 tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list
   = setSrcSpan loc                              $

testsuite/tests/ghci/scripts/T8776.stdout

-pattern P :: (Num t, Eq t1) => A t t1 	-- Defined at T8776.hs:6:9
+pattern P :: (Num t, Eq t1) => A t t1 	-- Defined at T8776.hs:6:1

testsuite/tests/patsyn/should_compile/T9889.hs

+{-# LANGUAGE PatternSynonyms #-}
+module ShouldCompile where
+
+pattern Id x = x
+
+Id x = True

testsuite/tests/patsyn/should_compile/all.T

@@ -20,3 +20,4 @@ test('T8968-2', normal, compile, [''])
 test('T8968-3', expect_broken(9953), compile, [''])
 test('ImpExp_Imp', [extra_clean(['ImpExp_Exp.hi', 'ImpExp_Exp.o'])], multimod_compile, ['ImpExp_Imp', '-v0'])
 test('T9857', normal, compile, [''])
+test('T9889', normal, compile, [''])

testsuite/tests/patsyn/should_fail/local.stderr

 
 local.hs:7:5:
-    Illegal pattern synonym declaration
-      Pattern synonym declarations are only valid in the top-level scope
+    Illegal pattern synonym declaration for ‘P’
+      Pattern synonym declarations are only valid at top level

testsuite/tests/patsyn/should_run/ghci.stdout

-pattern Single :: t -> [t] 	-- Defined at <interactive>:4:9
+pattern Single :: t -> [t] 	-- Defined at <interactive>:4:1
 foo :: [Bool] -> [Bool]
 [False]