X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FHsUtils.lhs;h=de883f25a5bd1d959c7eaf45bb11b6ba7d5cd7b6;hp=5d106f191d3153349162b490630caa4eedecfaae;hb=d76d9636aeebe933d160157331b8c8c0087e73ac;hpb=67cb409159fa9136dff942b8baaec25909416022 diff --git a/compiler/hsSyn/HsUtils.lhs b/compiler/hsSyn/HsUtils.lhs index 5d106f1..de883f2 100644 --- a/compiler/hsSyn/HsUtils.lhs +++ b/compiler/hsSyn/HsUtils.lhs @@ -1,3 +1,4 @@ + % % (c) The University of Glasgow, 1992-2006 % @@ -13,17 +14,60 @@ which deal with the intantiated versions are located elsewhere: Id typecheck/TcHsSyn \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - -module HsUtils where - -#include "HsVersions.h" - +module HsUtils( + -- Terms + mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt, + mkSimpleMatch, unguardedGRHSs, unguardedRHS, + 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, + + -- Literals + mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, + + -- Patterns + mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConPat, nlInfixConPat, + nlNullaryConPat, nlWildConPat, nlWildPat, nlTuplePat, + + -- Types + mkHsAppTy, userHsTyVarBndrs, + nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, + + -- Stmts + mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt, + emptyGroupStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, + emptyRecStmt, mkRecStmt, + + -- Template Haskell + unqualSplice, mkHsSpliceTy, mkHsSplice, mkHsQuasiQuote, unqualQuasiQuote, + + -- Flags + noRebindableInfo, + + -- Collecting binders + collectLocalBinders, collectHsValBinders, collectHsBindListBinders, + collectHsBindsBinders, collectHsBindBinders, collectMethodBinders, + collectPatBinders, collectPatsBinders, + collectLStmtsBinders, collectStmtsBinders, + collectLStmtBinders, collectStmtBinders, + collectSigTysFromPats, collectSigTysFromPat, + + hsTyClDeclBinders, hsTyClDeclsBinders, + hsForeignDeclsBinders, hsGroupBinders, + + -- Collecting implicit binders + lStmtsImplicits, hsValBindsImplicits, lPatImplicits + ) where + +import HsDecls import HsBinds import HsExpr import HsPat @@ -36,12 +80,15 @@ import Coercion import Type import DataCon import Name +import NameSet import BasicTypes import SrcLoc import FastString import Outputable import Util import Bag + +import Data.Either \end{code} @@ -91,12 +138,24 @@ mkHsWrap co_fn e | isIdHsWrapper co_fn = e | otherwise = HsWrap co_fn e mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id -mkHsWrapCoI IdCo e = e -mkHsWrapCoI (ACo co) e = mkHsWrap (WpCo co) 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 (ACo co) = WpCo co +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)) @@ -106,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 @@ -131,41 +187,109 @@ mkSimpleHsAlt pat expr -- These are the bits of syntax that contain rebindable names -- See RnEnv.lookupSyntaxName -mkHsIntegral i = HsIntegral i noSyntaxExpr -mkHsFractional f = HsFractional f noSyntaxExpr -mkHsIsString s = HsIsString s noSyntaxExpr -mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType +mkHsIntegral :: Integer -> PostTcType -> HsOverLit id +mkHsFractional :: Rational -> PostTcType -> HsOverLit id +mkHsIsString :: FastString -> PostTcType -> HsOverLit 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 + +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 + +emptyRecStmt :: StmtLR idL idR +mkRecStmt :: [LStmtLR idL idR] -> StmtLR idL idR + + +mkHsIntegral i = OverLit (HsIntegral i) noRebindableInfo noSyntaxExpr +mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noSyntaxExpr +mkHsIsString s = OverLit (HsIsString s) noRebindableInfo noSyntaxExpr + +noRebindableInfo :: Bool +noRebindableInfo = error "noRebindableInfo" -- Just another placeholder; + +-- 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 + +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 -mkGroupUsingStmt stmts usingExpr = GroupStmt (stmts, []) (GroupByNothing usingExpr) -mkGroupByStmt stmts byExpr = GroupStmt (stmts, []) (GroupBySomething (Right noSyntaxExpr) byExpr) -mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt (stmts, []) (GroupBySomething (Left usingExpr) byExpr) +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_ret_ty = placeHolderType } -mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType -mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr -mkRecStmt stmts = RecStmt stmts [] [] [] emptyLHsBinds +mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } ------------------------------- --- A useful function for building @OpApps@. The operator is always a -- variable, and we don't know the fixity yet. +mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar op)) (error "mkOpApp:fixity") e2 +mkHsSplice :: LHsExpr RdrName -> HsSplice RdrName mkHsSplice e = HsSplice unqualSplice e -unqualSplice = mkRdrUnqual (mkVarOccFS FSLIT("splice")) +mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName +mkHsSpliceTy e = HsSpliceTy (mkHsSplice e) emptyFVs placeHolderKind + +unqualSplice :: RdrName +unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice")) -- A name (uniquified later) to -- identify the splice +mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName +mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote + +unqualQuasiQuote :: RdrName +unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote")) + -- A name (uniquified later) to + -- identify the quasi-quote + +mkHsString :: String -> HsLit mkHsString s = HsString (mkFastString s) ------------- userHsTyVarBndrs :: [Located name] -> [Located (HsTyVarBndr name)] -userHsTyVarBndrs bndrs = [ L loc (UserTyVar v) | L loc v <- bndrs ] +userHsTyVarBndrs bndrs = [ L loc (UserTyVar v placeHolderKind) | L loc v <- bndrs ] \end{code} @@ -191,6 +315,7 @@ nlLitPat l = noLoc (LitPat l) nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id nlHsApp f x = noLoc (HsApp f x) +nlHsIntLit :: Integer -> LHsExpr id nlHsIntLit n = noLoc (HsLit (HsInt n)) nlHsApps :: id -> [LHsExpr id] -> LHsExpr id @@ -217,29 +342,57 @@ nlWildConPat :: DataCon -> LPat RdrName nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) (PrefixCon (nOfThem (dataConSourceArity con) nlWildPat))) -nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType) +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) +nlHsLam :: LMatch id -> LHsExpr id +nlHsPar :: LHsExpr id -> LHsExpr id +nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id +nlHsCase :: LHsExpr id -> [LMatch id] -> LHsExpr id +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)) -nlTuple exprs box = noLoc (ExplicitTuple exprs box) nlList exprs = noLoc (ExplicitList placeHolderType exprs) +nlHsAppTy :: LHsType name -> LHsType name -> LHsType name +nlHsTyVar :: name -> LHsType name +nlHsFunTy :: LHsType name -> LHsType name -> LHsType name + nlHsAppTy f t = noLoc (HsAppTy f t) nlHsTyVar x = noLoc (HsTyVar x) nlHsFunTy a b = noLoc (HsFunTy a b) +nlHsTyConApp :: name -> [LHsType name] -> LHsType name nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys \end{code} +Tuples. All these functions are *pre-typechecker* because they lack +types on the tuple. + +\begin{code} +mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a +-- Makes a pre-typechecker boxed tuple, deals with 1 case +mkLHsTupleExpr [e] = e +mkLHsTupleExpr es = noLoc $ ExplicitTuple (map Present es) Boxed + +mkLHsVarTuple :: [a] -> LHsExpr a +mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids) + +nlTuplePat :: [LPat id] -> Boxity -> LPat id +nlTuplePat pats box = noLoc (TuplePat pats box placeHolderType) +missingTupArg :: HsTupArg a +missingTupArg = Missing placeHolderType +\end{code} %************************************************************************ %* * @@ -255,8 +408,12 @@ mkFunBind fn ms = FunBind { fun_id = fn, fun_infix = False, fun_matches = mkMatc fun_tick = Nothing } -mkVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id -mkVarBind loc var rhs = mk_easy_FunBind loc var [] rhs +mkHsVarBind :: SrcSpan -> id -> LHsExpr id -> LHsBind id +mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs + +mkVarBind :: id -> LHsExpr id -> LHsBind id +mkVarBind var rhs = L (getLoc rhs) $ + VarBind { var_id = var, var_rhs = rhs, var_inline = False } ------------ mk_easy_FunBind :: SrcSpan -> id -> [LPat id] @@ -266,31 +423,19 @@ 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 loc fun [] = 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 (GRHSs (unguardedRHS expr) binds)) where - paren p = case p of - L _ (VarPat _) -> p - L l _ -> L l (ParPat p) + paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp) + | otherwise = lp \end{code} %************************************************************************ %* * - Collecting binders from HsBindGroups and HsBinds + Collecting binders %* * %************************************************************************ @@ -304,124 +449,119 @@ where 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 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) + \begin{code} -collectLocalBinders :: HsLocalBindsLR idL idR -> [Located idL] +----------------- Bindings -------------------------- +collectLocalBinders :: HsLocalBindsLR idL idR -> [idL] collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds collectLocalBinders (HsIPBinds _) = [] collectLocalBinders EmptyLocalBinds = [] -collectHsValBinders :: HsValBindsLR idL idR -> [Located idL] -collectHsValBinders (ValBindsIn binds sigs) = collectHsBindLocatedBinders binds -collectHsValBinders (ValBindsOut binds sigs) = foldr collect_one [] binds +collectHsValBinders :: HsValBindsLR idL idR -> [idL] +collectHsValBinders (ValBindsIn binds _) = collectHsBindsBinders binds +collectHsValBinders (ValBindsOut binds _) = foldr collect_one [] binds where - collect_one (_,binds) acc = foldrBag (collectAcc . unLoc) acc binds - -collectAcc :: HsBindLR idL idR -> [Located idL] -> [Located idL] -collectAcc (PatBind { pat_lhs = p }) acc = collectLocatedPatBinders p ++ acc -collectAcc (FunBind { fun_id = f }) acc = f : acc -collectAcc (VarBind { var_id = f }) acc = noLoc f : acc -collectAcc (AbsBinds { abs_exports = dbinds, abs_binds = binds }) acc - = [noLoc dp | (_,dp,_,_) <- dbinds] ++ acc - -- ++ foldr collectAcc acc binds + collect_one (_,binds) acc = collect_binds binds acc + +collectHsBindBinders :: HsBindLR idL idR -> [idL] +collectHsBindBinders b = collect_bind b [] + +collect_bind :: HsBindLR idL idR -> [idL] -> [idL] +collect_bind (PatBind { pat_lhs = p }) acc = collect_lpat p acc +collect_bind (FunBind { fun_id = L _ f }) acc = f : acc +collect_bind (VarBind { var_id = f }) acc = f : acc +collect_bind (AbsBinds { abs_exports = dbinds, abs_binds = _binds }) acc + = [dp | (_,dp,_,_) <- dbinds] ++ acc + -- ++ foldr collect_bind acc binds -- I don't think we want the binders from the nested binds -- The only time we collect binders from a typechecked -- binding (hence see AbsBinds) is in zonking in TcHsSyn -collectHsBindBinders :: LHsBindsLR idL idR -> [idL] -collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds) +collectHsBindsBinders :: LHsBindsLR idL idR -> [idL] +collectHsBindsBinders binds = collect_binds binds [] -collectHsBindLocatedBinders :: LHsBindsLR idL idR -> [Located idL] -collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds -\end{code} +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 -%************************************************************************ -%* * - Getting binders from statements -%* * -%************************************************************************ +collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName] +-- Used exclusively for the bindings of an instance decl which are all FunBinds +collectMethodBinders binds = foldrBag get [] binds + where + get (L _ (FunBind { fun_id = f })) fs = f : fs + get _ fs = fs + -- Someone else complains about non-FunBinds -\begin{code} -collectLStmtsBinders :: [LStmtLR idL idR] -> [Located idL] +----------------- Statements -------------------------- +collectLStmtsBinders :: [LStmtLR idL idR] -> [idL] collectLStmtsBinders = concatMap collectLStmtBinders -collectStmtsBinders :: [StmtLR idL idR] -> [Located idL] +collectStmtsBinders :: [StmtLR idL idR] -> [idL] collectStmtsBinders = concatMap collectStmtBinders -collectLStmtBinders :: LStmtLR idL idR -> [Located idL] +collectLStmtBinders :: LStmtLR idL idR -> [idL] collectLStmtBinders = collectStmtBinders . unLoc -collectStmtBinders :: StmtLR idL idR -> [Located idL] +collectStmtBinders :: StmtLR idL idR -> [idL] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? -collectStmtBinders (BindStmt pat _ _ _) = collectLocatedPatBinders pat +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 ss _ _ _ _) = collectLStmtsBinders ss -\end{code} - - -%************************************************************************ -%* * -%* Gathering stuff out of patterns -%* * -%************************************************************************ +collectStmtBinders (TransformStmt stmts _ _ _ _ _) = collectLStmtsBinders stmts +collectStmtBinders (GroupStmt { grpS_stmts = stmts }) = collectLStmtsBinders stmts +collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss -This function @collectPatBinders@ works with the ``collectBinders'' -functions for @HsBinds@, etc. The order in which the binders are -collected is important; see @HsBinds.lhs@. -It collects the bounds *value* variables in renamed patterns; type variables -are *not* collected. - -\begin{code} +----------------- Patterns -------------------------- collectPatBinders :: LPat a -> [a] -collectPatBinders pat = map unLoc (collectLocatedPatBinders pat) - -collectLocatedPatBinders :: LPat a -> [Located a] -collectLocatedPatBinders pat = collectl pat [] +collectPatBinders pat = collect_lpat pat [] collectPatsBinders :: [LPat a] -> [a] -collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats) +collectPatsBinders pats = foldr collect_lpat [] pats -collectLocatedPatsBinders :: [LPat a] -> [Located a] -collectLocatedPatsBinders pats = foldr collectl [] pats - ---------------------- -collectl (L l pat) bndrs +------------- +collect_lpat :: LPat name -> [name] -> [name] +collect_lpat (L _ pat) bndrs = go pat where - go (VarPat var) = L l var : bndrs - go (VarPatOut var bs) = L l var : collectHsBindLocatedBinders bs - ++ bndrs + go (VarPat var) = var : bndrs go (WildPat _) = bndrs - go (LazyPat pat) = collectl pat bndrs - go (BangPat pat) = collectl pat bndrs - go (AsPat a pat) = a : collectl pat bndrs - go (ViewPat exp pat _) = collectl pat bndrs - go (ParPat pat) = collectl pat bndrs + go (LazyPat pat) = collect_lpat pat bndrs + go (BangPat pat) = collect_lpat pat bndrs + go (AsPat (L _ a) pat) = a : collect_lpat pat bndrs + go (ViewPat _ pat _) = collect_lpat pat bndrs + go (ParPat pat) = collect_lpat pat bndrs - go (ListPat pats _) = foldr collectl bndrs pats - go (PArrPat pats _) = foldr collectl bndrs pats - go (TuplePat pats _ _) = foldr collectl bndrs pats + go (ListPat pats _) = foldr collect_lpat bndrs pats + go (PArrPat pats _) = foldr collect_lpat bndrs pats + go (TuplePat pats _ _) = foldr collect_lpat bndrs pats - go (ConPatIn c ps) = foldr collectl bndrs (hsConPatArgs ps) - go (ConPatOut {pat_args=ps}) = foldr collectl bndrs (hsConPatArgs ps) + go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps) + go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps) -- See Note [Dictionary binders in ConPatOut] go (LitPat _) = bndrs go (NPat _ _ _) = bndrs - go (NPlusKPat n _ _ _) = n : bndrs + go (NPlusKPat (L _ n) _ _ _) = n : bndrs - go (SigPatIn pat _) = collectl pat bndrs - go (SigPatOut pat _) = collectl pat bndrs - go (TypePat ty) = bndrs - go (CoPat _ pat ty) = collectl (noLoc 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} -Note [Dictionary binders in ConPatOut] +Note [Dictionary binders in ConPatOut] See also same Note in DsArrows ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Do *not* gather (a) dictionary and (b) dictionary bindings as binders of a ConPatOut pattern. For most calls it doesn't matter, because @@ -448,24 +588,161 @@ 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 :: [[LTyClDecl Name]] -> [Located (InstDecl Name)] -> [Name] +hsTyClDeclsBinders tycl_decls inst_decls + = [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. +-- 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 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 +%* * +%************************************************************************ + +\begin{code} collectSigTysFromPats :: [InPat name] -> [LHsType name] -collectSigTysFromPats pats = foldr collect_lpat [] pats +collectSigTysFromPats pats = foldr collect_sig_lpat [] pats collectSigTysFromPat :: InPat name -> [LHsType name] -collectSigTysFromPat pat = collect_lpat pat [] - -collect_lpat pat acc = collect_pat (unLoc pat) acc - -collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc) -collect_pat (TypePat ty) acc = ty:acc - -collect_pat (LazyPat pat) acc = collect_lpat pat acc -collect_pat (BangPat pat) acc = collect_lpat pat acc -collect_pat (AsPat a pat) acc = collect_lpat pat acc -collect_pat (ParPat pat) acc = collect_lpat pat acc -collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats -collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats -collect_pat (TuplePat pats _ _) acc = foldr collect_lpat acc pats -collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConPatArgs ps) -collect_pat other acc = acc -- Literals, vars, wildcard +collectSigTysFromPat pat = collect_sig_lpat pat [] + +collect_sig_lpat :: InPat name -> [LHsType name] -> [LHsType name] +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 +collect_sig_pat (AsPat _ pat) acc = collect_sig_lpat pat acc +collect_sig_pat (ParPat pat) acc = collect_sig_lpat pat acc +collect_sig_pat (ListPat pats _) acc = foldr collect_sig_lpat acc pats +collect_sig_pat (PArrPat pats _) acc = foldr collect_sig_lpat acc pats +collect_sig_pat (TuplePat pats _ _) acc = foldr collect_sig_lpat acc pats +collect_sig_pat (ConPatIn _ ps) acc = foldr collect_sig_lpat acc (hsConPatArgs ps) +collect_sig_pat _ acc = acc -- Literals, vars, wildcard \end{code}