+
%
% (c) The University of Glasgow, 1992-2006
%
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,
+ mkHsWrap, mkLHsWrap, mkHsWrapCoI, coiToHsWrapper, mkHsDictLet,
+ mkHsOpApp, mkHsDo,
+
+ 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,
+
+ -- 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,
+ collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
+ collectPatBinders, collectPatsBinders,
+ collectLStmtsBinders, collectStmtsBinders,
+ collectLStmtBinders, collectStmtBinders,
+ collectSigTysFromPats, collectSigTysFromPat
+ ) where
import HsBinds
import HsExpr
import Type
import DataCon
import Name
+import NameSet
import BasicTypes
import SrcLoc
import FastString
mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
mkHsWrapCoI IdCo e = e
-mkHsWrapCoI (ACo co) e = mkHsWrap (WpCo co) e
+mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e
coiToHsWrapper :: CoercionI -> HsWrapper
coiToHsWrapper IdCo = idHsWrapper
-coiToHsWrapper (ACo co) = WpCo co
+coiToHsWrapper (ACo co) = WpCast co
mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
-- 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
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
+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, []) (GroupByNothing usingExpr)
-mkGroupByStmt stmts byExpr = GroupStmt (stmts, []) (GroupBySomething (Right noSyntaxExpr) byExpr)
-mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt (stmts, []) (GroupBySomething (Left usingExpr) byExpr)
+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 = [], recS_dicts = 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 quoter span quote = HsQuasiQuote unqualQuasiQuote quoter span quote
+mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsQuasiQuote RdrName
+mkHsQuasiQuote quoter span quote = HsQuasiQuote quoter span quote
-unqualQuasiQuote = mkRdrUnqual (mkVarOccFS FSLIT("quasiquote"))
+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)
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 -> 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]
-> [([LPat id], LHsExpr id)]
-> LHsBind id
-mk_FunBind loc fun [] = panic "TcGenDeriv:mk_FunBind"
+mk_FunBind _ _ [] = panic "TcGenDeriv:mk_FunBind"
mk_FunBind loc fun pats_and_exprs
= L loc $ mkFunBind (L loc fun) matches
where
= 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 reuturn 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)
-
-collectHsBindLocatedBinders :: LHsBindsLR idL idR -> [Located idL]
-collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds
-\end{code}
+collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
+collectHsBindsBinders binds = collect_binds binds []
+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
$ concatMap fst xs
-collectStmtBinders (TransformStmt (stmts, _) _ _) = collectLStmtsBinders stmts
-collectStmtBinders (GroupStmt (stmts, _) _) = collectLStmtsBinders stmts
-collectStmtBinders (RecStmt ss _ _ _ _) = collectLStmtsBinders ss
-\end{code}
+collectStmtBinders (TransformStmt stmts _ _ _) = collectLStmtsBinders stmts
+collectStmtBinders (GroupStmt stmts _ _ _) = collectLStmtsBinders stmts
+collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
-%************************************************************************
-%* *
-%* 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@.
-
-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 (VarPatOut var bs) = var : collect_binds bs 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 (SigPatIn pat _) = collect_lpat pat bndrs
+ go (SigPatOut pat _) = collect_lpat pat bndrs
go (QuasiQuotePat _) = bndrs
- go (TypePat ty) = bndrs
- go (CoPat _ pat ty) = collectl (noLoc pat) 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
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.
+%************************************************************************
+%* *
+ 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}
projects / ghc-hetmet.git / blobdiff