X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsUtils.lhs;h=13f3cd7e55e0087738d0bdb09075503ef60955ef;hp=ea2432702889c9cf9cc2a536e0e7c7f0e49f50f2;hb=16b9e80dc14db24509f051f294b5b51943285090;hpb=2fc5aa708982a414235d3aff68dea4329b546063 diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index ea24327..13f3cd7 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -18,9 +18,9 @@ module HsUtils( -- Terms mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt, mkSimpleMatch, unguardedGRHSs, unguardedRHS, - mkMatchGroup, mkMatch, mkHsLam, + mkMatchGroup, mkMatch, mkHsLam, mkHsIf, mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI, - coiToHsWrapper, mkHsDictLet, + coiToHsWrapper, mkHsLams, mkHsDictLet, mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI, nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, @@ -60,8 +60,11 @@ module HsUtils( collectLStmtBinders, collectStmtBinders, collectSigTysFromPats, collectSigTysFromPat, - hsTyClDeclBinders, hsTyClDeclsBinders, hsConDeclsBinders, - hsForeignDeclsBinders, hsGroupBinders + hsTyClDeclBinders, hsTyClDeclsBinders, + hsForeignDeclsBinders, hsGroupBinders, + + -- Collecting implicit binders + lStmtsImplicits, hsValBindsImplicits, lPatImplicits ) where import HsDecls @@ -81,8 +84,11 @@ import NameSet import BasicTypes import SrcLoc import FastString +import Outputable import Util import Bag + +import Data.Either \end{code} @@ -159,8 +165,11 @@ mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) mkMatchGroup :: [LMatch id] -> MatchGroup id mkMatchGroup matches = MatchGroup matches placeHolderType +mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id +mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr + mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id -mkHsDictLet ev_binds expr = mkLHsWrap (WpLet ev_binds) expr +mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id -- Used for constructing dictionary terms etc, so no locations @@ -205,6 +214,9 @@ noRebindableInfo = error "noRebindableInfo" -- Just another placeholder; mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType +mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id +mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b + mkNPat lit neg = NPat lit neg noSyntaxExpr mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr @@ -225,7 +237,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 = emptyTcEvBinds } + , recS_rec_rets = [] } mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } @@ -329,7 +341,7 @@ nlList :: [LHsExpr id] -> LHsExpr id nlHsLam match = noLoc (HsLam (mkMatchGroup [match])) nlHsPar e = noLoc (HsPar e) -nlHsIf cond true false = noLoc (HsIf cond true false) +nlHsIf cond true false = noLoc (mkHsIf cond true false) nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup matches)) nlList exprs = noLoc (ExplicitList placeHolderType exprs) @@ -505,8 +517,6 @@ collect_lpat (L _ pat) bndrs = go pat where go (VarPat var) = var : 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 @@ -571,9 +581,10 @@ hsForeignDeclsBinders :: [LForeignDecl Name] -> [Name] hsForeignDeclsBinders foreign_decls = [n | L _ (ForeignImport (L _ n) _ _) <- foreign_decls] -hsTyClDeclsBinders :: [Located (TyClDecl Name)] -> [Located (InstDecl Name)] -> [Name] +hsTyClDeclsBinders :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name] hsTyClDeclsBinders tycl_decls inst_decls - = [n | d <- instDeclATs inst_decls ++ tycl_decls, L _ n <- hsTyClDeclBinders d] + = [n | d <- instDeclATs inst_decls ++ concat 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. @@ -612,6 +623,81 @@ hsConDeclsBinders cons %************************************************************************ %* * + Collecting binders the user did not write +%* * +%************************************************************************ + +The job of this family of functions is to run through binding sites and find the set of all Names +that were defined "implicitly", without being explicitly written by the user. + +The main purpose is to find names introduced by record wildcards so that we can avoid +warning the user when they don't use those names (#4404) + +\begin{code} +lStmtsImplicits :: [LStmtLR Name idR] -> NameSet +lStmtsImplicits = hs_lstmts + where + hs_lstmts :: [LStmtLR Name idR] -> NameSet + hs_lstmts = foldr (\stmt rest -> unionNameSets (hs_stmt (unLoc stmt)) rest) emptyNameSet + + hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat + hs_stmt (LetStmt binds) = hs_local_binds binds + hs_stmt (ExprStmt _ _ _) = emptyNameSet + hs_stmt (ParStmt xs) = hs_lstmts $ concatMap fst xs + + hs_stmt (TransformStmt stmts _ _ _) = hs_lstmts stmts + hs_stmt (GroupStmt stmts _ _ _) = hs_lstmts stmts + hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss + + hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds + hs_local_binds (HsIPBinds _) = emptyNameSet + hs_local_binds EmptyLocalBinds = emptyNameSet + +hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet +hsValBindsImplicits (ValBindsOut binds _) + = unionManyNameSets [foldBag unionNameSets (hs_bind . unLoc) emptyNameSet hs_binds | (_rec, hs_binds) <- binds] + where + hs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat + hs_bind _ = emptyNameSet +hsValBindsImplicits (ValBindsIn {}) = pprPanic "hsValBindsImplicits: ValBindsIn" empty + +lPatImplicits :: LPat Name -> NameSet +lPatImplicits = hs_lpat + where + hs_lpat (L _ pat) = hs_pat pat + + hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSets` rest) emptyNameSet + + hs_pat (LazyPat pat) = hs_lpat pat + hs_pat (BangPat pat) = hs_lpat pat + hs_pat (AsPat _ pat) = hs_lpat pat + hs_pat (ViewPat _ pat _) = hs_lpat pat + hs_pat (ParPat pat) = hs_lpat pat + hs_pat (ListPat pats _) = hs_lpats pats + hs_pat (PArrPat pats _) = hs_lpats pats + hs_pat (TuplePat pats _ _) = hs_lpats pats + + hs_pat (SigPatIn pat _) = hs_lpat pat + hs_pat (SigPatOut pat _) = hs_lpat pat + hs_pat (CoPat _ pat _) = hs_pat pat + + hs_pat (ConPatIn _ ps) = details ps + hs_pat (ConPatOut {pat_args=ps}) = details ps + + hs_pat _ = emptyNameSet + + details (PrefixCon ps) = hs_lpats ps + details (RecCon fs) = hs_lpats explicit `unionNameSets` mkNameSet (collectPatsBinders implicit) + where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat + | (i, fld) <- [0..] `zip` rec_flds fs + , let pat = hsRecFieldArg fld + pat_explicit = maybe True (i<) (rec_dotdot fs)] + details (InfixCon p1 p2) = hs_lpat p1 `unionNameSets` hs_lpat p2 +\end{code} + + +%************************************************************************ +%* * Collecting type signatures from patterns %* * %************************************************************************