X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsUtils.lhs;h=de883f25a5bd1d959c7eaf45bb11b6ba7d5cd7b6;hp=cfd2799bc88291413d895c1077d4b571674978b0;hb=d76d9636aeebe933d160157331b8c8c0087e73ac;hpb=40612c9014ef04806cd341a12cf010db51eca2e3 diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index cfd2799..de883f2 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -18,16 +18,17 @@ module HsUtils( -- Terms mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt, mkSimpleMatch, unguardedGRHSs, unguardedRHS, - mkMatchGroup, mkMatch, mkHsLam, - mkHsWrap, mkLHsWrap, mkHsWrapCoI, coiToHsWrapper, mkHsDictLet, - mkHsOpApp, mkHsDo, + mkMatchGroup, mkMatch, mkHsLam, mkHsIf, + mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI, + coiToHsWrapper, mkHsLams, mkHsDictLet, + mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCoI, mkDoStmts, nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, -- Bindigns - mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mk_FunBind, + mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, -- Literals mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, @@ -41,8 +42,8 @@ module HsUtils( nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, -- Stmts - mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, - mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, + mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt, + emptyGroupStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, emptyRecStmt, mkRecStmt, -- Template Haskell @@ -52,15 +53,18 @@ module HsUtils( noRebindableInfo, -- Collecting binders - collectLocalBinders, collectHsValBinders, + collectLocalBinders, collectHsValBinders, collectHsBindListBinders, collectHsBindsBinders, collectHsBindBinders, collectMethodBinders, collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectStmtsBinders, collectLStmtBinders, collectStmtBinders, collectSigTysFromPats, collectSigTysFromPat, - hsTyClDeclBinders, hsTyClDeclsBinders, hsConDeclsBinders, - hsForeignDeclsBinders, hsGroupBinders + hsTyClDeclBinders, hsTyClDeclsBinders, + hsForeignDeclsBinders, hsGroupBinders, + + -- Collecting implicit binders + lStmtsImplicits, hsValBindsImplicits, lPatImplicits ) where import HsDecls @@ -83,6 +87,8 @@ import FastString import Outputable import Util import Bag + +import Data.Either \end{code} @@ -132,13 +138,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 @@ -147,14 +165,11 @@ 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)] [] +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 (mkWpLet ev_binds) expr mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id -- Used for constructing dictionary terms etc, so no locations @@ -175,7 +190,9 @@ 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 +mkDoStmts :: [LStmt id] -> [LStmt id] mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id mkNPlusKPat :: Located id -> HsOverLit id -> Pat id @@ -183,6 +200,7 @@ 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 @@ -197,29 +215,47 @@ mkHsIsString s = OverLit (HsIsString s) noRebindableInfo noSyntaxExpr noRebindableInfo :: Bool noRebindableInfo = error "noRebindableInfo" -- Just another placeholder; -mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType +-- mkDoStmts turns a trailing ExprStmt into a LastStmt +mkDoStmts [L loc (ExprStmt e _ _ _)] = [L loc (mkLastStmt e)] +mkDoStmts (s:ss) = s : mkDoStmts ss +mkDoStmts [] = [] + +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 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 stmts usingExpr = TransformStmt stmts [] usingExpr Nothing noSyntaxExpr noSyntaxExpr +mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr) noSyntaxExpr noSyntaxExpr 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 +emptyGroupStmt :: StmtLR idL idR +emptyGroupStmt = GroupStmt { grpS_stmts = [], grpS_bndrs = [], grpS_explicit = False + , grpS_by = Nothing, grpS_using = noLoc noSyntaxExpr + , grpS_ret = noSyntaxExpr, grpS_bind = noSyntaxExpr + , grpS_fmap = noSyntaxExpr } +mkGroupUsingStmt ss u = emptyGroupStmt { grpS_stmts = ss, grpS_explicit = True, grpS_using = u } +mkGroupByStmt ss b = emptyGroupStmt { grpS_stmts = ss, grpS_by = Just b } +mkGroupByUsingStmt ss b u = emptyGroupStmt { grpS_stmts = ss, grpS_by = Just b + , grpS_explicit = True, grpS_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_dicts = emptyLHsBinds } + , recS_rec_rets = [], recS_ret_ty = placeHolderType } mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } @@ -309,8 +345,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) @@ -323,7 +359,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) @@ -387,17 +423,6 @@ mk_easy_FunBind loc fun pats expr = L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds] ------------ -mk_FunBind :: SrcSpan -> id - -> [([LPat id], LHsExpr id)] - -> LHsBind id - -mk_FunBind _ _ [] = panic "TcGenDeriv:mk_FunBind" -mk_FunBind loc fun pats_and_exprs - = L loc $ mkFunBind (L loc fun) matches - where - matches = [mkMatch p e emptyLocalBinds | (p,e) <-pats_and_exprs] - ------------- mkMatch :: [LPat id] -> LHsExpr id -> HsLocalBinds id -> LMatch id mkMatch pats expr binds = noLoc (Match (map paren pats) Nothing @@ -461,6 +486,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 @@ -486,12 +514,13 @@ 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 (TransformStmt stmts _ _ _ _ _) = collectLStmtsBinders stmts +collectStmtBinders (GroupStmt { grpS_stmts = stmts }) = collectLStmtsBinders stmts +collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss ----------------- Patterns -------------------------- @@ -507,7 +536,6 @@ collect_lpat (L _ pat) bndrs = go pat where go (VarPat var) = var : bndrs - go (VarPatOut var bs) = var : collect_binds bs bndrs go (WildPat _) = bndrs go (LazyPat pat) = collect_lpat pat bndrs go (BangPat pat) = collect_lpat pat bndrs @@ -572,9 +600,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. @@ -613,6 +642,82 @@ 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 (TransformStmt stmts _ _ _ _ _) = hs_lstmts stmts + hs_stmt (GroupStmt { grpS_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 %* * %************************************************************************