X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsUtils.lhs;h=526f7eb4d1c23b46f9424adfaf1aa1a3dbcc6751;hp=3ef4bff17714c8368846410c0c35cbe7b0c1aa98;hb=ffabe3acb2d30be0c8e89e139f5bca7a1eb900f6;hpb=6ea06bbf08517d9805feb82df65cc56ecbaf23a4 diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 3ef4bff..526f7eb 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -20,14 +20,14 @@ module HsUtils( mkSimpleMatch, unguardedGRHSs, unguardedRHS, mkMatchGroup, mkMatch, mkHsLam, mkHsIf, mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI, - coiToHsWrapper, mkHsDictLet, - mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI, + coiToHsWrapper, mkHsLams, mkHsDictLet, + mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCoI, nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, - -- Bindigns + -- Bindings mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, -- Literals @@ -42,8 +42,8 @@ module HsUtils( nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, -- Stmts - mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, - mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, + mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt, + emptyTransStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, emptyRecStmt, mkRecStmt, -- Template Haskell @@ -61,7 +61,10 @@ module HsUtils( collectSigTysFromPats, collectSigTysFromPat, hsTyClDeclBinders, hsTyClDeclsBinders, - hsForeignDeclsBinders, hsGroupBinders + 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 @@ -181,14 +190,13 @@ mkSimpleHsAlt pat expr mkHsIntegral :: Integer -> PostTcType -> HsOverLit id mkHsFractional :: Rational -> PostTcType -> HsOverLit id mkHsIsString :: FastString -> PostTcType -> HsOverLit id -mkHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id +mkHsDo :: HsStmtContext Name -> [LStmt id] -> HsExpr id +mkHsComp :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id mkNPlusKPat :: Located id -> HsOverLit id -> Pat id -mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR -mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR - +mkLastStmt :: LHsExpr idR -> StmtLR idL idR mkExprStmt :: LHsExpr idR -> StmtLR idL idR mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR @@ -203,7 +211,10 @@ mkHsIsString s = OverLit (HsIsString s) noRebindableInfo noSyntaxExpr noRebindableInfo :: Bool noRebindableInfo = error "noRebindableInfo" -- Just another placeholder; -mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType +mkHsDo ctxt stmts = HsDo ctxt stmts placeHolderType +mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) + where + last_stmt = L (getLoc expr) $ mkLastStmt expr mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b @@ -211,24 +222,32 @@ 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 -mkTransformStmt stmts usingExpr = TransformStmt stmts [] usingExpr Nothing -mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr) - +mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR +mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR mkGroupUsingStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR mkGroupByStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR -mkGroupUsingStmt stmts usingExpr = GroupStmt stmts [] Nothing (Left usingExpr) -mkGroupByStmt stmts byExpr = GroupStmt stmts [] (Just byExpr) (Right noSyntaxExpr) -mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt stmts [] (Just byExpr) (Left usingExpr) - -mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType +emptyTransStmt :: StmtLR idL idR +emptyTransStmt = TransStmt { trS_form = undefined, trS_stmts = [], trS_bndrs = [] + , trS_by = Nothing, trS_using = noLoc noSyntaxExpr + , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr + , trS_fmap = noSyntaxExpr } +mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u } +mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b } +mkGroupByStmt ss b = emptyTransStmt { trS_form = GroupFormB, trS_stmts = ss, trS_by = Just b } +mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupFormU, trS_stmts = ss, trS_using = u } +mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupFormU, trS_stmts = ss + , trS_by = Just b, trS_using = u } + +mkLastStmt expr = LastStmt expr noSyntaxExpr +mkExprStmt expr = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType 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_rec_rets = [], recS_ret_ty = placeHolderType } mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } @@ -318,8 +337,8 @@ nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) nlWildPat :: LPat id nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking -nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id -nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body) +nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id +nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) @@ -487,12 +506,12 @@ collectStmtBinders :: StmtLR idL idR -> [idL] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat collectStmtBinders (LetStmt binds) = collectLocalBinders binds -collectStmtBinders (ExprStmt _ _ _) = [] -collectStmtBinders (ParStmt xs) = collectLStmtsBinders +collectStmtBinders (ExprStmt {}) = [] +collectStmtBinders (LastStmt {}) = [] +collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders $ concatMap fst xs -collectStmtBinders (TransformStmt stmts _ _ _) = collectLStmtsBinders stmts -collectStmtBinders (GroupStmt stmts _ _ _) = collectLStmtsBinders stmts -collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss +collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts +collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss ----------------- Patterns -------------------------- @@ -529,7 +548,6 @@ collect_lpat (L _ pat) bndrs go (SigPatIn pat _) = collect_lpat pat bndrs go (SigPatOut pat _) = collect_lpat pat bndrs go (QuasiQuotePat _) = bndrs - go (TypePat _) = bndrs go (CoPat _ pat _) = go pat \end{code} @@ -614,6 +632,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 (LastStmt {}) = emptyNameSet + hs_stmt (ParStmt xs _ _ _) = hs_lstmts $ concatMap fst xs + + hs_stmt (TransStmt { trS_stmts = 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 %* * %************************************************************************ @@ -630,7 +723,6 @@ collect_sig_lpat pat acc = collect_sig_pat (unLoc pat) acc collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name] collect_sig_pat (SigPatIn pat ty) acc = collect_sig_lpat pat (ty:acc) -collect_sig_pat (TypePat ty) acc = ty:acc collect_sig_pat (LazyPat pat) acc = collect_sig_lpat pat acc collect_sig_pat (BangPat pat) acc = collect_sig_lpat pat acc