diff options
| -rw-r--r-- | compiler/deSugar/DsMeta.hs | 12 | ||||
| -rw-r--r-- | compiler/hsSyn/HsDecls.lhs | 43 | ||||
| -rw-r--r-- | compiler/hsSyn/HsUtils.lhs | 58 | ||||
| -rw-r--r-- | compiler/rename/RnNames.lhs | 7 | ||||
| -rw-r--r-- | compiler/rename/RnSource.lhs | 5 | ||||
| -rw-r--r-- | compiler/typecheck/TcDeriv.lhs | 5 | ||||
| -rw-r--r-- | utils/ghctags/Main.hs | 2 |
7 files changed, 69 insertions, 63 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 3f7f4d02f8..6b3d216f26 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs index baf6eca76f..dc4bac71ee 100644 --- a/compiler/hsSyn/HsDecls.lhs +++ b/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} %************************************************************************ diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index d5ff6f5624..0e4b0dbb38 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/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 diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index d82bea968c..2c0a45bc3b 100644 --- a/compiler/rename/RnNames.lhs +++ b/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} diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index a152a18a07..9b04da051c 100644 --- a/compiler/rename/RnSource.lhs +++ b/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) diff --git a/compiler/typecheck/TcDeriv.lhs b/compiler/typecheck/TcDeriv.lhs index 3a05380752..af68408459 100644 --- a/compiler/typecheck/TcDeriv.lhs +++ b/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 diff --git a/utils/ghctags/Main.hs b/utils/ghctags/Main.hs index 9017bd045b..9093e032e9 100644 --- a/utils/ghctags/Main.hs +++ b/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 |