Commit 241c6ba5 authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Refactoring of hsXxxBinders

This patch moves various functions that extract the binders
from a HsTyClDecl, HsForeignDecl etc into HsUtils, and gives
them consistent names.
parent 215ce9f1
......@@ -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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
......
......@@ -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}
%************************************************************************
......
......@@ -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
......
......@@ -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}
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment