module HsUtils(
mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypes, mkHsCaseAlt,
mkSimpleMatch, unguardedGRHSs, unguardedRHS,
mkMatchGroup, mkMatch, mkPrefixFunRhs, mkHsLam, mkHsIf,
mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
mkHsDictLet, mkHsLams,
mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
nlHsTyApp, nlHsTyApps, nlHsVar, nlHsDataCon,
nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
nlHsIntLit, nlHsVarApps,
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
typeToLHsType,
mkChunkified, chunkify,
mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, mkTopFunBind,
mkPatSynBind,
isInfixFunBind,
mkHsIntegral, mkHsFractional, mkHsIsString, mkHsString, mkHsStringPrimLit,
mkNPat, mkNPlusKPat, nlVarPat, nlLitPat, nlConVarPat, nlConVarPatName, nlConPat,
nlConPatName, nlInfixConPat, nlNullaryConPat, nlWildConPat, nlWildPat,
nlWildPatName, nlTuplePat, mkParPat, nlParPat,
mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
mkHsAppTy, mkHsAppKindTy, userHsTyVarBndrs, userHsLTyVarBndrs,
mkLHsSigType, mkLHsSigWcType, mkClassOpSigs, mkHsSigEnv,
nlHsAppTy, nlHsAppKindTy, nlHsTyVar, nlHsFunTy, nlHsParTy, nlHsTyConApp,
mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt,
mkLastStmt,
emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,
emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,
unitRecStmtTc,
mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkUntypedSplice,
mkHsQuasiQuote, unqualQuasiQuote,
isUnliftedHsBind, isBangedHsBind,
collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
collectHsIdBinders,
collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
collectPatBinders, collectPatsBinders,
collectLStmtsBinders, collectStmtsBinders,
collectLStmtBinders, collectStmtBinders,
hsLTyClDeclBinders, hsTyClForeignBinders,
hsPatSynSelectors, getPatSynBinds,
hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
lStmtsImplicits, hsValBindsImplicits, lPatImplicits
) where
#include "HsVersions.h"
import GhcPrelude
import HsDecls
import HsBinds
import HsExpr
import HsPat
import HsTypes
import HsLit
import PlaceHolder
import HsExtension
import TcEvidence
import RdrName
import Var
import TyCoRep
import Type ( tyConArgFlags )
import TysWiredIn ( unitTy )
import TcType
import DataCon
import ConLike
import Id
import Name
import NameSet hiding ( unitFV )
import NameEnv
import BasicTypes
import SrcLoc
import FastString
import Util
import Bag
import Outputable
import Constants
import Data.Either
import Data.Function
import Data.List
mkHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsPar e = cL (getLoc e) (HsPar noExt e)
mkSimpleMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
-> [LPat (GhcPass p)] -> Located (body (GhcPass p))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkSimpleMatch ctxt pats rhs
= cL loc $
Match { m_ext = noExt, m_ctxt = ctxt, m_pats = pats
, m_grhss = unguardedGRHSs rhs }
where
loc = case pats of
[] -> getLoc rhs
(pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
unguardedGRHSs :: Located (body (GhcPass p))
-> GRHSs (GhcPass p) (Located (body (GhcPass p)))
unguardedGRHSs rhs@(dL->L loc _)
= GRHSs noExt (unguardedRHS loc rhs) (noLoc emptyLocalBinds)
unguardedRHS :: SrcSpan -> Located (body (GhcPass p))
-> [LGRHS (GhcPass p) (Located (body (GhcPass p)))]
unguardedRHS loc rhs = [cL loc (GRHS noExt [] rhs)]
mkMatchGroup :: (XMG name (Located (body name)) ~ NoExt)
=> Origin -> [LMatch name (Located (body name))]
-> MatchGroup name (Located (body name))
mkMatchGroup origin matches = MG { mg_ext = noExt
, mg_alts = mkLocatedList matches
, mg_origin = origin }
mkLocatedList :: [Located a] -> Located [Located a]
mkLocatedList [] = noLoc []
mkLocatedList ms = cL (combineLocs (head ms) (last ms)) ms
mkHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkHsApp e1 e2 = addCLoc e1 e2 (HsApp noExt e1 e2)
mkHsAppType :: (NoGhcTc (GhcPass id) ~ GhcRn)
=> LHsExpr (GhcPass id) -> LHsWcType GhcRn -> LHsExpr (GhcPass id)
mkHsAppType e t = addCLoc e t_body (HsAppType noExt e paren_wct)
where
t_body = hswc_body t
paren_wct = t { hswc_body = parenthesizeHsType appPrec t_body }
mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
mkHsAppTypes = foldl' mkHsAppType
mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExt) =>
[LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
mkHsLam pats body = mkHsPar (cL (getLoc body) (HsLam noExt matches))
where
matches = mkMatchGroup Generated
[mkSimpleMatch LambdaExpr pats' body]
pats' = map (parenthesizePat appPrec) pats
mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
<.> mkWpLams dicts) expr
mkHsCaseAlt :: LPat (GhcPass p) -> (Located (body (GhcPass p)))
-> LMatch (GhcPass p) (Located (body (GhcPass p)))
mkHsCaseAlt pat expr
= mkSimpleMatch CaseAlt [pat] expr
nlHsTyApp :: IdP (GhcPass id) -> [Type] -> LHsExpr (GhcPass id)
nlHsTyApp fun_id tys
= noLoc (mkHsWrap (mkWpTyApps tys) (HsVar noExt (noLoc fun_id)))
nlHsTyApps :: IdP (GhcPass id) -> [Type] -> [LHsExpr (GhcPass id)]
-> LHsExpr (GhcPass id)
nlHsTyApps fun_id tys xs = foldl' nlHsApp (nlHsTyApp fun_id tys) xs
mkLHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsPar le@(dL->L loc e)
| hsExprNeedsParens appPrec e = cL loc (HsPar noExt le)
| otherwise = le
mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
mkParPat lp@(dL->L loc p)
| patNeedsParens appPrec p = cL loc (ParPat noExt lp)
| otherwise = lp
nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name)
nlParPat p = noLoc (ParPat noExt p)
mkHsIntegral :: IntegralLit -> HsOverLit GhcPs
mkHsFractional :: FractionalLit -> HsOverLit GhcPs
mkHsIsString :: SourceText -> FastString -> HsOverLit GhcPs
mkHsDo :: HsStmtContext Name -> [ExprLStmt GhcPs] -> HsExpr GhcPs
mkHsComp :: HsStmtContext Name -> [ExprLStmt GhcPs] -> LHsExpr GhcPs
-> HsExpr GhcPs
mkNPat :: Located (HsOverLit GhcPs) -> Maybe (SyntaxExpr GhcPs)
-> Pat GhcPs
mkNPlusKPat :: Located RdrName -> Located (HsOverLit GhcPs) -> Pat GhcPs
mkLastStmt :: Located (bodyR (GhcPass idR))
-> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkBodyStmt :: Located (bodyR GhcPs)
-> StmtLR (GhcPass idL) GhcPs (Located (bodyR GhcPs))
mkBindStmt :: (XBindStmt (GhcPass idL) (GhcPass idR)
(Located (bodyR (GhcPass idR))) ~ NoExt)
=> LPat (GhcPass idL) -> Located (bodyR (GhcPass idR))
-> StmtLR (GhcPass idL) (GhcPass idR) (Located (bodyR (GhcPass idR)))
mkTcBindStmt :: LPat GhcTc -> Located (bodyR GhcTc)
-> StmtLR GhcTc GhcTc (Located (bodyR GhcTc))
emptyRecStmt :: StmtLR (GhcPass idL) GhcPs bodyR
emptyRecStmtName :: StmtLR GhcRn GhcRn bodyR
emptyRecStmtId :: StmtLR GhcTc GhcTc bodyR
mkRecStmt :: [LStmtLR (GhcPass idL) GhcPs bodyR]
-> StmtLR (GhcPass idL) GhcPs bodyR
mkHsIntegral i = OverLit noExt (HsIntegral i) noExpr
mkHsFractional f = OverLit noExt (HsFractional f) noExpr
mkHsIsString src s = OverLit noExt (HsIsString src s) noExpr
mkHsDo ctxt stmts = HsDo noExt ctxt (mkLocatedList stmts)
mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt])
where
last_stmt = cL (getLoc expr) $ mkLastStmt expr
mkHsIf :: LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p)
-> HsExpr (GhcPass p)
mkHsIf c a b = HsIf noExt (Just noSyntaxExpr) c a b
mkNPat lit neg = NPat noExt lit neg noSyntaxExpr
mkNPlusKPat id lit
= NPlusKPat noExt id lit (unLoc lit) noSyntaxExpr noSyntaxExpr
mkTransformStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
mkTransformByStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
-> LHsExpr GhcPs -> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
mkGroupUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
mkGroupByUsingStmt :: [ExprLStmt GhcPs] -> LHsExpr GhcPs
-> LHsExpr GhcPs
-> StmtLR GhcPs GhcPs (LHsExpr GhcPs)
emptyTransStmt :: StmtLR GhcPs GhcPs (LHsExpr GhcPs)
emptyTransStmt = TransStmt { trS_ext = noExt
, trS_form = panic "emptyTransStmt: form"
, trS_stmts = [], trS_bndrs = []
, trS_by = Nothing, trS_using = noLoc noExpr
, trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
, trS_fmap = noExpr }
mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u }
mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u }
mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupForm, trS_stmts = ss, trS_using = u, trS_by = Just b }
mkLastStmt body = LastStmt noExt body False noSyntaxExpr
mkBodyStmt body
= BodyStmt noExt body noSyntaxExpr noSyntaxExpr
mkBindStmt pat body
= BindStmt noExt pat body noSyntaxExpr noSyntaxExpr
mkTcBindStmt pat body = BindStmt unitTy pat body noSyntaxExpr noSyntaxExpr
emptyRecStmt' :: forall idL idR body.
XRecStmt (GhcPass idL) (GhcPass idR) body
-> StmtLR (GhcPass idL) (GhcPass idR) body
emptyRecStmt' tyVal =
RecStmt
{ recS_stmts = [], recS_later_ids = []
, recS_rec_ids = []
, recS_ret_fn = noSyntaxExpr
, recS_mfix_fn = noSyntaxExpr
, recS_bind_fn = noSyntaxExpr
, recS_ext = tyVal }
unitRecStmtTc :: RecStmtTc
unitRecStmtTc = RecStmtTc { recS_bind_ty = unitTy
, recS_later_rets = []
, recS_rec_rets = []
, recS_ret_ty = unitTy }
emptyRecStmt = emptyRecStmt' noExt
emptyRecStmtName = emptyRecStmt' noExt
emptyRecStmtId = emptyRecStmt' unitRecStmtTc
mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
mkHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> HsExpr GhcPs
mkHsOpApp e1 op e2 = OpApp noExt e1 (noLoc (HsVar noExt (noLoc op))) e2
unqualSplice :: RdrName
unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
mkUntypedSplice :: SpliceDecoration -> LHsExpr GhcPs -> HsSplice GhcPs
mkUntypedSplice hasParen e = HsUntypedSplice noExt hasParen unqualSplice e
mkHsSpliceE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs
mkHsSpliceE hasParen e = HsSpliceE noExt (mkUntypedSplice hasParen e)
mkHsSpliceTE :: SpliceDecoration -> LHsExpr GhcPs -> HsExpr GhcPs
mkHsSpliceTE hasParen e
= HsSpliceE noExt (HsTypedSplice noExt hasParen unqualSplice e)
mkHsSpliceTy :: SpliceDecoration -> LHsExpr GhcPs -> HsType GhcPs
mkHsSpliceTy hasParen e = HsSpliceTy noExt
(HsUntypedSplice noExt hasParen unqualSplice e)
mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice GhcPs
mkHsQuasiQuote quoter span quote
= HsQuasiQuote noExt unqualSplice quoter span quote
unqualQuasiQuote :: RdrName
unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
mkHsString :: String -> HsLit (GhcPass p)
mkHsString s = HsString NoSourceText (mkFastString s)
mkHsStringPrimLit :: FastString -> HsLit (GhcPass p)
mkHsStringPrimLit fs
= HsStringPrim NoSourceText (fastStringToByteString fs)
userHsLTyVarBndrs :: SrcSpan -> [Located (IdP (GhcPass p))]
-> [LHsTyVarBndr (GhcPass p)]
userHsLTyVarBndrs loc bndrs = [ cL loc (UserTyVar noExt v) | v <- bndrs ]
userHsTyVarBndrs :: SrcSpan -> [IdP (GhcPass p)] -> [LHsTyVarBndr (GhcPass p)]
userHsTyVarBndrs loc bndrs = [ cL loc (UserTyVar noExt (cL loc v))
| v <- bndrs ]
nlHsVar :: IdP (GhcPass id) -> LHsExpr (GhcPass id)
nlHsVar n = noLoc (HsVar noExt (noLoc n))
nlHsDataCon :: DataCon -> LHsExpr GhcTc
nlHsDataCon con = noLoc (HsConLikeOut noExt (RealDataCon con))
nlHsLit :: HsLit (GhcPass p) -> LHsExpr (GhcPass p)
nlHsLit n = noLoc (HsLit noExt n)
nlHsIntLit :: Integer -> LHsExpr (GhcPass p)
nlHsIntLit n = noLoc (HsLit noExt (HsInt noExt (mkIntegralLit n)))
nlVarPat :: IdP (GhcPass id) -> LPat (GhcPass id)
nlVarPat n = noLoc (VarPat noExt (noLoc n))
nlLitPat :: HsLit GhcPs -> LPat GhcPs
nlLitPat l = noLoc (LitPat noExt l)
nlHsApp :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsApp f x = noLoc (HsApp noExt f (mkLHsPar x))
nlHsSyntaxApps :: SyntaxExpr (GhcPass id) -> [LHsExpr (GhcPass id)]
-> LHsExpr (GhcPass id)
nlHsSyntaxApps (SyntaxExpr { syn_expr = fun
, syn_arg_wraps = arg_wraps
, syn_res_wrap = res_wrap }) args
| [] <- arg_wraps
= ASSERT( isIdHsWrapper res_wrap )
foldl' nlHsApp (noLoc fun) args
| otherwise
= mkLHsWrap res_wrap (foldl' nlHsApp (noLoc fun) (zipWithEqual "nlHsSyntaxApps"
mkLHsWrap arg_wraps args))
nlHsApps :: IdP (GhcPass id) -> [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsApps f xs = foldl' nlHsApp (nlHsVar f) xs
nlHsVarApps :: IdP (GhcPass id) -> [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
nlHsVarApps f xs = noLoc (foldl' mk (HsVar noExt (noLoc f))
(map ((HsVar noExt) . noLoc) xs))
where
mk f a = HsApp noExt (noLoc f) (noLoc a)
nlConVarPat :: RdrName -> [RdrName] -> LPat GhcPs
nlConVarPat con vars = nlConPat con (map nlVarPat vars)
nlConVarPatName :: Name -> [Name] -> LPat GhcRn
nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)
nlInfixConPat :: RdrName -> LPat GhcPs -> LPat GhcPs -> LPat GhcPs
nlInfixConPat con l r = noLoc (ConPatIn (noLoc con)
(InfixCon (parenthesizePat opPrec l)
(parenthesizePat opPrec r)))
nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs
nlConPat con pats =
noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))
nlConPatName :: Name -> [LPat GhcRn] -> LPat GhcRn
nlConPatName con pats =
noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats)))
nlNullaryConPat :: IdP (GhcPass p) -> LPat (GhcPass p)
nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
nlWildConPat :: DataCon -> LPat GhcPs
nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
(PrefixCon (nOfThem (dataConSourceArity con)
nlWildPat)))
nlWildPat :: LPat GhcPs
nlWildPat = noLoc (WildPat noExt )
nlWildPatName :: LPat GhcRn
nlWildPatName = noLoc (WildPat noExt )
nlHsDo :: HsStmtContext Name -> [LStmt GhcPs (LHsExpr GhcPs)]
-> LHsExpr GhcPs
nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts)
nlHsOpApp :: LHsExpr GhcPs -> IdP GhcPs -> LHsExpr GhcPs -> LHsExpr GhcPs
nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2)
nlHsLam :: LMatch GhcPs (LHsExpr GhcPs) -> LHsExpr GhcPs
nlHsPar :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
nlHsIf :: LHsExpr (GhcPass id) -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
-> LHsExpr (GhcPass id)
nlHsCase :: LHsExpr GhcPs -> [LMatch GhcPs (LHsExpr GhcPs)]
-> LHsExpr GhcPs
nlList :: [LHsExpr GhcPs] -> LHsExpr GhcPs
nlHsLam match = noLoc (HsLam noExt (mkMatchGroup Generated [match]))
nlHsPar e = noLoc (HsPar noExt e)
nlHsIf cond true false = noLoc (HsIf noExt Nothing cond true false)
nlHsCase expr matches
= noLoc (HsCase noExt expr (mkMatchGroup Generated matches))
nlList exprs = noLoc (ExplicitList noExt Nothing exprs)
nlHsAppTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsTyVar :: IdP (GhcPass p) -> LHsType (GhcPass p)
nlHsFunTy :: LHsType (GhcPass p) -> LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsParTy :: LHsType (GhcPass p) -> LHsType (GhcPass p)
nlHsAppTy f t = noLoc (HsAppTy noExt f (parenthesizeHsType appPrec t))
nlHsTyVar x = noLoc (HsTyVar noExt NotPromoted (noLoc x))
nlHsFunTy a b = noLoc (HsFunTy noExt (parenthesizeHsType funPrec a) b)
nlHsParTy t = noLoc (HsParTy noExt t)
nlHsTyConApp :: IdP (GhcPass p) -> [LHsType (GhcPass p)] -> LHsType (GhcPass p)
nlHsTyConApp tycon tys = foldl' nlHsAppTy (nlHsTyVar tycon) tys
nlHsAppKindTy ::
LHsType (GhcPass p) -> LHsKind (GhcPass p) -> LHsType (GhcPass p)
nlHsAppKindTy f k = noLoc (HsAppKindTy noSrcSpan f (parenthesizeHsType appPrec k))
mkLHsTupleExpr :: [LHsExpr (GhcPass a)] -> LHsExpr (GhcPass a)
mkLHsTupleExpr [e] = e
mkLHsTupleExpr es
= noLoc $ ExplicitTuple noExt (map (noLoc . (Present noExt)) es) Boxed
mkLHsVarTuple :: [IdP (GhcPass a)] -> LHsExpr (GhcPass a)
mkLHsVarTuple ids = mkLHsTupleExpr (map nlHsVar ids)
nlTuplePat :: [LPat GhcPs] -> Boxity -> LPat GhcPs
nlTuplePat pats box = noLoc (TuplePat noExt pats box)
missingTupArg :: HsTupArg GhcPs
missingTupArg = Missing noExt
mkLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
mkLHsPatTup [] = noLoc $ TuplePat noExt [] Boxed
mkLHsPatTup [lpat] = lpat
mkLHsPatTup lpats = cL (getLoc (head lpats)) $ TuplePat noExt lpats Boxed
mkBigLHsVarTup :: [IdP (GhcPass id)] -> LHsExpr (GhcPass id)
mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
mkBigLHsTup :: [LHsExpr (GhcPass id)] -> LHsExpr (GhcPass id)
mkBigLHsTup = mkChunkified mkLHsTupleExpr
mkBigLHsVarPatTup :: [IdP GhcRn] -> LPat GhcRn
mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
mkBigLHsPatTup :: [LPat GhcRn] -> LPat GhcRn
mkBigLHsPatTup = mkChunkified mkLHsPatTup
mkChunkified :: ([a] -> a)
-> [a]
-> a
mkChunkified small_tuple as = mk_big_tuple (chunkify as)
where
mk_big_tuple [as] = small_tuple as
mk_big_tuple as_s = mk_big_tuple (chunkify (map small_tuple as_s))
chunkify :: [a] -> [[a]]
chunkify xs
| n_xs <= mAX_TUPLE_SIZE = [xs]
| otherwise = split xs
where
n_xs = length xs
split [] = []
split xs = take mAX_TUPLE_SIZE xs : split (drop mAX_TUPLE_SIZE xs)
mkLHsSigType :: LHsType GhcPs -> LHsSigType GhcPs
mkLHsSigType ty = mkHsImplicitBndrs ty
mkLHsSigWcType :: LHsType GhcPs -> LHsSigWcType GhcPs
mkLHsSigWcType ty = mkHsWildCardBndrs (mkHsImplicitBndrs ty)
mkHsSigEnv :: forall a. (LSig GhcRn -> Maybe ([Located Name], a))
-> [LSig GhcRn]
-> NameEnv a
mkHsSigEnv get_info sigs
= mkNameEnv (mk_pairs ordinary_sigs)
`extendNameEnvList` (mk_pairs gen_dm_sigs)
where
(gen_dm_sigs, ordinary_sigs) = partition is_gen_dm_sig sigs
is_gen_dm_sig (dL->L _ (ClassOpSig _ True _ _)) = True
is_gen_dm_sig _ = False
mk_pairs :: [LSig GhcRn] -> [(Name, a)]
mk_pairs sigs = [ (n,a) | Just (ns,a) <- map get_info sigs
, (dL->L _ n) <- ns ]
mkClassOpSigs :: [LSig GhcPs] -> [LSig GhcPs]
mkClassOpSigs sigs
= map fiddle sigs
where
fiddle (dL->L loc (TypeSig _ nms ty))
= cL loc (ClassOpSig noExt False nms (dropWildCards ty))
fiddle sig = sig
typeToLHsType :: Type -> LHsType GhcPs
typeToLHsType ty
= go ty
where
go :: Type -> LHsType GhcPs
go ty@(FunTy arg _)
| isPredTy arg
, (theta, tau) <- tcSplitPhiTy ty
= noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
, hst_xqual = noExt
, hst_body = go tau })
go (FunTy arg res) = nlHsFunTy (go arg) (go res)
go ty@(ForAllTy {})
| (tvs, tau) <- tcSplitForAllTys ty
= noLoc (HsForAllTy { hst_bndrs = map go_tv tvs
, hst_xforall = noExt
, hst_body = go tau })
go (TyVarTy tv) = nlHsTyVar (getRdrName tv)
go (AppTy t1 t2) = nlHsAppTy (go t1) (go t2)
go (LitTy (NumTyLit n))
= noLoc $ HsTyLit NoExt (HsNumTy NoSourceText n)
go (LitTy (StrTyLit s))
= noLoc $ HsTyLit NoExt (HsStrTy NoSourceText s)
go ty@(TyConApp tc args)
| tyConAppNeedsKindSig True tc (length args)
= nlHsParTy $ noLoc $ HsKindSig NoExt lhs_ty (go (typeKind ty))
| otherwise = lhs_ty
where
arg_flags :: [ArgFlag]
arg_flags = tyConArgFlags tc args
lhs_ty :: LHsType GhcPs
lhs_ty = foldl' (\f (arg, flag) ->
let arg' = go arg in
case flag of
Inferred -> f
Specified -> f `nlHsAppKindTy` arg'
Required -> f `nlHsAppTy` arg')
(nlHsTyVar (getRdrName tc))
(zip args arg_flags)
go (CastTy ty _) = go ty
go (CoercionTy co) = pprPanic "toLHsSigWcType" (ppr co)
go_tv :: TyVar -> LHsTyVarBndr GhcPs
go_tv tv = noLoc $ KindedTyVar noExt (noLoc (getRdrName tv))
(go (tyVarKind tv))
mkLHsWrap :: HsWrapper -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrap co_fn (dL->L loc e) = cL loc (mkHsWrap co_fn e)
mkHsWrap :: HsWrapper -> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrap co_fn e | isIdHsWrapper co_fn = e
mkHsWrap co_fn (HsWrap _ co_fn' e) = mkHsWrap (co_fn <.> co_fn') e
mkHsWrap co_fn e = HsWrap noExt co_fn e
mkHsWrapCo :: TcCoercionN
-> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
mkHsWrapCoR :: TcCoercionR
-> HsExpr (GhcPass id) -> HsExpr (GhcPass id)
mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
mkLHsWrapCo :: TcCoercionN -> LHsExpr (GhcPass id) -> LHsExpr (GhcPass id)
mkLHsWrapCo co (dL->L loc e) = cL loc (mkHsWrapCo co e)
mkHsCmdWrap :: HsWrapper -> HsCmd (GhcPass p) -> HsCmd (GhcPass p)
mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
| otherwise = HsCmdWrap noExt w cmd
mkLHsCmdWrap :: HsWrapper -> LHsCmd (GhcPass p) -> LHsCmd (GhcPass p)
mkLHsCmdWrap w (dL->L loc c) = cL loc (mkHsCmdWrap w c)
mkHsWrapPat :: HsWrapper -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
| otherwise = CoPat noExt co_fn p ty
mkHsWrapPatCo :: TcCoercionN -> Pat (GhcPass id) -> Type -> Pat (GhcPass id)
mkHsWrapPatCo co pat ty | isTcReflCo co = pat
| otherwise = CoPat noExt (mkWpCastN co) pat ty
mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
mkFunBind :: Located RdrName -> [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs
mkFunBind fn ms = FunBind { fun_id = fn
, fun_matches = mkMatchGroup Generated ms
, fun_co_fn = idHsWrapper
, fun_ext = noExt
, fun_tick = [] }
mkTopFunBind :: Origin -> Located Name -> [LMatch GhcRn (LHsExpr GhcRn)]
-> HsBind GhcRn
mkTopFunBind origin fn ms = FunBind { fun_id = fn
, fun_matches = mkMatchGroup origin ms
, fun_co_fn = idHsWrapper
, fun_ext = emptyNameSet
, fun_tick = [] }
mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind loc var rhs = mk_easy_FunBind loc var [] rhs
mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind var rhs = cL (getLoc rhs) $
VarBind { var_ext = noExt,
var_id = var, var_rhs = rhs, var_inline = False }
mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
-> LPat GhcPs -> HsPatSynDir GhcPs -> HsBind GhcPs
mkPatSynBind name details lpat dir = PatSynBind noExt psb
where
psb = PSB{ psb_ext = noExt
, psb_id = name
, psb_args = details
, psb_def = lpat
, psb_dir = dir }
isInfixFunBind :: HsBindLR id1 id2 -> Bool
isInfixFunBind (FunBind _ _ (MG _ matches _) _ _)
= any (isInfixMatch . unLoc) (unLoc matches)
isInfixFunBind _ = False
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat GhcPs]
-> LHsExpr GhcPs -> LHsBind GhcPs
mk_easy_FunBind loc fun pats expr
= cL loc $ mkFunBind (cL loc fun)
[mkMatch (mkPrefixFunRhs (cL loc fun)) pats expr
(noLoc emptyLocalBinds)]
mkPrefixFunRhs :: Located id -> HsMatchContext id
mkPrefixFunRhs n = FunRhs { mc_fun = n
, mc_fixity = Prefix
, mc_strictness = NoSrcStrict }
mkMatch :: HsMatchContext (NameOrRdrName (IdP (GhcPass p)))
-> [LPat (GhcPass p)] -> LHsExpr (GhcPass p)
-> Located (HsLocalBinds (GhcPass p))
-> LMatch (GhcPass p) (LHsExpr (GhcPass p))
mkMatch ctxt pats expr lbinds
= noLoc (Match { m_ext = noExt
, m_ctxt = ctxt
, m_pats = map paren pats
, m_grhss = GRHSs noExt (unguardedRHS noSrcSpan expr) lbinds })
where
paren lp@(dL->L l p)
| patNeedsParens appPrec p = cL l (ParPat noExt lp)
| otherwise = lp
isUnliftedHsBind :: HsBind GhcTc -> Bool
isUnliftedHsBind bind
| AbsBinds { abs_exports = exports, abs_sig = has_sig } <- bind
= if has_sig
then any (is_unlifted_id . abe_poly) exports
else any (is_unlifted_id . abe_mono) exports
| otherwise
= any is_unlifted_id (collectHsBindBinders bind)
where
is_unlifted_id id = isUnliftedType (idType id)
isBangedHsBind :: HsBind GhcTc -> Bool
isBangedHsBind (AbsBinds { abs_binds = binds })
= anyBag (isBangedHsBind . unLoc) binds
isBangedHsBind (FunBind {fun_matches = matches})
| [dL->L _ match] <- unLoc $ mg_alts matches
, FunRhs{mc_strictness = SrcStrict} <- m_ctxt match
= True
isBangedHsBind (PatBind {pat_lhs = pat})
= isBangedLPat pat
isBangedHsBind _
= False
collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR)
-> [IdP (GhcPass idL)]
collectLocalBinders (HsValBinds _ binds) = collectHsIdBinders binds
collectLocalBinders (HsIPBinds {}) = []
collectLocalBinders (EmptyLocalBinds _) = []
collectLocalBinders (XHsLocalBindsLR _) = []
collectHsIdBinders, collectHsValBinders
:: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)]
collectHsIdBinders = collect_hs_val_binders True
collectHsValBinders = collect_hs_val_binders False
collectHsBindBinders :: (SrcSpanLess (LPat p) ~ Pat p, HasSrcSpan (LPat p))=>
HsBindLR p idR -> [IdP p]
collectHsBindBinders b = collect_bind False b []
collectHsBindsBinders :: LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)]
collectHsBindsBinders binds = collect_binds False binds []
collectHsBindListBinders :: [LHsBindLR (GhcPass p) idR] -> [IdP (GhcPass p)]
collectHsBindListBinders = foldr (collect_bind False . unLoc) []
collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR)
-> [IdP (GhcPass idL)]
collect_hs_val_binders ps (ValBinds _ binds _) = collect_binds ps binds []
collect_hs_val_binders ps (XValBindsLR (NValBinds binds _))
= collect_out_binds ps binds
collect_out_binds :: Bool -> [(RecFlag, LHsBinds (GhcPass p))] ->
[IdP (GhcPass p)]
collect_out_binds ps = foldr (collect_binds ps . snd) []
collect_binds :: Bool -> LHsBindsLR (GhcPass p) idR ->
[IdP (GhcPass p)] -> [IdP (GhcPass p)]
collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds
collect_bind :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>
Bool -> HsBindLR p idR -> [IdP p] -> [IdP p]
collect_bind _ (PatBind { pat_lhs = p }) acc = collect_lpat p acc
collect_bind _ (FunBind { fun_id = (dL->L _ f) }) acc = f : acc
collect_bind _ (VarBind { var_id = f }) acc = f : acc
collect_bind _ (AbsBinds { abs_exports = dbinds }) acc = map abe_poly dbinds ++ acc
collect_bind omitPatSyn (PatSynBind _ (PSB { psb_id = (dL->L _ ps) })) acc
| omitPatSyn = acc
| otherwise = ps : acc
collect_bind _ (PatSynBind _ (XPatSynBind _)) acc = acc
collect_bind _ (XHsBindsLR _) acc = acc
collectMethodBinders :: LHsBindsLR idL idR -> [Located (IdP idL)]
collectMethodBinders binds = foldrBag (get . unLoc) [] binds
where
get (FunBind { fun_id = f }) fs = f : fs
get _ fs = fs
collectLStmtsBinders :: [LStmtLR (GhcPass idL) (GhcPass idR) body]
-> [IdP (GhcPass idL)]
collectLStmtsBinders = concatMap collectLStmtBinders
collectStmtsBinders :: [StmtLR (GhcPass idL) (GhcPass idR) body]
-> [IdP (GhcPass idL)]
collectStmtsBinders = concatMap collectStmtBinders
collectLStmtBinders :: LStmtLR (GhcPass idL) (GhcPass idR) body
-> [IdP (GhcPass idL)]
collectLStmtBinders = collectStmtBinders . unLoc
collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body
-> [IdP (GhcPass idL)]
collectStmtBinders (BindStmt _ pat _ _ _) = collectPatBinders pat
collectStmtBinders (LetStmt _ binds) = collectLocalBinders (unLoc binds)
collectStmtBinders (BodyStmt {}) = []
collectStmtBinders (LastStmt {}) = []
collectStmtBinders (ParStmt _ xs _ _) = collectLStmtsBinders
$ [s | ParStmtBlock _ ss _ _ <- xs, s <- ss]
collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts
collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss
collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args
where
collectArgBinders (_, ApplicativeArgOne _ pat _ _) = collectPatBinders pat
collectArgBinders (_, ApplicativeArgMany _ _ _ pat) = collectPatBinders pat
collectArgBinders _ = []
collectStmtBinders XStmtLR{} = panic "collectStmtBinders"
collectPatBinders :: LPat (GhcPass p) -> [IdP (GhcPass p)]
collectPatBinders pat = collect_lpat pat []
collectPatsBinders :: [LPat (GhcPass p)] -> [IdP (GhcPass p)]
collectPatsBinders pats = foldr collect_lpat [] pats
collect_lpat :: (SrcSpanLess (LPat p) ~ Pat p , HasSrcSpan (LPat p)) =>
LPat p -> [IdP p] -> [IdP p]
collect_lpat p bndrs
= go (unLoc p)
where
go (VarPat _ var) = unLoc var : bndrs
go (WildPat _) = bndrs
go (LazyPat _ pat) = collect_lpat pat bndrs
go (BangPat _ pat) = collect_lpat pat bndrs
go (AsPat _ a pat) = unLoc a : collect_lpat pat bndrs
go (ViewPat _ _ pat) = collect_lpat pat bndrs
go (ParPat _ pat) = collect_lpat pat bndrs
go (ListPat _ pats) = foldr collect_lpat bndrs pats
go (TuplePat _ pats _) = foldr collect_lpat bndrs pats
go (SumPat _ pat _ _) = collect_lpat pat bndrs
go (ConPatIn _ ps) = foldr collect_lpat bndrs (hsConPatArgs ps)
go (ConPatOut {pat_args=ps}) = foldr collect_lpat bndrs (hsConPatArgs ps)
go (LitPat _ _) = bndrs
go (NPat {}) = bndrs
go (NPlusKPat _ n _ _ _ _) = unLoc n : bndrs
go (SigPat _ pat _) = collect_lpat pat bndrs
go (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat)))
= go pat
go (SplicePat _ _) = bndrs
go (CoPat _ _ pat _) = go pat
go (XPat {}) = bndrs
hsGroupBinders :: HsGroup GhcRn -> [Name]
hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
hs_fords = foreign_decls })
= collectHsValBinders val_decls
++ hsTyClForeignBinders tycl_decls foreign_decls
hsGroupBinders (XHsGroup {}) = panic "hsGroupBinders"
hsTyClForeignBinders :: [TyClGroup GhcRn]
-> [LForeignDecl GhcRn]
-> [Name]
hsTyClForeignBinders tycl_decls foreign_decls
= map unLoc (hsForeignDeclsBinders foreign_decls)
++ getSelectorNames
(foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls
`mappend`
foldMap (foldMap hsLInstDeclBinders . group_instds) tycl_decls)
where
getSelectorNames :: ([Located Name], [LFieldOcc GhcRn]) -> [Name]
getSelectorNames (ns, fs) = map unLoc ns ++ map (extFieldOcc . unLoc) fs
hsLTyClDeclBinders :: Located (TyClDecl pass)
-> ([Located (IdP pass)], [LFieldOcc pass])
hsLTyClDeclBinders (dL->L loc (FamDecl { tcdFam = FamilyDecl
{ fdLName = (dL->L _ name) } }))
= ([cL loc name], [])
hsLTyClDeclBinders (dL->L _ (FamDecl { tcdFam = XFamilyDecl _ }))
= panic "hsLTyClDeclBinders"
hsLTyClDeclBinders (dL->L loc (SynDecl
{ tcdLName = (dL->L _ name) }))
= ([cL loc name], [])
hsLTyClDeclBinders (dL->L loc (ClassDecl
{ tcdLName = (dL->L _ cls_name)
, tcdSigs = sigs
, tcdATs = ats }))
= (cL loc cls_name :
[ cL fam_loc fam_name | (dL->L fam_loc (FamilyDecl
{ fdLName = L _ fam_name })) <- ats ]
++
[ cL mem_loc mem_name | (dL->L mem_loc (ClassOpSig _ False ns _)) <- sigs
, (dL->L _ mem_name) <- ns ]
, [])
hsLTyClDeclBinders (dL->L loc (DataDecl { tcdLName = (dL->L _ name)
, tcdDataDefn = defn }))
= (\ (xs, ys) -> (cL loc name : xs, ys)) $ hsDataDefnBinders defn
hsLTyClDeclBinders (dL->L _ (XTyClDecl _)) = panic "hsLTyClDeclBinders"
hsLTyClDeclBinders _ = panic "hsLTyClDeclBinders: Impossible Match"
hsForeignDeclsBinders :: [LForeignDecl pass] -> [Located (IdP pass)]
hsForeignDeclsBinders foreign_decls
= [ cL decl_loc n
| (dL->L decl_loc (ForeignImport { fd_name = (dL->L _ n) }))
<- foreign_decls]
hsPatSynSelectors :: HsValBinds (GhcPass p) -> [IdP (GhcPass p)]
hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors"
hsPatSynSelectors (XValBindsLR (NValBinds binds _))
= foldrBag addPatSynSelector [] . unionManyBags $ map snd binds
addPatSynSelector:: LHsBind p -> [IdP p] -> [IdP p]
addPatSynSelector bind sels
| PatSynBind _ (PSB { psb_args = RecCon as }) <- unLoc bind
= map (unLoc . recordPatSynSelectorId) as ++ sels
| otherwise = sels
getPatSynBinds :: [(RecFlag, LHsBinds id)] -> [PatSynBind id id]
getPatSynBinds binds
= [ psb | (_, lbinds) <- binds
, (dL->L _ (PatSynBind _ psb)) <- bagToList lbinds ]
hsLInstDeclBinders :: LInstDecl (GhcPass p)
-> ([Located (IdP (GhcPass p))], [LFieldOcc (GhcPass p)])
hsLInstDeclBinders (dL->L _ (ClsInstD
{ cid_inst = ClsInstDecl
{ cid_datafam_insts = dfis }}))
= foldMap (hsDataFamInstBinders . unLoc) dfis
hsLInstDeclBinders (dL->L _ (DataFamInstD { dfid_inst = fi }))
= hsDataFamInstBinders fi
hsLInstDeclBinders (dL->L _ (TyFamInstD {})) = mempty
hsLInstDeclBinders (dL->L _ (ClsInstD _ (XClsInstDecl {})))
= panic "hsLInstDeclBinders"
hsLInstDeclBinders (dL->L _ (XInstDecl _))
= panic "hsLInstDeclBinders"
hsLInstDeclBinders _ = panic "hsLInstDeclBinders: Impossible Match"
hsDataFamInstBinders :: DataFamInstDecl pass
-> ([Located (IdP pass)], [LFieldOcc pass])
hsDataFamInstBinders (DataFamInstDecl { dfid_eqn = HsIB { hsib_body =
FamEqn { feqn_rhs = defn }}})
= hsDataDefnBinders defn
hsDataFamInstBinders (DataFamInstDecl
{ dfid_eqn = HsIB { hsib_body = XFamEqn _}})
= panic "hsDataFamInstBinders"
hsDataFamInstBinders (DataFamInstDecl (XHsImplicitBndrs _))
= panic "hsDataFamInstBinders"
hsDataDefnBinders :: HsDataDefn pass -> ([Located (IdP pass)], [LFieldOcc pass])
hsDataDefnBinders (HsDataDefn { dd_cons = cons })
= hsConDeclsBinders cons
hsDataDefnBinders (XHsDataDefn _) = panic "hsDataDefnBinders"
type Seen pass = [LFieldOcc pass] -> [LFieldOcc pass]
hsConDeclsBinders :: [LConDecl pass] -> ([Located (IdP pass)], [LFieldOcc pass])
hsConDeclsBinders cons
= go id cons
where
go :: Seen pass -> [LConDecl pass]
-> ([Located (IdP pass)], [LFieldOcc pass])
go _ [] = ([], [])
go remSeen (r:rs)
= let loc = getLoc r
in case unLoc r of
ConDeclGADT { con_names = names, con_args = args }
-> (map (cL loc . unLoc) names ++ ns, flds ++ fs)
where
(remSeen', flds) = get_flds remSeen args
(ns, fs) = go remSeen' rs
ConDeclH98 { con_name = name, con_args = args }
-> ([cL loc (unLoc name)] ++ ns, flds ++ fs)
where
(remSeen', flds) = get_flds remSeen args
(ns, fs) = go remSeen' rs
XConDecl _ -> panic "hsConDeclsBinders"
get_flds :: Seen pass -> HsConDeclDetails pass
-> (Seen pass, [LFieldOcc pass])
get_flds remSeen (RecCon flds)
= (remSeen', fld_names)
where
fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds))
remSeen' = foldr (.) remSeen
[deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v
| v <- fld_names]
get_flds remSeen _
= (remSeen, [])
lStmtsImplicits :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]
-> NameSet
lStmtsImplicits = hs_lstmts
where
hs_lstmts :: [LStmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))]
-> NameSet
hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet
hs_stmt :: StmtLR GhcRn (GhcPass idR) (Located (body (GhcPass idR)))
-> NameSet
hs_stmt (BindStmt _ pat _ _ _) = lPatImplicits pat
hs_stmt (ApplicativeStmt _ args _) = unionNameSets (map do_arg args)
where do_arg (_, ApplicativeArgOne _ pat _ _) = lPatImplicits pat
do_arg (_, ApplicativeArgMany _ stmts _ _) = hs_lstmts stmts
do_arg (_, XApplicativeArg _) = panic "lStmtsImplicits"
hs_stmt (LetStmt _ binds) = hs_local_binds (unLoc binds)
hs_stmt (BodyStmt {}) = emptyNameSet
hs_stmt (LastStmt {}) = emptyNameSet
hs_stmt (ParStmt _ xs _ _) = hs_lstmts [s | ParStmtBlock _ ss _ _ <- xs
, s <- ss]
hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts
hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss
hs_stmt (XStmtLR {}) = panic "lStmtsImplicits"
hs_local_binds (HsValBinds _ val_binds) = hsValBindsImplicits val_binds
hs_local_binds (HsIPBinds {}) = emptyNameSet
hs_local_binds (EmptyLocalBinds _) = emptyNameSet
hs_local_binds (XHsLocalBindsLR _) = emptyNameSet
hsValBindsImplicits :: HsValBindsLR GhcRn (GhcPass idR) -> NameSet
hsValBindsImplicits (XValBindsLR (NValBinds binds _))
= foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds
hsValBindsImplicits (ValBinds _ binds _)
= lhsBindsImplicits binds
lhsBindsImplicits :: LHsBindsLR GhcRn idR -> NameSet
lhsBindsImplicits = foldBag unionNameSet (lhs_bind . unLoc) emptyNameSet
where
lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
lhs_bind _ = emptyNameSet
lPatImplicits :: LPat GhcRn -> NameSet
lPatImplicits = hs_lpat
where
hs_lpat lpat = hs_pat (unLoc lpat)
hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSet` 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 (TuplePat _ pats _) = hs_lpats pats
hs_pat (SigPat _ 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 `unionNameSet` 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
(unLoc fld)
pat_explicit = maybe True (i<) (rec_dotdot fs)]
details (InfixCon p1 p2) = hs_lpat p1 `unionNameSet` hs_lpat p2