module HsUtils(
mkHsPar, mkHsApp, mkHsAppType, mkHsAppTypeOut, mkHsConApp, mkSimpleHsAlt,
mkSimpleMatch, unguardedGRHSs, unguardedRHS,
mkMatchGroup, mkMatchGroupName, mkMatch, mkHsLam, mkHsIf,
mkHsWrap, mkLHsWrap, mkHsWrapCo, mkHsWrapCoR, mkLHsWrapCo,
mkHsDictLet, mkHsLams,
mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
mkLHsPar, mkHsCmdWrap, mkLHsCmdWrap,
nlHsTyApp, nlHsTyApps, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsSyntaxApps,
nlHsIntLit, nlHsVarApps,
nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
mkLHsTupleExpr, mkLHsVarTuple, missingTupArg,
toLHsSigWcType,
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, nlWildPatId, nlTuplePat, mkParPat,
mkBigLHsVarTup, mkBigLHsTup, mkBigLHsVarPatTup, mkBigLHsPatTup,
mkHsAppTy, mkHsAppTys, userHsTyVarBndrs, userHsLTyVarBndrs,
mkLHsSigType, mkLHsSigWcType, mkClassOpSigs,
nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp,
mkTransformStmt, mkTransformByStmt, mkBodyStmt, mkBindStmt, mkTcBindStmt,
mkLastStmt,
emptyTransStmt, mkGroupUsingStmt, mkGroupByUsingStmt,
emptyRecStmt, emptyRecStmtName, emptyRecStmtId, mkRecStmt,
mkHsSpliceTy, mkHsSpliceE, mkHsSpliceTE, mkUntypedSplice,
mkHsQuasiQuote, unqualQuasiQuote,
noRebindableInfo,
collectLocalBinders, collectHsValBinders, collectHsBindListBinders,
collectHsIdBinders,
collectHsBindsBinders, collectHsBindBinders, collectMethodBinders,
collectPatBinders, collectPatsBinders,
collectLStmtsBinders, collectStmtsBinders,
collectLStmtBinders, collectStmtBinders,
hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynBinders,
hsForeignDeclsBinders, hsGroupBinders, hsDataFamInstBinders,
lStmtsImplicits, hsValBindsImplicits, lPatImplicits
) where
#include "HsVersions.h"
import HsDecls
import HsBinds
import HsExpr
import HsPat
import HsTypes
import HsLit
import PlaceHolder
import TcEvidence
import RdrName
import Var
import TyCoRep
import Type ( filterOutInvisibleTypes )
import TysWiredIn ( unitTy )
import TcType
import DataCon
import Name
import NameSet
import BasicTypes
import SrcLoc
import FastString
import Util
import Bag
import Outputable
import Constants
import Data.Either
import Data.Function
import Data.List
#if __GLASGOW_HASKELL__ < 709
import Data.Foldable ( foldMap )
import Data.Monoid ( mempty, mappend )
#endif
mkHsPar :: LHsExpr id -> LHsExpr id
mkHsPar e = L (getLoc e) (HsPar e)
mkSimpleMatch :: [LPat id] -> Located (body id) -> LMatch id (Located (body id))
mkSimpleMatch pats rhs
= L loc $
Match NonFunBindMatch pats Nothing (unguardedGRHSs rhs)
where
loc = case pats of
[] -> getLoc rhs
(pat:_) -> combineSrcSpans (getLoc pat) (getLoc rhs)
unguardedGRHSs :: Located (body id) -> GRHSs id (Located (body id))
unguardedGRHSs rhs@(L loc _)
= GRHSs (unguardedRHS loc rhs) (noLoc emptyLocalBinds)
unguardedRHS :: SrcSpan -> Located (body id) -> [LGRHS id (Located (body id))]
unguardedRHS loc rhs = [L loc (GRHS [] rhs)]
mkMatchGroup :: Origin -> [LMatch RdrName (Located (body RdrName))]
-> MatchGroup RdrName (Located (body RdrName))
mkMatchGroup origin matches = MG { mg_alts = mkLocatedList matches
, mg_arg_tys = []
, mg_res_ty = placeHolderType
, mg_origin = origin }
mkLocatedList :: [Located a] -> Located [Located a]
mkLocatedList [] = noLoc []
mkLocatedList ms = L (combineLocs (head ms) (last ms)) ms
mkMatchGroupName :: Origin -> [LMatch Name (Located (body Name))]
-> MatchGroup Name (Located (body Name))
mkMatchGroupName origin matches = MG { mg_alts = mkLocatedList matches
, mg_arg_tys = []
, mg_res_ty = placeHolderType
, mg_origin = origin }
mkHsApp :: LHsExpr name -> LHsExpr name -> LHsExpr name
mkHsApp e1 e2 = addCLoc e1 e2 (HsApp e1 e2)
mkHsAppType :: LHsExpr name -> LHsWcType name -> LHsExpr name
mkHsAppType e t = addCLoc e (hswc_body t) (HsAppType e t)
mkHsAppTypeOut :: LHsExpr Id -> LHsWcType Name -> LHsExpr Id
mkHsAppTypeOut e t = addCLoc e (hswc_body t) (HsAppTypeOut e t)
mkHsLam :: [LPat RdrName] -> LHsExpr RdrName -> LHsExpr RdrName
mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
where
matches = mkMatchGroup Generated [mkSimpleMatch pats body]
mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id
mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars
<.> mkWpLams dicts) expr
mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id
mkHsConApp data_con tys args
= foldl mk_app (nlHsTyApp (dataConWrapId data_con) tys) args
where
mk_app f a = noLoc (HsApp f (noLoc a))
mkSimpleHsAlt :: LPat id -> (Located (body id)) -> LMatch id (Located (body id))
mkSimpleHsAlt pat expr
= mkSimpleMatch [pat] expr
nlHsTyApp :: name -> [Type] -> LHsExpr name
nlHsTyApp fun_id tys = noLoc (HsWrap (mkWpTyApps tys) (HsVar (noLoc fun_id)))
nlHsTyApps :: name -> [Type] -> [LHsExpr name] -> LHsExpr name
nlHsTyApps fun_id tys xs = foldl nlHsApp (nlHsTyApp fun_id tys) xs
mkLHsPar :: LHsExpr name -> LHsExpr name
mkLHsPar le@(L loc e) | hsExprNeedsParens e = L loc (HsPar le)
| otherwise = le
mkParPat :: LPat name -> LPat name
mkParPat lp@(L loc p) | hsPatNeedsParens p = L loc (ParPat lp)
| otherwise = lp
mkHsIntegral :: String -> Integer -> PostTc RdrName Type -> HsOverLit RdrName
mkHsFractional :: FractionalLit -> PostTc RdrName Type -> HsOverLit RdrName
mkHsIsString :: String -> FastString -> PostTc RdrName Type -> HsOverLit RdrName
mkHsDo :: HsStmtContext Name -> [ExprLStmt RdrName] -> HsExpr RdrName
mkHsComp :: HsStmtContext Name -> [ExprLStmt RdrName] -> LHsExpr RdrName
-> HsExpr RdrName
mkNPat :: Located (HsOverLit RdrName) -> Maybe (SyntaxExpr RdrName) -> Pat RdrName
mkNPlusKPat :: Located RdrName -> Located (HsOverLit RdrName) -> Pat RdrName
mkLastStmt :: Located (bodyR idR) -> StmtLR idL idR (Located (bodyR idR))
mkBodyStmt :: Located (bodyR RdrName)
-> StmtLR idL RdrName (Located (bodyR RdrName))
mkBindStmt :: (PostTc idR Type ~ PlaceHolder)
=> LPat idL -> Located (bodyR idR)
-> StmtLR idL idR (Located (bodyR idR))
mkTcBindStmt :: LPat Id -> Located (bodyR Id) -> StmtLR Id Id (Located (bodyR Id))
emptyRecStmt :: StmtLR idL RdrName bodyR
emptyRecStmtName :: StmtLR Name Name bodyR
emptyRecStmtId :: StmtLR Id Id bodyR
mkRecStmt :: [LStmtLR idL RdrName bodyR] -> StmtLR idL RdrName bodyR
mkHsIntegral src i = OverLit (HsIntegral src i) noRebindableInfo noExpr
mkHsFractional f = OverLit (HsFractional f) noRebindableInfo noExpr
mkHsIsString src s = OverLit (HsIsString src s) noRebindableInfo noExpr
noRebindableInfo :: PlaceHolder
noRebindableInfo = PlaceHolder
mkHsDo ctxt stmts = HsDo ctxt (mkLocatedList 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 placeHolderType
mkNPlusKPat id lit = NPlusKPat id lit (unLoc lit) noSyntaxExpr noSyntaxExpr placeHolderType
mkTransformStmt :: (PostTc idR Type ~ PlaceHolder)
=> [ExprLStmt idL] -> LHsExpr idR
-> StmtLR idL idR (LHsExpr idL)
mkTransformByStmt :: (PostTc idR Type ~ PlaceHolder)
=> [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
-> StmtLR idL idR (LHsExpr idL)
mkGroupUsingStmt :: (PostTc idR Type ~ PlaceHolder)
=> [ExprLStmt idL] -> LHsExpr idR
-> StmtLR idL idR (LHsExpr idL)
mkGroupByUsingStmt :: (PostTc idR Type ~ PlaceHolder)
=> [ExprLStmt idL] -> LHsExpr idR -> LHsExpr idR
-> StmtLR idL idR (LHsExpr idL)
emptyTransStmt :: (PostTc idR Type ~ PlaceHolder) => StmtLR idL idR (LHsExpr idR)
emptyTransStmt = TransStmt { trS_form = panic "emptyTransStmt: form"
, trS_stmts = [], trS_bndrs = []
, trS_by = Nothing, trS_using = noLoc noExpr
, trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr
, trS_bind_arg_ty = PlaceHolder
, 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 body False noSyntaxExpr
mkBodyStmt body = BodyStmt body noSyntaxExpr noSyntaxExpr placeHolderType
mkBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr PlaceHolder
mkTcBindStmt pat body = BindStmt pat body noSyntaxExpr noSyntaxExpr unitTy
emptyRecStmt' :: forall idL idR body.
PostTc idR Type -> StmtLR idL 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_bind_ty = tyVal
, recS_later_rets = []
, recS_rec_rets = [], recS_ret_ty = tyVal }
emptyRecStmt = emptyRecStmt' placeHolderType
emptyRecStmtName = emptyRecStmt' placeHolderType
emptyRecStmtId = emptyRecStmt' unitTy
mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts }
mkHsOpApp :: LHsExpr id -> id -> LHsExpr id -> HsExpr id
mkHsOpApp e1 op e2 = OpApp e1 (noLoc (HsVar (noLoc op)))
(error "mkOpApp:fixity") e2
unqualSplice :: RdrName
unqualSplice = mkRdrUnqual (mkVarOccFS (fsLit "splice"))
mkUntypedSplice :: LHsExpr RdrName -> HsSplice RdrName
mkUntypedSplice e = HsUntypedSplice unqualSplice e
mkHsSpliceE :: LHsExpr RdrName -> HsExpr RdrName
mkHsSpliceE e = HsSpliceE (mkUntypedSplice e)
mkHsSpliceTE :: LHsExpr RdrName -> HsExpr RdrName
mkHsSpliceTE e = HsSpliceE (HsTypedSplice unqualSplice e)
mkHsSpliceTy :: LHsExpr RdrName -> HsType RdrName
mkHsSpliceTy e = HsSpliceTy (HsUntypedSplice unqualSplice e) placeHolderKind
mkHsQuasiQuote :: RdrName -> SrcSpan -> FastString -> HsSplice RdrName
mkHsQuasiQuote quoter span quote = HsQuasiQuote unqualSplice quoter span quote
unqualQuasiQuote :: RdrName
unqualQuasiQuote = mkRdrUnqual (mkVarOccFS (fsLit "quasiquote"))
mkHsString :: String -> HsLit
mkHsString s = HsString s (mkFastString s)
mkHsStringPrimLit :: FastString -> HsLit
mkHsStringPrimLit fs
= HsStringPrim (unpackFS fs) (fastStringToByteString fs)
userHsLTyVarBndrs :: SrcSpan -> [Located name] -> [LHsTyVarBndr name]
userHsLTyVarBndrs loc bndrs = [ L loc (UserTyVar v) | v <- bndrs ]
userHsTyVarBndrs :: SrcSpan -> [name] -> [LHsTyVarBndr name]
userHsTyVarBndrs loc bndrs = [ L loc (UserTyVar (L loc v)) | v <- bndrs ]
nlHsVar :: id -> LHsExpr id
nlHsVar n = noLoc (HsVar (noLoc n))
nlHsLit :: HsLit -> LHsExpr id
nlHsLit n = noLoc (HsLit n)
nlVarPat :: id -> LPat id
nlVarPat n = noLoc (VarPat (noLoc n))
nlLitPat :: HsLit -> LPat id
nlLitPat l = noLoc (LitPat l)
nlHsApp :: LHsExpr id -> LHsExpr id -> LHsExpr id
nlHsApp f x = noLoc (HsApp f x)
nlHsSyntaxApps :: SyntaxExpr id -> [LHsExpr id] -> LHsExpr 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))
nlHsIntLit :: Integer -> LHsExpr id
nlHsIntLit n = noLoc (HsLit (HsInt (show n) n))
nlHsApps :: id -> [LHsExpr id] -> LHsExpr id
nlHsApps f xs = foldl nlHsApp (nlHsVar f) xs
nlHsVarApps :: id -> [id] -> LHsExpr id
nlHsVarApps f xs = noLoc (foldl mk (HsVar (noLoc f)) (map (HsVar . noLoc) xs))
where
mk f a = HsApp (noLoc f) (noLoc a)
nlConVarPat :: RdrName -> [RdrName] -> LPat RdrName
nlConVarPat con vars = nlConPat con (map nlVarPat vars)
nlConVarPatName :: Name -> [Name] -> LPat Name
nlConVarPatName con vars = nlConPatName con (map nlVarPat vars)
nlInfixConPat :: id -> LPat id -> LPat id -> LPat id
nlInfixConPat con l r = noLoc (ConPatIn (noLoc con) (InfixCon l r))
nlConPat :: RdrName -> [LPat RdrName] -> LPat RdrName
nlConPat con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
nlConPatName :: Name -> [LPat Name] -> LPat Name
nlConPatName con pats = noLoc (ConPatIn (noLoc con) (PrefixCon pats))
nlNullaryConPat :: id -> LPat id
nlNullaryConPat con = noLoc (ConPatIn (noLoc con) (PrefixCon []))
nlWildConPat :: DataCon -> LPat RdrName
nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con))
(PrefixCon (nOfThem (dataConSourceArity con)
nlWildPat)))
nlWildPat :: LPat RdrName
nlWildPat = noLoc (WildPat placeHolderType )
nlWildPatName :: LPat Name
nlWildPatName = noLoc (WildPat placeHolderType )
nlWildPatId :: LPat Id
nlWildPatId = noLoc (WildPat placeHolderTypeTc )
nlHsDo :: HsStmtContext Name -> [LStmt RdrName (LHsExpr RdrName)]
-> LHsExpr RdrName
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 RdrName (LHsExpr RdrName) -> LHsExpr RdrName
nlHsPar :: LHsExpr id -> LHsExpr id
nlHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> LHsExpr id
nlHsCase :: LHsExpr RdrName -> [LMatch RdrName (LHsExpr RdrName)]
-> LHsExpr RdrName
nlList :: [LHsExpr RdrName] -> LHsExpr RdrName
nlHsLam match = noLoc (HsLam (mkMatchGroup Generated [match]))
nlHsPar e = noLoc (HsPar e)
nlHsIf cond true false = noLoc (mkHsIf cond true false)
nlHsCase expr matches = noLoc (HsCase expr (mkMatchGroup Generated matches))
nlList exprs = noLoc (ExplicitList placeHolderType Nothing 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 (noLoc x))
nlHsFunTy a b = noLoc (HsFunTy a b)
nlHsTyConApp :: name -> [LHsType name] -> LHsType name
nlHsTyConApp tycon tys = foldl nlHsAppTy (nlHsTyVar tycon) tys
mkLHsTupleExpr :: [LHsExpr a] -> LHsExpr a
mkLHsTupleExpr [e] = e
mkLHsTupleExpr es = noLoc $ ExplicitTuple (map (noLoc . 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 [])
missingTupArg :: HsTupArg RdrName
missingTupArg = Missing placeHolderType
mkLHsPatTup :: [LPat id] -> LPat id
mkLHsPatTup [] = noLoc $ TuplePat [] Boxed []
mkLHsPatTup [lpat] = lpat
mkLHsPatTup lpats = L (getLoc (head lpats)) $ TuplePat lpats Boxed []
mkBigLHsVarTup :: [id] -> LHsExpr id
mkBigLHsVarTup ids = mkBigLHsTup (map nlHsVar ids)
mkBigLHsTup :: [LHsExpr id] -> LHsExpr id
mkBigLHsTup = mkChunkified mkLHsTupleExpr
mkBigLHsVarPatTup :: [id] -> LPat id
mkBigLHsVarPatTup bs = mkBigLHsPatTup (map nlVarPat bs)
mkBigLHsPatTup :: [LPat id] -> LPat id
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 RdrName -> LHsSigType RdrName
mkLHsSigType ty = mkHsImplicitBndrs ty
mkLHsSigWcType :: LHsType RdrName -> LHsSigWcType RdrName
mkLHsSigWcType ty = mkHsImplicitBndrs (mkHsWildCardBndrs ty)
mkClassOpSigs :: [LSig RdrName] -> [LSig RdrName]
mkClassOpSigs sigs
= map fiddle sigs
where
fiddle (L loc (TypeSig nms ty)) = L loc (ClassOpSig False nms (dropWildCards ty))
fiddle sig = sig
toLHsSigWcType :: Type -> LHsSigWcType RdrName
toLHsSigWcType ty
= mkLHsSigWcType (go ty)
where
go :: Type -> LHsType RdrName
go ty@(ForAllTy (Anon arg) _)
| isPredTy arg
, (theta, tau) <- tcSplitPhiTy ty
= noLoc (HsQualTy { hst_ctxt = noLoc (map go theta)
, hst_body = go tau })
go (ForAllTy (Anon arg) res) = nlHsFunTy (go arg) (go res)
go ty@(ForAllTy {})
| (tvs, tau) <- tcSplitForAllTys ty
= noLoc (HsForAllTy { hst_bndrs = map go_tv tvs
, 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 (HsNumTy "" n)
go (LitTy (StrTyLit s)) = noLoc $ HsTyLit (HsStrTy "" s)
go (TyConApp tc args) = nlHsTyConApp (getRdrName tc) (map go args')
where
args' = filterOutInvisibleTypes tc args
go (CastTy ty _) = go ty
go (CoercionTy co) = pprPanic "toLHsSigWcType" (ppr co)
go_tv :: TyVar -> LHsTyVarBndr RdrName
go_tv tv = noLoc $ KindedTyVar (noLoc (getRdrName tv))
(go (tyVarKind tv))
mkLHsWrap :: HsWrapper -> LHsExpr id -> LHsExpr id
mkLHsWrap co_fn (L loc e) = L loc (mkHsWrap co_fn e)
mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
mkHsWrap co_fn e | isIdHsWrapper co_fn = e
| otherwise = HsWrap co_fn e
mkHsWrapCo :: TcCoercionN
-> HsExpr id -> HsExpr id
mkHsWrapCo co e = mkHsWrap (mkWpCastN co) e
mkHsWrapCoR :: TcCoercionR
-> HsExpr id -> HsExpr id
mkHsWrapCoR co e = mkHsWrap (mkWpCastR co) e
mkLHsWrapCo :: TcCoercionN -> LHsExpr id -> LHsExpr id
mkLHsWrapCo co (L loc e) = L loc (mkHsWrapCo co e)
mkHsCmdWrap :: HsWrapper -> HsCmd id -> HsCmd id
mkHsCmdWrap w cmd | isIdHsWrapper w = cmd
| otherwise = HsCmdWrap w cmd
mkLHsCmdWrap :: HsWrapper -> LHsCmd id -> LHsCmd id
mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c)
mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
| otherwise = CoPat co_fn p ty
mkHsWrapPatCo :: TcCoercionN -> Pat id -> Type -> Pat id
mkHsWrapPatCo co pat ty | isTcReflCo co = pat
| otherwise = CoPat (mkWpCastN co) pat ty
mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id
mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
mkFunBind :: Located RdrName -> [LMatch RdrName (LHsExpr RdrName)]
-> HsBind RdrName
mkFunBind fn ms = FunBind { fun_id = fn
, fun_matches = mkMatchGroup Generated ms
, fun_co_fn = idHsWrapper
, bind_fvs = placeHolderNames
, fun_tick = [] }
mkTopFunBind :: Origin -> Located Name -> [LMatch Name (LHsExpr Name)]
-> HsBind Name
mkTopFunBind origin fn ms = FunBind { fun_id = fn
, fun_matches = mkMatchGroupName origin ms
, fun_co_fn = idHsWrapper
, bind_fvs = emptyNameSet
, fun_tick = [] }
mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr RdrName -> LHsBind RdrName
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 }
mkPatSynBind :: Located RdrName -> HsPatSynDetails (Located RdrName)
-> LPat RdrName -> HsPatSynDir RdrName -> HsBind RdrName
mkPatSynBind name details lpat dir = PatSynBind psb
where
psb = PSB{ psb_id = name
, psb_args = details
, psb_def = lpat
, psb_dir = dir
, psb_fvs = placeHolderNames }
isInfixFunBind :: HsBindLR id1 id2 -> Bool
isInfixFunBind (FunBind _ (MG matches _ _ _) _ _ _)
= any (isInfixMatch . unLoc) (unLoc matches)
isInfixFunBind _ = False
mk_easy_FunBind :: SrcSpan -> RdrName -> [LPat RdrName]
-> LHsExpr RdrName -> LHsBind RdrName
mk_easy_FunBind loc fun pats expr
= L loc $ mkFunBind (L loc fun) [mkMatch pats expr (noLoc emptyLocalBinds)]
mkMatch :: [LPat id] -> LHsExpr id -> Located (HsLocalBinds id)
-> LMatch id (LHsExpr id)
mkMatch pats expr lbinds
= noLoc (Match NonFunBindMatch (map paren pats) Nothing
(GRHSs (unguardedRHS noSrcSpan expr) lbinds))
where
paren lp@(L l p) | hsPatNeedsParens p = L l (ParPat lp)
| otherwise = lp
collectLocalBinders :: HsLocalBindsLR idL idR -> [idL]
collectLocalBinders (HsValBinds binds) = collectHsIdBinders binds
collectLocalBinders (HsIPBinds _) = []
collectLocalBinders EmptyLocalBinds = []
collectHsIdBinders, collectHsValBinders :: HsValBindsLR idL idR -> [idL]
collectHsIdBinders = collect_hs_val_binders True
collectHsValBinders = collect_hs_val_binders False
collectHsBindBinders :: HsBindLR idL idR -> [idL]
collectHsBindBinders b = collect_bind False b []
collectHsBindsBinders :: LHsBindsLR idL idR -> [idL]
collectHsBindsBinders binds = collect_binds False binds []
collectHsBindListBinders :: [LHsBindLR idL idR] -> [idL]
collectHsBindListBinders = foldr (collect_bind False . unLoc) []
collect_hs_val_binders :: Bool -> HsValBindsLR idL idR -> [idL]
collect_hs_val_binders ps (ValBindsIn binds _) = collect_binds ps binds []
collect_hs_val_binders ps (ValBindsOut binds _) = collect_out_binds ps binds
collect_out_binds :: Bool -> [(RecFlag, LHsBinds id)] -> [id]
collect_out_binds ps = foldr (collect_binds ps . snd) []
collect_binds :: Bool -> LHsBindsLR idL idR -> [idL] -> [idL]
collect_binds ps binds acc = foldrBag (collect_bind ps . unLoc) acc binds
collect_bind :: Bool -> 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 }) acc = map abe_poly dbinds ++ acc
collect_bind _ (AbsBindsSig { abs_sig_export = poly }) acc = poly : acc
collect_bind omitPatSyn (PatSynBind (PSB { psb_id = L _ ps })) acc =
if omitPatSyn then acc else ps : acc
collectMethodBinders :: LHsBindsLR RdrName idR -> [Located RdrName]
collectMethodBinders binds = foldrBag (get . unLoc) [] binds
where
get (FunBind { fun_id = f }) fs = f : fs
get _ fs = fs
collectLStmtsBinders :: [LStmtLR idL idR body] -> [idL]
collectLStmtsBinders = concatMap collectLStmtBinders
collectStmtsBinders :: [StmtLR idL idR body] -> [idL]
collectStmtsBinders = concatMap collectStmtBinders
collectLStmtBinders :: LStmtLR idL idR body -> [idL]
collectLStmtBinders = collectStmtBinders . unLoc
collectStmtBinders :: StmtLR idL idR body -> [idL]
collectStmtBinders (BindStmt pat _ _ _ _)= collectPatBinders pat
collectStmtBinders (LetStmt (L _ binds)) = collectLocalBinders 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{} = []
collectPatBinders :: LPat a -> [a]
collectPatBinders pat = collect_lpat pat []
collectPatsBinders :: [LPat a] -> [a]
collectPatsBinders pats = foldr collect_lpat [] pats
collect_lpat :: LPat name -> [name] -> [name]
collect_lpat (L _ pat) bndrs
= go pat
where
go (VarPat (L _ var)) = var : bndrs
go (WildPat _) = 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 collect_lpat bndrs pats
go (PArrPat pats _) = foldr collect_lpat bndrs pats
go (TuplePat pats _ _) = foldr collect_lpat bndrs pats
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 (L _ n) _ _ _ _ _)= n : bndrs
go (SigPatIn pat _) = collect_lpat pat bndrs
go (SigPatOut pat _) = collect_lpat pat bndrs
go (SplicePat _) = bndrs
go (CoPat _ pat _) = go pat
hsGroupBinders :: HsGroup Name -> [Name]
hsGroupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls,
hs_instds = inst_decls, hs_fords = foreign_decls })
= collectHsValBinders val_decls
++ hsTyClForeignBinders tycl_decls inst_decls foreign_decls
hsTyClForeignBinders :: [TyClGroup Name] -> [LInstDecl Name]
-> [LForeignDecl Name] -> [Name]
hsTyClForeignBinders tycl_decls inst_decls foreign_decls
= map unLoc (hsForeignDeclsBinders foreign_decls)
++ getSelectorNames (foldMap (foldMap hsLTyClDeclBinders . group_tyclds) tycl_decls
`mappend` foldMap hsLInstDeclBinders inst_decls)
where
getSelectorNames :: ([Located Name], [LFieldOcc Name]) -> [Name]
getSelectorNames (ns, fs) = map unLoc ns ++ map (selectorFieldOcc.unLoc) fs
hsLTyClDeclBinders :: Located (TyClDecl name) -> ([Located name], [LFieldOcc name])
hsLTyClDeclBinders (L loc (FamDecl { tcdFam = FamilyDecl { fdLName = L _ name } }))
= ([L loc name], [])
hsLTyClDeclBinders (L loc (SynDecl { tcdLName = L _ name })) = ([L loc name], [])
hsLTyClDeclBinders (L loc (ClassDecl { tcdLName = L _ cls_name
, tcdSigs = sigs, tcdATs = ats }))
= (L loc cls_name :
[ L fam_loc fam_name | L fam_loc (FamilyDecl { fdLName = L _ fam_name }) <- ats ] ++
[ L mem_loc mem_name | L mem_loc (ClassOpSig False ns _) <- sigs, L _ mem_name <- ns ]
, [])
hsLTyClDeclBinders (L loc (DataDecl { tcdLName = L _ name, tcdDataDefn = defn }))
= (\ (xs, ys) -> (L loc name : xs, ys)) $ hsDataDefnBinders defn
hsForeignDeclsBinders :: [LForeignDecl name] -> [Located name]
hsForeignDeclsBinders foreign_decls
= [ L decl_loc n
| L decl_loc (ForeignImport { fd_name = L _ n }) <- foreign_decls]
hsPatSynBinders :: HsValBinds RdrName
-> ([Located RdrName], [Located RdrName])
hsPatSynBinders (ValBindsIn binds _) = foldrBag addPatSynBndr ([],[]) binds
hsPatSynBinders _ = panic "hsPatSynBinders"
addPatSynBndr :: LHsBindLR id id -> ([Located id], [Located id])
-> ([Located id], [Located id])
addPatSynBndr bind (sels, pss)
| L bind_loc (PatSynBind (PSB { psb_id = L _ n
, psb_args = RecordPatSyn as })) <- bind
= (map recordPatSynSelectorId as ++ sels, L bind_loc n : pss)
| L bind_loc (PatSynBind (PSB { psb_id = L _ n})) <- bind
= (sels, L bind_loc n : pss)
| otherwise
= (sels, pss)
hsLInstDeclBinders :: LInstDecl name -> ([Located name], [LFieldOcc name])
hsLInstDeclBinders (L _ (ClsInstD { cid_inst = ClsInstDecl { cid_datafam_insts = dfis } }))
= foldMap (hsDataFamInstBinders . unLoc) dfis
hsLInstDeclBinders (L _ (DataFamInstD { dfid_inst = fi }))
= hsDataFamInstBinders fi
hsLInstDeclBinders (L _ (TyFamInstD {})) = mempty
hsDataFamInstBinders :: DataFamInstDecl name -> ([Located name], [LFieldOcc name])
hsDataFamInstBinders (DataFamInstDecl { dfid_defn = defn })
= hsDataDefnBinders defn
hsDataDefnBinders :: HsDataDefn name -> ([Located name], [LFieldOcc name])
hsDataDefnBinders (HsDataDefn { dd_cons = cons })
= hsConDeclsBinders cons
hsConDeclsBinders :: [LConDecl name] -> ([Located name], [LFieldOcc name])
hsConDeclsBinders cons = go id cons
where go :: ([LFieldOcc name] -> [LFieldOcc name])
-> [LConDecl name] -> ([Located name], [LFieldOcc name])
go _ [] = ([], [])
go remSeen (r:rs) =
case r of
L loc (ConDeclGADT { con_names = names
, con_type = HsIB { hsib_body = res_ty}}) ->
case tau of
L _ (HsFunTy
(L _ (HsAppsTy
[L _ (HsAppPrefix (L _ (HsRecTy flds)))])) _res_ty)
-> record_gadt flds
L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty)
-> record_gadt flds
_other -> (map (L loc . unLoc) names ++ ns, fs)
where (ns, fs) = go remSeen rs
where
(_tvs, _cxt, tau) = splitLHsSigmaTy res_ty
record_gadt flds = (map (L loc . unLoc) names ++ ns, r' ++ fs)
where r' = remSeen (concatMap (cd_fld_names . unLoc) flds)
remSeen' = foldr (.) remSeen
[deleteBy ((==) `on`
unLoc . rdrNameFieldOcc . unLoc) v
| v <- r']
(ns, fs) = go remSeen' rs
L loc (ConDeclH98 { con_name = name
, con_details = RecCon flds }) ->
([L loc (unLoc name)] ++ ns, r' ++ fs)
where r' = remSeen (concatMap (cd_fld_names . unLoc)
(unLoc flds))
remSeen'
= foldr (.) remSeen
[deleteBy ((==) `on`
unLoc . rdrNameFieldOcc . unLoc) v | v <- r']
(ns, fs) = go remSeen' rs
L loc (ConDeclH98 { con_name = name }) ->
([L loc (unLoc name)] ++ ns, fs)
where (ns, fs) = go remSeen rs
lStmtsImplicits :: [LStmtLR Name idR (Located (body idR))] -> NameSet
lStmtsImplicits = hs_lstmts
where
hs_lstmts :: [LStmtLR Name idR (Located (body idR))] -> NameSet
hs_lstmts = foldr (\stmt rest -> unionNameSet (hs_stmt (unLoc stmt)) rest) emptyNameSet
hs_stmt :: StmtLR Name idR (Located (body 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
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_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 _)
= foldr (unionNameSet . lhsBindsImplicits . snd) emptyNameSet binds
hsValBindsImplicits (ValBindsIn binds _)
= lhsBindsImplicits binds
lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet
lhsBindsImplicits = foldBag unionNameSet (lhs_bind . unLoc) emptyNameSet
where
lhs_bind (PatBind { pat_lhs = lpat }) = lPatImplicits lpat
lhs_bind _ = emptyNameSet
lPatImplicits :: LPat Name -> NameSet
lPatImplicits = hs_lpat
where
hs_lpat (L _ pat) = hs_pat pat
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 (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 `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