diff options
Diffstat (limited to 'compiler/GHC/Hs/Utils.hs')
| -rw-r--r-- | compiler/GHC/Hs/Utils.hs | 218 |
1 files changed, 143 insertions, 75 deletions
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 5daa380819..8c2dee179f 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -24,6 +24,9 @@ just attach noSrcSpan to everything. {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -89,6 +92,7 @@ module GHC.Hs.Utils( collectPatBinders, collectPatsBinders, collectLStmtsBinders, collectStmtsBinders, collectLStmtBinders, collectStmtBinders, + CollectPass(..), hsLTyClDeclBinders, hsTyClForeignBinders, hsPatSynSelectors, getPatSynBinds, @@ -135,6 +139,7 @@ import GHC.Settings.Constants import Data.Either import Data.Function import Data.List +import Data.Proxy {- ************************************************************************ @@ -197,8 +202,11 @@ mkHsAppType e t = addCLoc e t_body (HsAppType noExtField e paren_wct) mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn mkHsAppTypes = foldl' mkHsAppType -mkHsLam :: (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) => - [LPat (GhcPass p)] -> LHsExpr (GhcPass p) -> LHsExpr (GhcPass p) +mkHsLam :: IsPass p + => (XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField) + => [LPat (GhcPass p)] + -> LHsExpr (GhcPass p) + -> LHsExpr (GhcPass p) mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam noExtField matches)) where matches = mkMatchGroup Generated @@ -231,7 +239,7 @@ mkLHsPar le@(L loc e) | hsExprNeedsParens appPrec e = L loc (HsPar noExtField le) | otherwise = le -mkParPat :: LPat (GhcPass name) -> LPat (GhcPass name) +mkParPat :: IsPass p => LPat (GhcPass p) -> LPat (GhcPass p) mkParPat lp@(L loc p) | patNeedsParens appPrec p = L loc (ParPat noExtField lp) | otherwise = lp @@ -436,25 +444,42 @@ 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))) +nlInfixConPat con l r = noLoc $ ConPat + { pat_con = noLoc con + , pat_args = InfixCon (parenthesizePat opPrec l) + (parenthesizePat opPrec r) + , pat_con_ext = noExtField + } nlConPat :: RdrName -> [LPat GhcPs] -> LPat GhcPs -nlConPat con pats = - noLoc (ConPatIn (noLoc con) (PrefixCon (map (parenthesizePat appPrec) pats))) +nlConPat con pats = noLoc $ ConPat + { pat_con_ext = noExtField + , pat_con = noLoc con + , pat_args = 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 [])) +nlConPatName con pats = noLoc $ ConPat + { pat_con_ext = noExtField + , pat_con = noLoc con + , pat_args = PrefixCon (map (parenthesizePat appPrec) pats) + } + +nlNullaryConPat :: RdrName -> LPat GhcPs +nlNullaryConPat con = noLoc $ ConPat + { pat_con_ext = noExtField + , pat_con = noLoc con + , pat_args = PrefixCon [] + } nlWildConPat :: DataCon -> LPat GhcPs -nlWildConPat con = noLoc (ConPatIn (noLoc (getRdrName con)) - (PrefixCon (replicate (dataConSourceArity con) - nlWildPat))) +nlWildConPat con = noLoc $ ConPat + { pat_con_ext = noExtField + , pat_con = noLoc $ getRdrName con + , pat_args = PrefixCon $ + replicate (dataConSourceArity con) + nlWildPat + } -- | Wildcard pattern - after parsing nlWildPat :: LPat GhcPs @@ -801,11 +826,11 @@ mkLHsCmdWrap w (L loc c) = L loc (mkHsCmdWrap w c) mkHsWrapPat :: HsWrapper -> Pat GhcTc -> Type -> Pat GhcTc mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p - | otherwise = CoPat noExtField co_fn p ty + | otherwise = XPat $ CoPat co_fn p ty mkHsWrapPatCo :: TcCoercionN -> Pat GhcTc -> Type -> Pat GhcTc mkHsWrapPatCo co pat ty | isTcReflCo co = pat - | otherwise = CoPat noExtField (mkWpCastN co) pat ty + | otherwise = XPat $ CoPat (mkWpCastN co) pat ty mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr @@ -880,8 +905,10 @@ mkPrefixFunRhs n = FunRhs { mc_fun = n , mc_strictness = NoSrcStrict } ------------ -mkMatch :: HsMatchContext (NoGhcTc (GhcPass p)) - -> [LPat (GhcPass p)] -> LHsExpr (GhcPass p) +mkMatch :: forall p. IsPass p + => HsMatchContext (NoGhcTc (GhcPass p)) + -> [LPat (GhcPass p)] + -> LHsExpr (GhcPass p) -> Located (HsLocalBinds (GhcPass p)) -> LMatch (GhcPass p) (LHsExpr (GhcPass p)) mkMatch ctxt pats expr lbinds @@ -890,6 +917,7 @@ mkMatch ctxt pats expr lbinds , m_pats = map paren pats , m_grhss = GRHSs noExtField (unguardedRHS noSrcSpan expr) lbinds }) where + paren :: Located (Pat (GhcPass p)) -> Located (Pat (GhcPass p)) paren lp@(L l p) | patNeedsParens appPrec p = L l (ParPat noExtField lp) | otherwise = lp @@ -979,49 +1007,69 @@ isBangedHsBind (PatBind {pat_lhs = pat}) isBangedHsBind _ = False -collectLocalBinders :: HsLocalBindsLR (GhcPass idL) (GhcPass idR) +collectLocalBinders :: CollectPass (GhcPass idL) + => HsLocalBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] collectLocalBinders (HsValBinds _ binds) = collectHsIdBinders binds -- No pattern synonyms here collectLocalBinders (HsIPBinds {}) = [] collectLocalBinders (EmptyLocalBinds _) = [] -collectHsIdBinders, collectHsValBinders - :: HsValBindsLR (GhcPass idL) (GhcPass idR) -> [IdP (GhcPass idL)] +collectHsIdBinders :: CollectPass (GhcPass idL) + => HsValBindsLR (GhcPass idL) (GhcPass idR) + -> [IdP (GhcPass idL)] -- ^ Collect 'Id' binders only, or 'Id's + pattern synonyms, respectively collectHsIdBinders = collect_hs_val_binders True + +collectHsValBinders :: CollectPass (GhcPass idL) + => HsValBindsLR (GhcPass idL) (GhcPass idR) + -> [IdP (GhcPass idL)] collectHsValBinders = collect_hs_val_binders False -collectHsBindBinders :: XRec pass Pat ~ Located (Pat pass) => - HsBindLR pass idR -> [IdP pass] +collectHsBindBinders :: CollectPass p + => HsBindLR p idR + -> [IdP p] -- ^ Collect both 'Id's and pattern-synonym binders collectHsBindBinders b = collect_bind False b [] -collectHsBindsBinders :: LHsBindsLR (GhcPass p) idR -> [IdP (GhcPass p)] +collectHsBindsBinders :: CollectPass p + => LHsBindsLR p idR + -> [IdP p] collectHsBindsBinders binds = collect_binds False binds [] -collectHsBindListBinders :: [LHsBindLR (GhcPass p) idR] -> [IdP (GhcPass p)] +collectHsBindListBinders :: CollectPass p + => [LHsBindLR p idR] + -> [IdP p] -- ^ Same as 'collectHsBindsBinders', but works over a list of bindings collectHsBindListBinders = foldr (collect_bind False . unLoc) [] -collect_hs_val_binders :: Bool -> HsValBindsLR (GhcPass idL) (GhcPass idR) +collect_hs_val_binders :: CollectPass (GhcPass idL) + => 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 :: CollectPass p + => Bool + -> [(RecFlag, LHsBinds p)] + -> [IdP 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 :: CollectPass p + => Bool + -> LHsBindsLR p idR + -> [IdP p] + -> [IdP p] -- ^ Collect 'Id's, or 'Id's + pattern synonyms, depending on boolean flag collect_binds ps binds acc = foldr (collect_bind ps . unLoc) acc binds -collect_bind :: XRec pass Pat ~ Located (Pat pass) => - Bool -> HsBindLR pass idR -> - [IdP pass] -> [IdP pass] +collect_bind :: CollectPass 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 = L _ f }) acc = f : acc collect_bind _ (VarBind { var_id = f }) acc = f : acc @@ -1045,19 +1093,23 @@ collectMethodBinders binds = foldr (get . unLoc) [] binds -- Someone else complains about non-FunBinds ----------------- Statements -------------------------- -collectLStmtsBinders :: [LStmtLR (GhcPass idL) (GhcPass idR) body] +collectLStmtsBinders :: (CollectPass (GhcPass idL)) + => [LStmtLR (GhcPass idL) (GhcPass idR) body] -> [IdP (GhcPass idL)] collectLStmtsBinders = concatMap collectLStmtBinders -collectStmtsBinders :: [StmtLR (GhcPass idL) (GhcPass idR) body] +collectStmtsBinders :: (CollectPass (GhcPass idL)) + => [StmtLR (GhcPass idL) (GhcPass idR) body] -> [IdP (GhcPass idL)] collectStmtsBinders = concatMap collectStmtBinders -collectLStmtBinders :: LStmtLR (GhcPass idL) (GhcPass idR) body +collectLStmtBinders :: (CollectPass (GhcPass idL)) + => LStmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)] collectLStmtBinders = collectStmtBinders . unLoc -collectStmtBinders :: StmtLR (GhcPass idL) (GhcPass idR) body +collectStmtBinders :: (CollectPass (GhcPass idL)) + => StmtLR (GhcPass idL) (GhcPass idR) body -> [IdP (GhcPass idL)] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? collectStmtBinders (BindStmt _ pat _) = collectPatBinders pat @@ -1072,47 +1124,65 @@ collectStmtBinders (ApplicativeStmt _ args _) = concatMap collectArgBinders args where collectArgBinders (_, ApplicativeArgOne { app_arg_pattern = pat }) = collectPatBinders pat collectArgBinders (_, ApplicativeArgMany { bv_pattern = pat }) = collectPatBinders pat + collectArgBinders (_, XApplicativeArg {}) = [] ----------------- Patterns -------------------------- -collectPatBinders :: LPat (GhcPass p) -> [IdP (GhcPass p)] +collectPatBinders :: CollectPass p => LPat p -> [IdP p] collectPatBinders pat = collect_lpat pat [] -collectPatsBinders :: [LPat (GhcPass p)] -> [IdP (GhcPass p)] +collectPatsBinders :: CollectPass p => [LPat p] -> [IdP p] collectPatsBinders pats = foldr collect_lpat [] pats ------------- -collect_lpat :: XRec pass Pat ~ Located (Pat pass) => - LPat pass -> [IdP pass] -> [IdP pass] -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) - -- See Note [Dictionary binders in ConPatOut] - 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 +collect_lpat :: forall pass. (CollectPass pass) + => LPat pass -> [IdP pass] -> [IdP pass] +collect_lpat p bndrs = collect_pat (unLoc p) bndrs + +collect_pat :: forall p. CollectPass p + => Pat p + -> [IdP p] + -> [IdP p] +collect_pat pat bndrs = case pat of + (VarPat _ var) -> unLoc var : bndrs + (WildPat _) -> bndrs + (LazyPat _ pat) -> collect_lpat pat bndrs + (BangPat _ pat) -> collect_lpat pat bndrs + (AsPat _ a pat) -> unLoc a : collect_lpat pat bndrs + (ViewPat _ _ pat) -> collect_lpat pat bndrs + (ParPat _ pat) -> collect_lpat pat bndrs + (ListPat _ pats) -> foldr collect_lpat bndrs pats + (TuplePat _ pats _) -> foldr collect_lpat bndrs pats + (SumPat _ pat _ _) -> collect_lpat pat bndrs + (ConPat {pat_args=ps}) -> foldr collect_lpat bndrs (hsConPatArgs ps) + -- See Note [Dictionary binders in ConPatOut] + (LitPat _ _) -> bndrs + (NPat {}) -> bndrs + (NPlusKPat _ n _ _ _ _) -> unLoc n : bndrs + (SigPat _ pat _) -> collect_lpat pat bndrs + (SplicePat _ (HsSpliced _ _ (HsSplicedPat pat))) + -> collect_pat pat bndrs + (SplicePat _ _) -> bndrs + (XPat ext) -> collectXXPat (Proxy @p) ext bndrs + +-- | This class specifies how to collect variable identifiers from extension patterns in the given pass. +-- Consumers of the GHC API that define their own passes should feel free to implement instances in order +-- to make use of functions which depend on it. +-- +-- In particular, Haddock already makes use of this, with an instance for its 'DocNameI' pass so that +-- it can reuse the code in GHC for collecting binders. +class (XRec p Pat ~ Located (Pat p)) => CollectPass p where + collectXXPat :: Proxy p -> XXPat p -> [IdP p] -> [IdP p] + +instance CollectPass (GhcPass 'Parsed) where + collectXXPat _ ext = noExtCon ext + +instance CollectPass (GhcPass 'Renamed) where + collectXXPat _ ext = noExtCon ext + +instance CollectPass (GhcPass 'Typechecked) where + collectXXPat _ (CoPat _ pat _) = collect_pat pat + {- Note [Dictionary binders in ConPatOut] See also same Note in GHC.HsToCore.Arrows @@ -1394,10 +1464,8 @@ lPatImplicits = hs_lpat hs_pat (TuplePat _ pats _) = hs_lpats pats hs_pat (SigPat _ pat _) = hs_lpat pat - hs_pat (CoPat _ _ pat _) = hs_pat pat - hs_pat (ConPatIn n ps) = details n ps - hs_pat (ConPatOut {pat_con=con, pat_args=ps}) = details (fmap conLikeName con) ps + hs_pat (ConPat {pat_con=con, pat_args=ps}) = details con ps hs_pat _ = [] |