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.
-- 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]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- ** 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(..),
CImportSpec(..),
-- ** Data-constructor declarations
ConDecl(..), LConDecl, ResType(..),
- HsConDeclDetails, hsConDeclArgTys, hsConDeclsNames,
+ HsConDeclDetails, hsConDeclArgTys,
-- ** Document comments
DocDecl(..), LDocDecl, docDeclDoc,
-- ** Deprecations
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
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
-- 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}
%************************************************************************
collectPatBinders, collectPatsBinders,
collectLStmtsBinders, collectStmtsBinders,
collectLStmtBinders, collectStmtBinders,
- collectSigTysFromPats, collectSigTysFromPat
+ collectSigTysFromPats, collectSigTysFromPat,
+
+ hsTyClDeclBinders, hsTyClDeclsBinders, hsConDeclsBinders,
+ hsForeignDeclsBinders, hsGroupBinders
) where
+import HsDecls
import HsBinds
import HsExpr
import HsPat
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
= 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
; 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
; 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}
-- 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
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)
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
, 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
projects / ghc-hetmet.git / commitdiff