X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsUtils.lhs;h=f01fb6e5cc70077824ad802499c9f939012e4a6f;hp=d5ff6f56243d6f76cf7e28100d0dbb7cf9f0e8e7;hb=d2ce0f52d42edf32bb9f13796e6ba6edba8bd516;hpb=f1cc3eb980a634e62f2739a7a25387c902fa9d8a diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index d5ff6f5..f01fb6e 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -19,8 +19,9 @@ module HsUtils( mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt, mkSimpleMatch, unguardedGRHSs, unguardedRHS, mkMatchGroup, mkMatch, mkHsLam, - mkHsWrap, mkLHsWrap, mkHsWrapCoI, coiToHsWrapper, mkHsDictLet, - mkHsOpApp, mkHsDo, + mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI, + coiToHsWrapper, mkHsDictLet, + mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI, nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, @@ -52,14 +53,18 @@ module HsUtils( noRebindableInfo, -- Collecting binders - collectLocalBinders, collectHsValBinders, + collectLocalBinders, collectHsValBinders, collectHsBindListBinders, collectHsBindsBinders, collectHsBindBinders, collectMethodBinders, collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectStmtsBinders, collectLStmtBinders, collectStmtBinders, - collectSigTysFromPats, collectSigTysFromPat + collectSigTysFromPats, collectSigTysFromPat, + + hsTyClDeclBinders, hsTyClDeclsBinders, hsConDeclsBinders, + hsForeignDeclsBinders, hsGroupBinders ) where +import HsDecls import HsBinds import HsExpr import HsPat @@ -128,13 +133,25 @@ mkHsWrap co_fn e | isIdHsWrapper co_fn = e | otherwise = HsWrap co_fn e mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id -mkHsWrapCoI IdCo e = e +mkHsWrapCoI (IdCo _) e = e mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e +mkLHsWrapCoI :: CoercionI -> LHsExpr id -> LHsExpr id +mkLHsWrapCoI (IdCo _) e = e +mkLHsWrapCoI (ACo co) (L loc e) = L loc (mkHsWrap (WpCast co) e) + coiToHsWrapper :: CoercionI -> HsWrapper -coiToHsWrapper IdCo = idHsWrapper +coiToHsWrapper (IdCo _) = idHsWrapper coiToHsWrapper (ACo co) = WpCast co +mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id +mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p + | otherwise = CoPat co_fn p ty + +mkHsWrapPatCoI :: CoercionI -> Pat id -> Type -> Pat id +mkHsWrapPatCoI (IdCo _) pat _ = pat +mkHsWrapPatCoI (ACo co) pat ty = CoPat (WpCast co) pat ty + mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) where @@ -143,14 +160,8 @@ mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) mkMatchGroup :: [LMatch id] -> MatchGroup id mkMatchGroup matches = MatchGroup matches placeHolderType -mkHsDictLet :: LHsBinds Id -> LHsExpr Id -> LHsExpr Id --- Used for the dictionary bindings gotten from TcSimplify --- We make them recursive to be on the safe side -mkHsDictLet binds expr - | isEmptyLHsBinds binds = expr - | otherwise = L (getLoc expr) (HsLet (HsValBinds val_binds) expr) - where - val_binds = ValBindsOut [(Recursive, binds)] [] +mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id +mkHsDictLet ev_binds expr = mkLHsWrap (WpLet ev_binds) expr mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id -- Used for constructing dictionary terms etc, so no locations @@ -215,7 +226,7 @@ mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = [] , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr , recS_bind_fn = noSyntaxExpr - , recS_rec_rets = [], recS_dicts = emptyLHsBinds } + , recS_rec_rets = [], recS_dicts = emptyTcEvBinds } mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } @@ -423,7 +434,7 @@ it should return [x, y, f, a, b] (remember, order important). Note [Collect binders only after renaming] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ These functions should only be used on HsSyn *after* the renamer, -to reuturn a [Name] or [Id]. Before renaming the record punning +to return a [Name] or [Id]. Before renaming the record punning and wild-card mechanism makes it hard to know what is bound. So these functions should not be applied to (HsSyn RdrName) @@ -457,6 +468,9 @@ collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc collectHsBindsBinders :: LHsBindsLR idL idR -> [idL] collectHsBindsBinders binds = collect_binds 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 @@ -503,7 +517,8 @@ collect_lpat (L _ pat) bndrs = go pat where go (VarPat var) = var : bndrs - go (VarPatOut var bs) = var : collect_binds bs bndrs + go (VarPatOut var _) = var : bndrs + -- See Note [Dictionary binders in ConPatOut] go (WildPat _) = bndrs go (LazyPat pat) = collect_lpat pat bndrs go (BangPat pat) = collect_lpat pat bndrs @@ -555,6 +570,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