Refactoring of hsXxxBinders

This patch moves various functions that extract the binders
from a HsTyClDecl, HsForeignDecl etc into HsUtils, and gives
them consistent names.

compiler/deSugar/DsMeta.hs

@@ -106,7 +106,7 @@ repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat)
 
 repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec]))
 repTopDs group
- = do { let { bndrs = groupBinders group } ;
+ = do { let { bndrs = hsGroupBinders group } ;
 	ss <- mkGenSyms bndrs ;
 
 	-- Bind all the names mainly to avoid repeated use of explicit strings.
@@ -135,16 +135,6 @@ repTopDs group
 	-- Do *not* gensym top-level binders
       }
 
-groupBinders :: HsGroup Name -> [Name]
-groupBinders (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 ++
-    [n | d <- tycl_decls ++ assoc_tycl_decls, L _ n <- tyClDeclNames (unLoc d)] ++
-    [n | L _ (ForeignImport (L _ n) _ _) <- foreign_decls]
-  where
-    assoc_tycl_decls = concat [ats | L _ (InstDecl _ _ _ ats) <- inst_decls]
-
 
 {- 	Note [Binders and occurrences]
 	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

compiler/hsSyn/HsDecls.lhs

@@ -24,7 +24,7 @@ module HsDecls (
   -- ** Class or type declarations
   TyClDecl(..), LTyClDecl,
   isClassDecl, isSynDecl, isDataDecl, isTypeDecl, isFamilyDecl,
-  isFamInstDecl, tcdName, tyClDeclNames, tyClDeclTyVars,
+  isFamInstDecl, tcdName, tyClDeclTyVars,
   countTyClDecls,
   -- ** Instance declarations
   InstDecl(..), LInstDecl, NewOrData(..), FamilyFlavour(..),
@@ -43,7 +43,7 @@ module HsDecls (
   CImportSpec(..),
   -- ** Data-constructor declarations
   ConDecl(..), LConDecl, ResType(..), 
-  HsConDeclDetails, hsConDeclArgTys, hsConDeclsNames,
+  HsConDeclDetails, hsConDeclArgTys, 
   -- ** Document comments
   DocDecl(..), LDocDecl, docDeclDoc,
   -- ** Deprecations
@@ -544,23 +544,6 @@ Dealing with names
 tcdName :: TyClDecl name -> name
 tcdName decl = unLoc (tcdLName decl)
 
-tyClDeclNames :: Eq name => TyClDecl name -> [Located name]
--- ^ Returns all the /binding/ names of the decl, along with their SrcLocs.
--- The first one is guaranteed to be the name of the decl. For record fields
--- mentioned in multiple constructors, the SrcLoc will be from the first
--- occurence.  We use the equality to filter out duplicate field names
-
-tyClDeclNames (TyFamily    {tcdLName = name})    = [name]
-tyClDeclNames (TySynonym   {tcdLName = name})    = [name]
-tyClDeclNames (ForeignType {tcdLName = name})    = [name]
-
-tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})
-  = cls_name : 
-    concatMap (tyClDeclNames . unLoc) ats ++ [n | L _ (TypeSig n _) <- sigs]
-
-tyClDeclNames (TyData {tcdLName = tc_name, tcdCons = cons})
-  = tc_name : hsConDeclsNames cons
-
 tyClDeclTyVars :: TyClDecl name -> [LHsTyVarBndr name]
 tyClDeclTyVars (TyFamily    {tcdTyVars = tvs}) = tvs
 tyClDeclTyVars (TySynonym   {tcdTyVars = tvs}) = tvs
@@ -757,24 +740,6 @@ instance OutputableBndr name => Outputable (ResType name) where
    ppr (ResTyGADT ty) = ptext (sLit "ResTyGADT") <+> pprParendHsType (unLoc ty)
 \end{code}
 
-\begin{code}
-hsConDeclsNames :: (Eq name) => [LConDecl name] -> [Located name]
-  -- See tyClDeclNames for what this does
-  -- The function is boringly complicated because of the records
-  -- And since we only have equality, we have to be a little careful
-hsConDeclsNames cons
-  = snd (foldl do_one ([], []) cons)
-  where
-    do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname, con_details = RecCon flds }))
-	= (map unLoc new_flds ++ flds_seen, lname : new_flds ++ acc)
-	where
-	  new_flds = filterOut (\f -> unLoc f `elem` flds_seen) 
-			       (map cd_fld_name flds)
-
-    do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname }))
-	= (flds_seen, lname:acc)
-\end{code}
-  
 
 \begin{code}
 instance (OutputableBndr name) => Outputable (ConDecl name) where
@@ -837,8 +802,8 @@ instance (OutputableBndr name) => Outputable (InstDecl name) where
 
 -- Extract the declarations of associated types from an instance
 --
-instDeclATs :: InstDecl name -> [LTyClDecl name]
-instDeclATs (InstDecl _ _ _ ats) = ats
+instDeclATs :: [LInstDecl name] -> [LTyClDecl name]
+instDeclATs inst_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats]
 \end{code}
 
 %************************************************************************

compiler/hsSyn/HsUtils.lhs

@@ -57,9 +57,13 @@ module HsUtils(
   collectPatBinders, collectPatsBinders,
   collectLStmtsBinders, collectStmtsBinders,
   collectLStmtBinders, collectStmtBinders,
-  collectSigTysFromPats, collectSigTysFromPat
+  collectSigTysFromPats, collectSigTysFromPat,
+
+  hsTyClDeclBinders, hsTyClDeclsBinders, hsConDeclsBinders, 
+  hsForeignDeclsBinders, hsGroupBinders
   ) where
 
+import HsDecls
 import HsBinds
 import HsExpr
 import HsPat
@@ -555,6 +559,58 @@ and *also* uses that dictionary to match the (n+1) pattern.  Yet, the
 variables bound by the lazy pattern are n,m, *not* the dictionary d.
 So in mkSelectorBinds in DsUtils, we want just m,n as the variables bound.
 
+\begin{code}
+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]
+
+hsTyClDeclsBinders :: [Located (TyClDecl Name)] -> [Located (InstDecl Name)] -> [Name]
+hsTyClDeclsBinders tycl_decls inst_decls
+  = [n | d <- instDeclATs inst_decls ++ tycl_decls, L _ n <- hsTyClDeclBinders d]
+
+hsTyClDeclBinders :: Eq name => Located (TyClDecl name) -> [Located name]
+-- ^ Returns all the /binding/ names of the decl, along with their SrcLocs.
+-- The first one is guaranteed to be the name of the decl. For record fields
+-- mentioned in multiple constructors, the SrcLoc will be from the first
+-- occurence.  We use the equality to filter out duplicate field names
+
+hsTyClDeclBinders (L _ (TyFamily    {tcdLName = name})) = [name]
+hsTyClDeclBinders (L _ (TySynonym   {tcdLName = name})) = [name]
+hsTyClDeclBinders (L _ (ForeignType {tcdLName = name})) = [name]
+
+hsTyClDeclBinders (L _ (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats}))
+  = cls_name : 
+    concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig n _) <- sigs]
+
+hsTyClDeclBinders (L _ (TyData {tcdLName = tc_name, tcdCons = cons}))
+  = tc_name : hsConDeclsBinders cons
+
+hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name]
+  -- See hsTyClDeclBinders for what this does
+  -- The function is boringly complicated because of the records
+  -- And since we only have equality, we have to be a little careful
+hsConDeclsBinders cons
+  = snd (foldl do_one ([], []) cons)
+  where
+    do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname, con_details = RecCon flds }))
+	= (map unLoc new_flds ++ flds_seen, lname : new_flds ++ acc)
+	where
+	  new_flds = filterOut (\f -> unLoc f `elem` flds_seen) 
+			       (map cd_fld_name flds)
+
+    do_one (flds_seen, acc) (L _ (ConDecl { con_name = lname }))
+	= (flds_seen, lname:acc)
+\end{code}
+
+
 %************************************************************************
 %*									*
 	Collecting type signatures from patterns

compiler/rename/RnNames.lhs

@@ -394,8 +394,7 @@ get_local_binders gbl_env (HsGroup {hs_valds  = ValBindsIn _ val_sigs,
   = do	{   -- separate out the family instance declarations
           let (tyinst_decls1, tycl_decls_noinsts) 
                            = partition (isFamInstDecl . unLoc) tycl_decls
-              tyinst_decls = tyinst_decls1 ++ 
-                             concatMap (instDeclATs . unLoc) inst_decls 
+              tyinst_decls = tyinst_decls1 ++ instDeclATs inst_decls
 
             -- process all type/class decls except family instances
         ; tc_names  <- mapM new_tc tycl_decls_noinsts
@@ -433,7 +432,7 @@ get_local_binders gbl_env (HsGroup {hs_valds  = ValBindsIn _ val_sigs,
 	     ; sub_names <- mapM (newTopSrcBinder mod) sub_rdrs
 	     ; return (AvailTC main_name (main_name : sub_names)) }
       where
-	(main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl)
+	(main_rdr : sub_rdrs) = hsTyClDeclBinders tc_decl
 
     new_ti tc_name_env ti_decl  -- ONLY for type/data instances
 	= do { main_name <- lookupFamInstDeclBndr tc_name_env main_rdr
@@ -441,7 +440,7 @@ get_local_binders gbl_env (HsGroup {hs_valds  = ValBindsIn _ val_sigs,
 	     ; return (AvailTC main_name sub_names) }
                 	-- main_name is not bound here!
       where
-	(main_rdr : sub_rdrs) = tyClDeclNames (unLoc ti_decl)
+	(main_rdr : sub_rdrs) = hsTyClDeclBinders ti_decl
 
 get_local_binders _ g = pprPanic "get_local_binders" (ppr g)
 \end{code}

compiler/rename/RnSource.lhs

@@ -466,7 +466,7 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats)
 	-- The typechecker (not the renamer) checks that all 
 	-- the declarations are for the right class
     let
-	at_names = map (head . tyClDeclNames . unLoc) ats
+	at_names = map (head . hsTyClDeclBinders) ats
     in
     checkDupRdrNames at_names		`thenM_`
 	-- See notes with checkDupRdrNames for methods, above
@@ -1059,8 +1059,7 @@ extendRecordFieldEnv tycl_decls inst_decls
     all_data_cons = [con | L _ (TyData { tcdCons = cons }) <- all_tycl_decls
     		         , L _ con <- cons ]
     all_tycl_decls = at_tycl_decls ++ tycl_decls
-    at_tycl_decls = [at | L _ (InstDecl _ _ _ ats) <- inst_decls, at <- ats]
-    		      -- Do not forget associated types!
+    at_tycl_decls = instDeclATs inst_decls  -- Do not forget associated types!
 
     get_con (ConDecl { con_name = con, con_details = RecCon flds })
 	    (RecFields env fld_set)

compiler/typecheck/TcDeriv.lhs

@@ -436,10 +436,7 @@ makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls
 
     all_tydata :: [(LHsType Name, LTyClDecl Name)]
 	-- Derived predicate paired with its data type declaration
-    all_tydata = extractTyDataPreds tycl_decls ++
-		 [ pd                -- Traverse assoc data families
-                 | L _ (InstDecl _ _ _ ats) <- inst_decls
-		 , pd <- extractTyDataPreds ats ]
+    all_tydata = extractTyDataPreds (instDeclATs inst_decls ++ tycl_decls)
 
     deriv_locs = map (getLoc . snd) all_tydata
 		 ++ map getLoc deriv_decls

utils/ghctags/Main.hs

@@ -251,7 +251,7 @@ boundValues mod group =
                        , bind <- bagToList binds
                        , x <- boundThings mod bind ]
                _other -> error "boundValues"
-      tys = [ n | ns <- map (tyClDeclNames . unLoc) (hs_tyclds group)
+      tys = [ n | ns <- map hsTyClDeclBinders (hs_tyclds group)
                 , n <- map found ns ]
       fors = concat $ map forBound (hs_fords group)
              where forBound lford = case unLoc lford of