diff options
Diffstat (limited to 'compiler/GHC/Hs/Utils.hs')
| -rw-r--r-- | compiler/GHC/Hs/Utils.hs | 44 |
1 files changed, 33 insertions, 11 deletions
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index eb410a3c6a..9c7fe17f88 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -98,7 +98,7 @@ module GHC.Hs.Utils( collectHsIdBinders, collectHsBindsBinders, collectHsBindBinders, collectMethodBinders, - collectPatBinders, collectPatsBinders, + collectPatBinders, collectPatsBinders, collectLMatchPatsBinders, collectLStmtsBinders, collectStmtsBinders, collectLStmtBinders, collectStmtBinders, CollectPass(..), CollectFlag(..), @@ -174,7 +174,7 @@ mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan) => HsMatchContext (GhcPass p) - -> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p)) + -> [LMatchPat (GhcPass p)] -> LocatedA (body (GhcPass p)) -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) mkSimpleMatch ctxt pats rhs = L loc $ @@ -183,7 +183,8 @@ mkSimpleMatch ctxt pats rhs where loc = case pats of [] -> getLoc rhs - (pat:_) -> combineSrcSpansA (getLoc pat) (getLoc rhs) + ((L _ (VisPat _ pat)):_) -> combineSrcSpansA (getLoc pat) (getLoc rhs) + _ -> getLoc rhs unguardedGRHSs :: Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan @@ -248,14 +249,14 @@ mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn mkHsAppTypes = foldl' mkHsAppType mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) - => [LPat (GhcPass p)] + => [LMatchPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches)) where matches = mkMatchGroup Generated (noLocA [mkSimpleMatch LambdaExpr pats' body]) - pats' = map (parenthesizePat appPrec) pats + pats' = map (parenthesizeLMatchPat appPrec) pats mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr GhcTc -> LHsExpr GhcTc mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars @@ -267,10 +268,10 @@ mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpan, Anno (Match (GhcPass p) (LocatedA (body (GhcPass p)))) ~ SrcSpanAnnA) - => LPat (GhcPass p) -> (LocatedA (body (GhcPass p))) + => LMatchPat (GhcPass p) -> (LocatedA (body (GhcPass p))) -> LMatch (GhcPass p) (LocatedA (body (GhcPass p))) -mkHsCaseAlt pat expr - = mkSimpleMatch CaseAlt [pat] expr +mkHsCaseAlt match_pat expr + = mkSimpleMatch CaseAlt [match_pat] expr nlHsTyApp :: Id -> [Type] -> LHsExpr GhcTc nlHsTyApp fun_id tys @@ -288,6 +289,9 @@ mkLHsPar = parenthesizeHsExpr appPrec mkParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p) mkParPat = parenthesizePat appPrec +mkParLamPat :: IsPass p => LMatchPat (GhcPass p) -> LMatchPat (GhcPass p) +mkParLamPat = parenthesizeLMatchPat appPrec + nlParPat :: LPat (GhcPass name) -> LPat (GhcPass name) nlParPat p = noLocA (gParPat p) @@ -893,7 +897,7 @@ spanHsLocaLBinds (HsIPBinds _ (IPBinds _ bs)) ------------ -- | Convenience function using 'mkFunBind'. -- This is for generated bindings only, do not use for user-written code. -mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LPat GhcPs] +mkSimpleGeneratedFunBind :: SrcSpan -> RdrName -> [LMatchPat GhcPs] -> LHsExpr GhcPs -> LHsBind GhcPs mkSimpleGeneratedFunBind loc fun pats expr = L (noAnnSrcSpan loc) $ mkFunBind Generated (L (noAnnSrcSpan loc) fun) @@ -909,14 +913,14 @@ mkPrefixFunRhs n = FunRhs { mc_fun = n ------------ mkMatch :: forall p. IsPass p => HsMatchContext (GhcPass p) - -> [LPat (GhcPass p)] + -> [LMatchPat (GhcPass p)] -> LHsExpr (GhcPass p) -> HsLocalBinds (GhcPass p) -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) mkMatch ctxt pats expr binds = noLocA (Match { m_ext = noAnn , m_ctxt = ctxt - , m_pats = map mkParPat pats + , m_pats = map mkParLamPat pats , m_grhss = GRHSs emptyComments (unguardedRHS noAnn noSrcSpan expr) binds }) {- @@ -1160,6 +1164,14 @@ collectPatsBinders -> [IdP p] collectPatsBinders flag pats = foldr (collect_lpat flag) [] pats +collectLMatchPatsBinders + :: CollectPass p + => CollectFlag p + -> [LMatchPat p] + -> [IdP p] +-- ^ Return all the variables bound by the `[LMatchPat p]`, +-- including both type variables and term variables +collectLMatchPatsBinders flag pats = foldr (collect_lmatchpat flag) [] pats ------------- @@ -1183,6 +1195,16 @@ collect_lpat :: forall p. (CollectPass p) -> [IdP p] collect_lpat flag pat bndrs = collect_pat flag (unXRec @p pat) bndrs +collect_lmatchpat :: forall p. (CollectPass p) + => CollectFlag p + -> LMatchPat p + -> [IdP p] + -> [IdP p] +collect_lmatchpat flag match_pat bndrs = case (unXRec @p match_pat) of + VisPat _ pat -> collect_lpat flag pat bndrs + InvisTyVarPat _ idp -> (unXRec @p idp) : bndrs + _ -> bndrs -- TODO: implement these cases properly + collect_pat :: forall p. CollectPass p => CollectFlag p -> Pat p |