+
%
% (c) The University of Glasgow, 1992-2006
%
Id typecheck/TcHsSyn
\begin{code}
-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, mkHsWrapPat, mkHsWrapPatCoI,
+
+ 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,
+ 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
import RdrName
import Var
+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}
mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
mkHsWrap co_fn e | isIdHsWrapper co_fn = e
- | otherwise = HsWrap co_fn e
+ | otherwise = HsWrap co_fn e
+
+mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
+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) = 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))
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 dictinoary terms etc, so no locations
+-- Used for constructing dictionary terms etc, so no locations
mkHsConApp data_con tys args
= foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
where
-- 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
+mkHsIntegral :: Integer -> PostTcType -> HsOverLit id
+mkHsFractional :: Rational -> PostTcType -> HsOverLit id
+mkHsIsString :: FastString -> PostTcType -> HsOverLit id
+mkHsDo :: 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
+
+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;
+
mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType
-mkNPat lit neg = NPat lit neg noSyntaxExpr 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
+mkTransformStmt stmts usingExpr = TransformStmt stmts [] usingExpr Nothing
+mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr)
+
+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
mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr
-mkRecStmt stmts = RecStmt stmts [] [] [] emptyLHsBinds
+
+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 = [] }
+
+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}
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
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)
+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}
%************************************************************************
%* *
fun_tick = Nothing }
-mkVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
-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 -> RdrName -> [LPat RdrName]
- -> LHsExpr RdrName -> LHsBind RdrName
+mk_easy_FunBind :: SrcSpan -> id -> [LPat id]
+ -> LHsExpr id -> LHsBind id
mk_easy_FunBind loc fun pats expr
= L loc $ mkFunBind (L loc fun) [mkMatch pats expr emptyLocalBinds]
------------
-mk_FunBind :: SrcSpan -> RdrName
- -> [([LPat RdrName], LHsExpr RdrName)]
- -> LHsBind RdrName
-
-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
%* *
%************************************************************************
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 :: HsLocalBinds name -> [Located name]
+----------------- Bindings --------------------------
+collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
collectLocalBinders (HsValBinds val_binds) = collectHsValBinders val_binds
collectLocalBinders (HsIPBinds _) = []
collectLocalBinders EmptyLocalBinds = []
-collectHsValBinders :: HsValBinds name -> [Located name]
-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 :: HsBind name -> [Located name] -> [Located name]
-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 :: LHsBinds name -> [name]
-collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds)
+collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
+collectHsBindsBinders binds = collect_binds binds []
-collectHsBindLocatedBinders :: LHsBinds name -> [Located name]
-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 :: OutputableBndr id => [LStmt id] -> [Located id]
+----------------- Statements --------------------------
+collectLStmtsBinders :: [LStmtLR idL idR] -> [idL]
collectLStmtsBinders = concatMap collectLStmtBinders
-collectStmtsBinders :: OutputableBndr id => [Stmt id] -> [Located id]
+collectStmtsBinders :: [StmtLR idL idR] -> [idL]
collectStmtsBinders = concatMap collectStmtBinders
-collectLStmtBinders :: OutputableBndr id => LStmt id -> [Located id]
+collectLStmtBinders :: LStmtLR idL idR -> [idL]
collectLStmtBinders = collectStmtBinders . unLoc
-collectStmtBinders :: OutputableBndr id => Stmt id -> [Located id]
+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
$ concatMap fst xs
-collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
-collectStmtBinders s = pprPanic "collectStmtBinders" (ppr s)
-\end{code}
-
-
-%************************************************************************
-%* *
-%* Gathering stuff out of patterns
-%* *
-%************************************************************************
-
-This function @collectPatBinders@ works with the ``collectBinders''
-functions for @HsBinds@, etc. The order in which the binders are
-collected is important; see @HsBinds.lhs@.
+collectStmtBinders (TransformStmt stmts _ _ _) = collectLStmtsBinders stmts
+collectStmtBinders (GroupStmt stmts _ _ _) = collectLStmtsBinders stmts
+collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
-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)
-
-collectLocatedPatsBinders :: [LPat a] -> [Located a]
-collectLocatedPatsBinders pats = foldr collectl [] pats
+collectPatsBinders pats = foldr collect_lpat [] 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 (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 (NPat _ _ _) = 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
we want to generate bindings for x,y but not for dictionaries bound by
C. (The type checker ensures they would not be used.)
+Desugaring of arrow case expressions needs these bindings (see DsArrows
+and arrowcase1), but SPJ (Jan 2007) says it's safer for it to use its
+own pat-binder-collector:
+
+Here's the problem. Consider
+
+data T a where
+ C :: Num a => a -> Int -> T a
+
+f ~(C (n+1) m) = (n,m)
+
+Here, the pattern (C (n+1)) binds a hidden dictionary (d::Num a),
+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 :: [[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 (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
+%* *
+%************************************************************************
+
\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}