[Git][ghc/ghc][wip/sand-witch/check- at -binders] Filter out type binders on desugaring
Andrei Borzenkov (@sand-witch)
gitlab at gitlab.haskell.org
Thu Feb 8 14:21:11 UTC 2024
Andrei Borzenkov pushed to branch wip/sand-witch/check- at -binders at Glasgow Haskell Compiler / GHC
Commits:
a7c60d3d by Andrei Borzenkov at 2024-02-08T18:20:58+04:00
Filter out type binders on desugaring
- - - - -
5 changed files:
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/TyCl/PatSyn.hs
Changes:
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -38,9 +38,10 @@ module GHC.Hs.Pat (
hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs,
hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr,
- mkPrefixConPat, mkCharLitPat, mkNilPat, mkVisPat,
+ mkPrefixConPat, mkCharLitPat, mkNilPat, mkVisPat, mkVisPatX,
+ mkRetainedVisPat,
- expectVisPats,
+ Erasure(..), expectVisPats,
isSimplePat, isPatSyn,
looksLazyPatBind,
@@ -86,8 +87,6 @@ import GHC.Data.Bag -- collect ev vars from pats
import GHC.Data.Maybe
import GHC.Types.Name (Name, dataName)
import Data.Data
-import GHC.Utils.Panic.Plain (panic)
-import GHC.Utils.Misc (HasCallStack)
import Data.Functor.Identity
@@ -186,7 +185,9 @@ type instance XConPatTyArg GhcTc = NoExtField
type instance XHsFieldBind _ = EpAnn [AddEpAnn]
-type instance XVisPat (GhcPass _) = NoExtField
+type instance XVisPat GhcPs = NoExtField
+type instance XVisPat GhcRn = NoExtField
+type instance XVisPat GhcTc = Erasure
type instance XInvisPat GhcPs = EpToken "@"
type instance XInvisPat GhcRn = NoExtField
@@ -194,6 +195,8 @@ type instance XInvisPat GhcTc = Type
type instance XXArgPat (GhcPass _) = DataConCantHappen
+data Erasure = Erased | Retained
+ deriving (Data)
-- ---------------------------------------------------------------------
-- API Annotations types
@@ -471,17 +474,26 @@ mkCharLitPat src c = mkPrefixConPat charDataCon
[noLocA $ LitPat noExtField (HsCharPrim src c)] []
-- | A helper function that constructs an argument pattern (LArgPat) from a pattern (LPat)
-mkVisPat :: LPat (GhcPass pass) -> LArgPat (GhcPass pass)
-mkVisPat lpat = L (getLoc lpat) (VisPat noExtField lpat)
+mkVisPat :: XVisPat (GhcPass pass) ~ NoExtField => LPat (GhcPass pass) -> LArgPat (GhcPass pass)
+mkVisPat = mkVisPatX noExtField
+
+mkVisPatX :: XVisPat (GhcPass pass) -> LPat (GhcPass pass) -> LArgPat (GhcPass pass)
+mkVisPatX x lpat = L (getLoc lpat) (VisPat x lpat)
+
+mkRetainedVisPat :: forall pass. IsPass pass => LPat (GhcPass pass) -> LArgPat (GhcPass pass)
+mkRetainedVisPat = case ghcPass @pass of
+ GhcPs -> mkVisPat
+ GhcRn -> mkVisPat
+ GhcTc -> mkVisPatX Retained
-- | A helper that unwraps LArgPat when the caller statically knows that
-- all patterns are visible (i.e. none of them are @-patterns).
-expectVisPats :: HasCallStack => [LArgPat (GhcPass p)] -> [LPat (GhcPass p)]
-expectVisPats xs = map toLPat xs
+expectVisPats :: [LArgPat GhcTc] -> [LPat GhcTc]
+expectVisPats xs = mapMaybe to_lpat xs
where
- toLPat :: LArgPat (GhcPass p) -> LPat (GhcPass p)
- toLPat (L _ (VisPat _ pat)) = pat
- toLPat (L _ (InvisPat _ _)) = panic "expectVisPats: unexpected invisible pattern"
+ to_lpat :: LArgPat GhcTc -> Maybe (LPat GhcTc)
+ to_lpat (L _ (VisPat Retained pat)) = Just pat
+ to_lpat _ = Nothing
{-
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -186,7 +186,8 @@ mkHsPar e = L (getLoc e) (gHsPar e)
mkSimpleMatch :: (Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
~ SrcSpanAnnA,
Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
- ~ EpAnn NoEpAnns)
+ ~ EpAnn NoEpAnns,
+ XVisPat (GhcPass p) ~ NoExtField)
=> HsMatchContext (LIdP (NoGhcTc (GhcPass p)))
-> [LPat (GhcPass p)] -> LocatedA (body (GhcPass p))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
@@ -280,7 +281,8 @@ mkHsAppType e t = addCLocA t_body e (HsAppType noExtField e paren_wct)
mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
mkHsAppTypes = foldl' mkHsAppType
-mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin)
+mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ Origin,
+ XVisPat (GhcPass p) ~ NoExtField)
=> [LPat (GhcPass p)]
-> LHsExpr (GhcPass p)
-> LHsExpr (GhcPass p)
@@ -310,11 +312,12 @@ mkHsSyntaxApps _ NoSyntaxExprTc args = pprPanic "mkHsSyntaxApps" (ppr args)
mkHsCaseAlt :: (Anno (GRHS (GhcPass p) (LocatedA (body (GhcPass p))))
~ EpAnn NoEpAnns,
Anno (Match (GhcPass p) (LocatedA (body (GhcPass p))))
- ~ SrcSpanAnnA)
+ ~ SrcSpanAnnA,
+ IsPass p)
=> LPat (GhcPass p) -> (LocatedA (body (GhcPass p)))
-> LMatch (GhcPass p) (LocatedA (body (GhcPass p)))
mkHsCaseAlt pat expr
- = mkSimpleMatch CaseAlt [pat] expr
+ = mkSimpleMatchArg CaseAlt [mkRetainedVisPat pat] expr
nlHsTyApp :: Id -> [Type] -> LHsExpr GhcTc
nlHsTyApp fun_id tys
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -834,9 +834,9 @@ dsDo ctx stmts
mfix_app = nlHsSyntaxApps mfix_op [mfix_arg]
match_group = MatchGroupTc [unrestricted tup_ty] body_ty (Generated OtherExpansion SkipPmc)
mfix_arg = noLocA $ HsLam noAnn LamSingle
- (MG { mg_alts = noLocA [mkSimpleMatch
+ (MG { mg_alts = noLocA [mkSimpleMatchArg
(LamAlt LamSingle)
- [mfix_pat] body]
+ [mkVisPatX Retained mfix_pat] body]
, mg_ext = match_group
})
mfix_pat = noLocA $ LazyPat noExtField $ mkBigLHsPatTupId rec_tup_pats
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -163,19 +163,19 @@ tcMatchPats match_ctxt pats pat_tys thing_inside
-- ExpFunPatTy: expecting a value pattern
-- tc_lpat will error if it sees a @t type pattern
- loop (L l (VisPat x pat) : pats) (ExpFunPatTy pat_ty : pat_tys)
+ loop (L l (VisPat _ pat) : pats) (ExpFunPatTy pat_ty : pat_tys)
= do { (p, (ps, res)) <- tc_lpat pat_ty penv pat $
loop pats pat_tys
- ; return (L l (VisPat x p):ps, res) }
+ ; return (L l (VisPat Retained p) : ps, res) }
-- ExpForAllPat: expecting a type pattern
- loop all_pats@(L _ apat : pats) (ExpForAllPatTy (Bndr tv vis) : pat_tys)
+ loop all_pats@(L l apat : pats) (ExpForAllPatTy (Bndr tv vis) : pat_tys)
| VisPat _ pat <- apat
, isVisibleForAllTyFlag vis
- = do { (_p, (ps, res)) <- tc_forall_lpat tv penv pat $
+ = do { (p, (ps, res)) <- tc_forall_lpat tv penv pat $
loop pats pat_tys
- ; return (ps, res) }
+ ; return (L l (VisPat Erased p) : ps, res) }
-- Invisible forall in type, and an @a type pattern
-- Add an equation here when we have these
@@ -185,9 +185,9 @@ tcMatchPats match_ctxt pats pat_tys thing_inside
-- Invisible forall in type, and an @a type patters
| InvisPat _ tp <- apat
, isInvisibleForAllTyFlag vis
- = do { (_p, (ps, res)) <- tc_ty_pat tp tv $
+ = do { (p, (ps, res)) <- tc_ty_pat tp tv $
loop pats pat_tys
- ; return (ps, res) }
+ ; return (L l (InvisPat p tp) : ps, res) }
| otherwise -- Discard invisible pat_ty
= loop all_pats pat_tys
=====================================
compiler/GHC/Tc/TyCl/PatSyn.hs
=====================================
@@ -801,8 +801,9 @@ tcPatSynMatcher (L loc ps_name) lpat prag_fn
}
body' = noLocA $
HsLam noAnn LamSingle $
- MG{ mg_alts = noLocA [mkSimpleMatch (LamAlt LamSingle)
- args body]
+ MG{ mg_alts = noLocA [mkSimpleMatchArg (LamAlt LamSingle)
+ (map (mkVisPatX Retained) args)
+ body]
, mg_ext = MatchGroupTc (map unrestricted [pat_ty, cont_ty, fail_ty]) res_ty gen
}
match = mkMatch (mkPrefixFunRhs (L loc (idName patsyn_id))) []
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a7c60d3d6f47378bd9a532e47b04a03921843ff5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/a7c60d3d6f47378bd9a532e47b04a03921843ff5
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240208/09dde8a9/attachment-0001.html>
More information about the ghc-commits
mailing list