summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--compiler/GHC/Hs/Expr.hs12
-rw-r--r--compiler/GHC/Hs/Instances.hs5
-rw-r--r--compiler/GHC/Hs/Pat.hs60
-rw-r--r--compiler/GHC/Hs/Pat.hs-boot2
-rw-r--r--compiler/GHC/Hs/Syn/Type.hs11
-rw-r--r--compiler/GHC/Hs/Utils.hs44
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs15
-rw-r--r--compiler/GHC/Parser.y16
-rw-r--r--compiler/GHC/Parser/Errors/Ppr.hs4
-rw-r--r--compiler/GHC/Parser/Errors/Types.hs3
-rw-r--r--compiler/GHC/Parser/PostProcess.hs23
-rw-r--r--compiler/GHC/Rename/Bind.hs2
-rw-r--r--compiler/GHC/Rename/Expr.hs2
-rw-r--r--compiler/GHC/Rename/HsType.hs4
-rw-r--r--compiler/GHC/Rename/Pat.hs45
-rw-r--r--compiler/Language/Haskell/Syntax/Expr.hs2
-rw-r--r--compiler/Language/Haskell/Syntax/Extension.hs4
-rw-r--r--compiler/Language/Haskell/Syntax/Pat.hs32
-rw-r--r--compiler/Language/Haskell/Syntax/Pat.hs-boot3
19 files changed, 242 insertions, 47 deletions
diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index eb51021b83..a7de65843c 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -1276,7 +1276,11 @@ matchGroupArity (MG { mg_alts = alts })
| L _ (alt1:_) <- alts = length (hsLMatchPats alt1)
| otherwise = panic "matchGroupArity"
-hsLMatchPats :: LMatch (GhcPass id) body -> [LPat (GhcPass id)]
+matchGroupLMatchPats :: MatchGroup (GhcPass id) body -> [LMatchPat (GhcPass id)]
+matchGroupLMatchPats (MG { mg_alts = (L _ (alt : _)) }) = hsLMatchPats alt
+matchGroupLMatchPats _ = panic []
+
+hsLMatchPats :: LMatch (GhcPass id) body -> [LMatchPat (GhcPass id)]
hsLMatchPats (L _ (Match { m_pats = pats })) = pats
-- We keep the type checker happy by providing EpAnnComments. They
@@ -1321,7 +1325,7 @@ pprPatBind pat grhss
pprMatch :: (OutputableBndrId idR, Outputable body)
=> Match (GhcPass idR) body -> SDoc
pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })
- = sep [ sep (herald : map (nest 2 . pprParendLPat appPrec) other_pats)
+ = sep [ sep (herald : map (nest 2 . pprParendLMatchPat appPrec) other_pats)
, nest 2 (pprGRHSs ctxt grhss) ]
where
(herald, other_pats)
@@ -1341,9 +1345,9 @@ pprMatch (Match { m_pats = pats, m_ctxt = ctxt, m_grhss = grhss })
| null rest -> (pp_infix, []) -- x &&& y = e
| otherwise -> (parens pp_infix, rest) -- (x &&& y) z = e
where
- pp_infix = pprParendLPat opPrec p1
+ pp_infix = pprParendLMatchPat opPrec p1
<+> pprInfixOcc fun
- <+> pprParendLPat opPrec p2
+ <+> pprParendLMatchPat opPrec p2
_ -> pprPanic "pprMatch" (ppr ctxt $$ ppr pats)
LambdaExpr -> (char '\\', pats)
diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs
index 21cd9b5d76..8e345cdd95 100644
--- a/compiler/GHC/Hs/Instances.hs
+++ b/compiler/GHC/Hs/Instances.hs
@@ -307,6 +307,11 @@ deriving instance Data (HsCmdTop GhcPs)
deriving instance Data (HsCmdTop GhcRn)
deriving instance Data (HsCmdTop GhcTc)
+-- deriving instance (DataIdLR p p) => Data (MatchPat p)
+deriving instance Data (MatchPat GhcPs)
+deriving instance Data (MatchPat GhcRn)
+deriving instance Data (MatchPat GhcTc)
+
-- deriving instance (DataIdLR p p,Data body) => Data (MatchGroup p body)
deriving instance Data (MatchGroup GhcPs (LocatedA (HsExpr GhcPs)))
deriving instance Data (MatchGroup GhcRn (LocatedA (HsExpr GhcRn)))
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index a4b3bed851..88bc223b7b 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -20,7 +20,7 @@
-}
module GHC.Hs.Pat (
- Pat(..), LPat,
+ Pat(..), LPat, MatchPat(..), LMatchPat,
EpAnnSumPat(..),
ConPatTc (..),
ConLikeP,
@@ -34,18 +34,18 @@ module GHC.Hs.Pat (
hsRecFields, hsRecFieldSel, hsRecFieldId, hsRecFieldsArgs,
hsRecUpdFieldId, hsRecUpdFieldOcc, hsRecUpdFieldRdr,
- mkPrefixConPat, mkCharLitPat, mkNilPat,
+ mkPrefixConPat, mkCharLitPat, mkNilPat, mkVisPat,
isSimplePat,
looksLazyPatBind,
- isBangedLPat,
- gParPat, patNeedsParens, parenthesizePat,
+ isBangedLPat, isBangedLMatchPat,
+ gParPat, patNeedsParens, parenthesizePat, parenthesizeLMatchPat,
isIrrefutableHsPat,
collectEvVarsPat, collectEvVarsPats,
- pprParendLPat, pprConArgs,
- pprLPat
+ pprParendLPat, pprParendLMatchPat, pprConArgs,
+ pprLPat, pprLMatchPat
) where
import GHC.Prelude
@@ -170,6 +170,27 @@ type instance ConLikeP GhcTc = ConLike
type instance XHsFieldBind _ = EpAnn [AddEpAnn]
+type instance XVisPat (GhcPass _) = NoExtField
+
+type instance XInvisTyVarPat GhcPs = EpAnn [AddEpAnn]
+type instance XInvisTyVarPat GhcRn = NoExtField
+type instance XInvisTyVarPat GhcTc = NoExtField
+
+type instance XInvisWildTyPat GhcPs = NoExtField
+type instance XInvisWildTyPat GhcRn = NoExtField
+type instance XInvisWildTyPat GhcTc = Type -- ?? perhaps, NoExtField, I'm not sure
+
+type instance XXMatchPat (GhcPass _) = NoExtCon
+
+mkVisPat :: forall pass. IsPass pass => LPat (GhcPass pass) -> LMatchPat (GhcPass pass)
+mkVisPat lpat =
+ case ghcPass @pass of
+ GhcPs -> L l (VisPat noExtField lpat)
+ GhcRn -> L l (VisPat noExtField lpat)
+ GhcTc -> L l (VisPat noExtField lpat)
+ where
+ l = getLoc lpat
+
-- ---------------------------------------------------------------------
-- API Annotations types
@@ -205,7 +226,6 @@ data XXPatGhcTc
-- See Note [Rebindable syntax and HsExpansion].
| ExpansionPat (Pat GhcRn) (Pat GhcTc)
-
-- See Note [Rebindable syntax and HsExpansion].
data HsPatExpansion a b
= HsPatExpanded a b
@@ -267,9 +287,17 @@ instance OutputableBndrId p => Outputable (Pat (GhcPass p)) where
instance (Outputable a, Outputable b) => Outputable (HsPatExpansion a b) where
ppr (HsPatExpanded a b) = ifPprDebug (vcat [ppr a, ppr b]) (ppr a)
+instance OutputableBndrId p => Outputable (MatchPat (GhcPass p)) where
+ ppr (VisPat _ lpat) = ppr (unLoc lpat)
+ ppr (InvisTyVarPat _ idp) = ppr idp
+ ppr (InvisWildTyPat _) = text "_@"
+
pprLPat :: (OutputableBndrId p) => LPat (GhcPass p) -> SDoc
pprLPat (L _ e) = pprPat e
+pprLMatchPat :: (OutputableBndrId p) => LMatchPat (GhcPass p) -> SDoc
+pprLMatchPat (L _ e) = ppr e
+
-- | Print with type info if -dppr-debug is on
pprPatBndr :: OutputableBndr name => name -> SDoc
pprPatBndr var
@@ -282,6 +310,12 @@ pprParendLPat :: (OutputableBndrId p)
=> PprPrec -> LPat (GhcPass p) -> SDoc
pprParendLPat p = pprParendPat p . unLoc
+pprParendLMatchPat :: (OutputableBndrId p)
+ => PprPrec -> LMatchPat (GhcPass p) -> SDoc
+pprParendLMatchPat p (L _ (VisPat _ pat)) = pprParendLPat p pat
+pprParendLMatchPat _ (L _ (InvisTyVarPat _ pat)) = char '@' <> (ppr (unLoc pat))
+pprParendLMatchPat _ (L _ (InvisWildTyPat _)) = text "@_"
+
pprParendPat :: forall p. OutputableBndrId p
=> PprPrec
-> Pat (GhcPass p)
@@ -444,6 +478,9 @@ patterns are treated specially, of course.
The 1.3 report defines what ``irrefutable'' and ``failure-free'' patterns are.
-}
+isBangedLMatchPat :: LMatchPat (GhcPass p) -> Bool
+isBangedLMatchPat (L _ (VisPat _ pat)) = isBangedLPat pat
+isBangedLMatchPat _ = False
isBangedLPat :: LPat (GhcPass p) -> Bool
isBangedLPat = isBangedPat . unLoc
@@ -680,6 +717,14 @@ parenthesizePat p lpat@(L loc pat)
| patNeedsParens p pat = L loc (gParPat lpat)
| otherwise = lpat
+parenthesizeLMatchPat :: IsPass p
+ => PprPrec
+ -> LMatchPat (GhcPass p)
+ -> LMatchPat (GhcPass p)
+parenthesizeLMatchPat p (L l (VisPat x lpat)) =
+ L l (VisPat x (parenthesizePat p lpat))
+parenthesizeLMatchPat _ invis = invis
+
{-
% Collect all EvVars from all constructor patterns
-}
@@ -726,6 +771,7 @@ collectEvVarsPat pat =
-}
type instance Anno (Pat (GhcPass p)) = SrcSpanAnnA
+type instance Anno (MatchPat (GhcPass p)) = SrcSpanAnnA
type instance Anno (HsOverLit (GhcPass p)) = SrcSpan
type instance Anno ConLike = SrcSpanAnnN
type instance Anno (HsFieldBind lhs rhs) = SrcSpanAnnA
diff --git a/compiler/GHC/Hs/Pat.hs-boot b/compiler/GHC/Hs/Pat.hs-boot
index f128e6d4ea..4056823581 100644
--- a/compiler/GHC/Hs/Pat.hs-boot
+++ b/compiler/GHC/Hs/Pat.hs-boot
@@ -13,5 +13,7 @@ import GHC.Hs.Extension ( OutputableBndrId, GhcPass )
import Language.Haskell.Syntax.Pat
instance (OutputableBndrId p) => Outputable (Pat (GhcPass p))
+instance (OutputableBndrId p) => Outputable (MatchPat (GhcPass p))
pprLPat :: (OutputableBndrId p) => LPat (GhcPass p) -> SDoc
+pprLMatchPat :: (OutputableBndrId p) => LMatchPat (GhcPass p) -> SDoc
diff --git a/compiler/GHC/Hs/Syn/Type.hs b/compiler/GHC/Hs/Syn/Type.hs
index 1501abbb9e..80c4ad5b6c 100644
--- a/compiler/GHC/Hs/Syn/Type.hs
+++ b/compiler/GHC/Hs/Syn/Type.hs
@@ -7,7 +7,8 @@ module GHC.Hs.Syn.Type (
-- * Extracting types from HsExpr
lhsExprType, hsExprType, hsWrapperType,
-- * Extracting types from HsSyn
- hsLitType, hsPatType, hsLPatType
+ hsLitType, hsPatType, hsLPatType,
+ hsLMatchPatType, hsMatchPatType
) where
@@ -38,6 +39,14 @@ import GHC.Utils.Panic
-}
+hsLMatchPatType :: LMatchPat GhcTc -> Type
+hsLMatchPatType (L _ pat) = hsMatchPatType pat
+
+hsMatchPatType :: MatchPat GhcTc -> Type
+hsMatchPatType (VisPat _ pat) = hsLPatType pat
+hsMatchPatType (InvisTyVarPat _ var) = idType (unLoc var)
+hsMatchPatType (InvisWildTyPat ty) = ty
+
hsLPatType :: LPat GhcTc -> Type
hsLPatType (L _ p) = hsPatType p
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
diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs
index a783833317..3d2940603a 100644
--- a/compiler/GHC/Iface/Ext/Ast.hs
+++ b/compiler/GHC/Iface/Ext/Ast.hs
@@ -490,6 +490,16 @@ patScopes rsp useScope patScope xs =
map (\(RS sc a) -> PS rsp useScope sc a) $
listScopes patScope xs
+matchPatScopes
+ :: Maybe Span
+ -> Scope
+ -> Scope
+ -> [LMatchPat (GhcPass p)]
+ -> [PScoped (LMatchPat (GhcPass p))]
+matchPatScopes rsp useScope patScope xs =
+ map (\(RS sc a) -> PS rsp useScope sc a) $
+ listScopes patScope xs
+
-- | 'listScopes' specialised to 'HsPatSigType'
tScopes
:: Scope
@@ -908,6 +918,9 @@ instance HiePass p => ToHie (HsPatSynDir (GhcPass p)) where
ExplicitBidirectional mg -> toHie mg
_ -> pure []
+instance ToHie (PScoped (GenLocated SrcSpanAnnA (MatchPat (GhcPass p)))) where
+ toHie = undefined
+
instance ( HiePass p
, Data (body (GhcPass p))
, AnnoBody p body
@@ -917,7 +930,7 @@ instance ( HiePass p
Match{m_ctxt=mctx, m_pats = pats, m_grhss = grhss } ->
[ toHie mctx
, let rhsScope = mkScope $ grhss_span grhss
- in toHie $ patScopes Nothing rhsScope NoScope pats
+ in toHie $ matchPatScopes Nothing rhsScope NoScope pats
, toHie grhss
]
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index fc546c515d..2b259354e5 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2788,7 +2788,7 @@ aexp :: { ECP }
unECP $2 >>= \ $2 ->
mkHsNegAppPV (comb2A $1 $>) $2 [mj AnnMinus $1] }
- | '\\' apats '->' exp
+ | '\\' matchpats '->' exp
{ ECP $
unECP $4 >>= \ $4 ->
mkHsLamPV (comb2 $1 (reLoc $>)) (\cs -> mkMatchGroup FromSource
@@ -3243,7 +3243,7 @@ alt :: { forall b. DisambECP b => PV (LMatch GhcPs (LocatedA b)) }
acsA (\cs -> sLL (reLoc $1) $>
(Match { m_ext = (EpAnn (glAR $1) [] cs)
, m_ctxt = CaseAlt
- , m_pats = [$1]
+ , m_pats = [L noSrcSpanA (VisPat noExtField $1)]
, m_grhss = unLoc $2 }))}
alt_rhs :: { forall b. DisambECP b => PV (Located (GRHSs GhcPs (LocatedA b))) }
@@ -3289,12 +3289,14 @@ bindpat : exp {% -- See Note [Parser-Validator Details] in GHC.Parse
checkPattern_details incompleteDoBlock
(unECP $1) }
-apat :: { LPat GhcPs }
-apat : aexp {% (checkPattern <=< runPV) (unECP $1) }
+matchpat :: { LMatchPat GhcPs }
+matchpat : aexp {% (fmap mkVisPat . checkPattern <=< runPV) (unECP $1) }
+ | PREFIX_AT tyvar { (L noSrcSpanA (InvisTyVarPat noAnn $2)) }
+ | PREFIX_AT '_' { (L noSrcSpanA (InvisWildTyPat noExtField)) }
-apats :: { [LPat GhcPs] }
- : apat apats { $1 : $2 }
- | {- empty -} { [] }
+matchpats :: { [LMatchPat GhcPs] }
+ : matchpat matchpats { $1 : $2 }
+ | {- empty -} { [] }
-----------------------------------------------------------------------------
-- Statement sequences
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index 138a24ccd5..59edbff669 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -177,6 +177,8 @@ instance Diagnostic PsMessage where
-> mkSimpleDecorated $ text "Illegal lambda-case"
PsErrEmptyLambda
-> mkSimpleDecorated $ text "A lambda requires at least one parameter"
+ PsErrorIllegalTypeArguments
+ -> mkSimpleDecorated $ text "Type variable arguments after ordinary patterns are not allowed yet"
PsErrLinearFunction
-> mkSimpleDecorated $ text "Illegal use of linear functions"
PsErrOverloadedRecordUpdateNotEnabled
@@ -598,6 +600,7 @@ instance Diagnostic PsMessage where
PsErrParseRightOpSectionInPat{} -> ErrorWithoutFlag
PsErrIllegalGadtRecordMultiplicity{} -> ErrorWithoutFlag
PsErrInvalidCApiImport {} -> ErrorWithoutFlag
+ PsErrorIllegalTypeArguments -> ErrorWithoutFlag
diagnosticHints = \case
PsUnknownMessage m -> diagnosticHints m
@@ -757,6 +760,7 @@ instance Diagnostic PsMessage where
PsErrInvalidPackageName{} -> noHints
PsErrIllegalGadtRecordMultiplicity{} -> noHints
PsErrInvalidCApiImport {} -> noHints
+ PsErrorIllegalTypeArguments -> noHints
psHeaderMessageDiagnostic :: PsHeaderMessage -> DecoratedSDoc
psHeaderMessageDiagnostic = \case
diff --git a/compiler/GHC/Parser/Errors/Types.hs b/compiler/GHC/Parser/Errors/Types.hs
index d39048c441..01168441c9 100644
--- a/compiler/GHC/Parser/Errors/Types.hs
+++ b/compiler/GHC/Parser/Errors/Types.hs
@@ -144,6 +144,9 @@ data PsMessage
-- | A lambda requires at least one parameter
| PsErrEmptyLambda
+ -- | Type variable arguments after ordinary patterns are not allowed yet
+ | PsErrorIllegalTypeArguments
+
-- | Underscores in literals without the extension enabled
| PsErrNumUnderscores !NumUnderscoreReason
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index e553348ea7..79855ddb40 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -655,17 +655,18 @@ mkPatSynMatchGroup (L loc patsyn_name) (L ld decls) =
wrongNameBindingErr (locA loc) decl
; match <- case details of
PrefixCon _ pats -> return $ Match { m_ext = noAnn
- , m_ctxt = ctxt, m_pats = pats
+ , m_ctxt = ctxt
+ , m_pats = (\pat -> L loc (VisPat noExtField pat)) <$> pats
, m_grhss = rhs }
where
ctxt = FunRhs { mc_fun = ln
, mc_fixity = Prefix
, mc_strictness = NoSrcStrict }
- InfixCon p1 p2 -> return $ Match { m_ext = noAnn
- , m_ctxt = ctxt
- , m_pats = [p1, p2]
- , m_grhss = rhs }
+ InfixCon p1@(L l1 _) p2@(L l2 _) -> return $ Match { m_ext = noAnn
+ , m_ctxt = ctxt
+ , m_pats = [(L l1 (VisPat noExtField p1)), (L l2 (VisPat noExtField p2))]
+ , m_grhss = rhs }
where
ctxt = FunRhs { mc_fun = ln
, mc_fixity = Infix
@@ -1121,6 +1122,11 @@ checkPattern_details extraDetails pp = runPV_details extraDetails (pp >>= checkL
checkLPat :: LocatedA (PatBuilder GhcPs) -> PV (LPat GhcPs)
checkLPat e@(L l _) = checkPat l e [] []
+checkLamPat :: LocatedA (PatBuilder GhcPs) -> PV (LMatchPat GhcPs)
+checkLamPat (L l (PatBuilderAppType _ (HsPS {hsps_body = L _ (HsTyVar _ NotPromoted c)}))) =
+ return $ (L l (InvisTyVarPat EpAnnNotUsed c))
+checkLamPat e@(L l _) = (\pat -> L l (VisPat noExtField pat)) <$> checkPat l e [] []
+
checkPat :: SrcSpanAnnA -> LocatedA (PatBuilder GhcPs) -> [HsPatSigType GhcPs] -> [LPat GhcPs]
-> PV (LPat GhcPs)
checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args
@@ -1129,8 +1135,6 @@ checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args
, pat_con = L ln c
, pat_args = PrefixCon tyargs args
}
- | not (null tyargs) =
- patFail (locA l) . PsErrInPat e $ PEIP_TypeArgs tyargs
| (not (null args) && patIsRec c) = do
ctx <- askParseContext
patFail (locA l) . PsErrInPat e $ PEIP_RecPattern args YesPatIsRecursive ctx
@@ -1246,7 +1250,7 @@ checkFunBind :: SrcStrictness
-> Located (GRHSs GhcPs (LHsExpr GhcPs))
-> P (HsBind GhcPs)
checkFunBind strictness locF ann fun is_infix pats (L _ grhss)
- = do ps <- runPV_details extraDetails (mapM checkLPat pats)
+ = do ps <- runPV_details extraDetails (mapM checkLamPat pats)
let match_span = noAnnSrcSpan $ locF
cs <- getCommentsFor locF
return (makeFunBind fun (L (noAnnSrcSpan $ locA match_span)
@@ -1289,7 +1293,7 @@ checkPatBind loc annsIn (L _ (BangPat (EpAnn _ ans cs) (L _ (VarPat _ v))))
, mc_fixity = Prefix
, mc_strictness = SrcStrict }
, m_pats = []
- , m_grhss = grhss }
+ , m_grhss = grhss }
checkPatBind loc annsIn lhs (L _ grhss) = do
cs <- getCommentsFor loc
@@ -1346,6 +1350,7 @@ isFunLhs e = go e [] [] []
op_app = L loc (PatBuilderOpApp k
(L loc' op) r (EpAnn loca (reverse ops++cps) cs))
_ -> return Nothing }
+ go (L _ (PatBuilderAppType pat _)) es ann cps = go pat es ann cps
go _ _ _ _ = return Nothing
mkBangTy :: EpAnn [AddEpAnn] -> SrcStrictness -> LHsType GhcPs -> HsType GhcPs
diff --git a/compiler/GHC/Rename/Bind.hs b/compiler/GHC/Rename/Bind.hs
index 1e4c43cf7d..068b2a597b 100644
--- a/compiler/GHC/Rename/Bind.hs
+++ b/compiler/GHC/Rename/Bind.hs
@@ -1209,7 +1209,7 @@ rnMatch' :: (AnnoBody body)
-> Match GhcPs (LocatedA (body GhcPs))
-> RnM (Match GhcRn (LocatedA (body GhcRn)), FreeVars)
rnMatch' ctxt rnBody (Match { m_ctxt = mf, m_pats = pats, m_grhss = grhss })
- = rnPats ctxt pats $ \ pats' -> do
+ = rnLMatchPats ctxt pats $ \ pats' -> do
{ (grhss', grhss_fvs) <- rnGRHSs ctxt rnBody grhss
; let mf' = case (ctxt, mf) of
(FunRhs { mc_fun = L _ funid }, FunRhs { mc_fun = L lf _ })
diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index 35129a55cd..cc013047e6 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -2591,7 +2591,7 @@ getMonadFailOp ctxt
nlHsApp (noLocA failExpr)
(nlHsApp (noLocA $ fromStringExpr) arg_syn_expr)
let failAfterFromStringExpr :: HsExpr GhcRn =
- unLoc $ mkHsLam [noLocA $ VarPat noExtField $ noLocA arg_name] body
+ unLoc $ mkHsLam [(L noSrcSpanA (VisPat NoExtField (noLocA $ VarPat noExtField $ noLocA arg_name)))] body
let failAfterFromStringSynExpr :: SyntaxExpr GhcRn =
mkSyntaxExpr failAfterFromStringExpr
return (failAfterFromStringSynExpr, failFvs `plusFV` fromStringFvs)
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index 674cfe6198..07d805334f 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -1534,8 +1534,8 @@ checkPrecMatch :: Name -> MatchGroup GhcRn body -> RnM ()
checkPrecMatch op (MG { mg_alts = (L _ ms) })
= mapM_ check ms
where
- check (L _ (Match { m_pats = (L l1 p1)
- : (L l2 p2)
+ check (L _ (Match { m_pats = (L _ (VisPat _ (L l1 p1)))
+ : (L _ (VisPat _ (L l2 p2)))
: _ }))
= setSrcSpan (locA $ combineSrcSpansA l1 l2) $
do checkPrec op p1 False
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 534b03e602..17a1973065 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -23,6 +23,7 @@ free variables.
-}
module GHC.Rename.Pat (-- main entry points
rnPat, rnPats, rnBindPat, rnPatAndThen,
+ rnLMatchPats, rnLMatchPat,
NameMaker, applyNameMaker, -- a utility for making names:
localRecNameMaker, topRecNameMaker, -- sometimes we want to make local names,
@@ -430,6 +431,50 @@ rnPats ctxt pats thing_inside
where
doc_pat = text "In" <+> pprMatchContext ctxt
+rnLMatchPatAndThen :: NameMaker -> LMatchPat GhcPs -> CpsRn (LMatchPat GhcRn)
+rnLMatchPatAndThen nm pat = wrapSrcSpanCps (rnMatchPatAndThen nm) pat
+
+rnLMatchPatsAndThen :: NameMaker -> [LMatchPat GhcPs] -> CpsRn ([LMatchPat GhcRn])
+rnLMatchPatsAndThen nm = mapM (rnLMatchPatAndThen nm)
+
+rnMatchPatAndThen :: NameMaker -> MatchPat GhcPs -> CpsRn (MatchPat GhcRn)
+rnMatchPatAndThen nm (VisPat _ lpat)
+ = do { renamed_pat <- rnLPatAndThen nm lpat
+ ; return (VisPat NoExtField renamed_pat)
+ }
+rnMatchPatAndThen nm (InvisTyVarPat _ (L l rdr))
+ = do { loc <- liftCps getSrcSpanM
+ ; name <- newPatName nm (L (noAnnSrcSpan loc) rdr)
+ ; return (InvisTyVarPat NoExtField (L l name))
+ }
+rnMatchPatAndThen _ (InvisWildTyPat _) = return (InvisWildTyPat NoExtField)
+
+rnLMatchPats :: HsMatchContext GhcRn -- for error messages
+ -> [LMatchPat GhcPs]
+ -> ([LMatchPat GhcRn] -> RnM (a, FreeVars))
+ -> RnM (a, FreeVars)
+rnLMatchPats ctxt pats thing_inside
+ = do { envs_before <- getRdrEnvs
+ ; unCpsRn (rnLMatchPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do
+ {
+ ; let bndrs = collectLMatchPatsBinders CollNoDictBinders pats'
+ ; addErrCtxt doc_pat $
+ if isPatSynCtxt ctxt
+ then checkDupNames bndrs
+ else checkDupAndShadowedNames envs_before bndrs
+ ; thing_inside pats'
+ } }
+ where
+ doc_pat = text "In" <+> pprMatchContext ctxt
+
+rnLMatchPat :: HsMatchContext GhcRn -- for error messages
+ -> LMatchPat GhcPs
+ -> (LMatchPat GhcRn -> RnM (a, FreeVars))
+ -> RnM (a, FreeVars)
+rnLMatchPat ctxt pat thing_inside =
+ rnLMatchPats ctxt [pat] (\pats' -> let [pat'] = pats' in thing_inside pat')
+
+
rnPat :: HsMatchContext GhcRn -- for error messages
-> LPat GhcPs
-> (LPat GhcRn -> RnM (a, FreeVars))
diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs
index b472ac9589..c7c22c2bc1 100644
--- a/compiler/Language/Haskell/Syntax/Expr.hs
+++ b/compiler/Language/Haskell/Syntax/Expr.hs
@@ -1065,7 +1065,7 @@ data Match p body
m_ext :: XCMatch p body,
m_ctxt :: HsMatchContext p,
-- See note [m_ctxt in Match]
- m_pats :: [LPat p], -- The patterns
+ m_pats :: [LMatchPat p], -- The patterns
m_grhss :: (GRHSs p body)
}
| XMatch !(XXMatch p body)
diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs
index 8d8eadf135..fa7628f8ad 100644
--- a/compiler/Language/Haskell/Syntax/Extension.hs
+++ b/compiler/Language/Haskell/Syntax/Extension.hs
@@ -583,6 +583,10 @@ type family XSigPat x
type family XCoPat x
type family XXPat x
type family XHsFieldBind x
+type family XVisPat x
+type family XInvisTyVarPat x
+type family XInvisWildTyPat x
+type family XXMatchPat x
-- =====================================================================
-- Type families for the HsTypes type families
diff --git a/compiler/Language/Haskell/Syntax/Pat.hs b/compiler/Language/Haskell/Syntax/Pat.hs
index 4393ad998a..02948d9664 100644
--- a/compiler/Language/Haskell/Syntax/Pat.hs
+++ b/compiler/Language/Haskell/Syntax/Pat.hs
@@ -19,8 +19,7 @@
-- See Note [Language.Haskell.Syntax.* Hierarchy] for why not GHC.Hs.*
module Language.Haskell.Syntax.Pat (
- Pat(..), LPat,
- ConLikeP,
+ Pat(..), LPat, MatchPat(..), LMatchPat, toLPats, toPats, toInvisPats, ConLikeP,
HsConPatDetails, hsConPatArgs,
HsRecFields(..), HsFieldBind(..), LHsFieldBind,
@@ -214,6 +213,35 @@ data Pat p
type family ConLikeP x
+data MatchPat pass
+ = VisPat (XVisPat pass) (LPat pass)
+ | InvisTyVarPat (XInvisTyVarPat pass) (LIdP pass)
+ | InvisWildTyPat (XInvisWildTyPat pass)
+ | XMatchPat !(XXMatchPat pass)
+
+type LMatchPat pass = XRec pass (MatchPat pass)
+
+toLPats :: forall pass. UnXRec pass => [LMatchPat pass] -> [LPat pass]
+toLPats [] = []
+toLPats (x : xs) =
+ case unXRec @pass x of
+ VisPat _ pat -> pat : toLPats xs
+ _ -> toLPats xs
+
+toPats :: forall pass. UnXRec pass => [MatchPat pass] -> [Pat pass]
+toPats [] = []
+toPats (x : xs) =
+ case x of
+ VisPat _ pat -> unXRec @pass pat : toPats xs
+ _ -> toPats xs
+
+toInvisPats :: forall pass. UnXRec pass => [LMatchPat pass] -> [LMatchPat pass]
+toInvisPats [] = []
+toInvisPats (x : xs) =
+ case unXRec @pass x of
+ InvisTyVarPat _ _ -> x : toInvisPats xs
+ InvisWildTyPat _ -> x : toInvisPats xs
+ _ -> toInvisPats xs
-- ---------------------------------------------------------------------
diff --git a/compiler/Language/Haskell/Syntax/Pat.hs-boot b/compiler/Language/Haskell/Syntax/Pat.hs-boot
index 4ff0371e39..29ec86565f 100644
--- a/compiler/Language/Haskell/Syntax/Pat.hs-boot
+++ b/compiler/Language/Haskell/Syntax/Pat.hs-boot
@@ -9,5 +9,8 @@ import Language.Haskell.Syntax.Extension ( XRec )
import Data.Kind
type role Pat nominal
+type role MatchPat nominal
data Pat (i :: Type)
type LPat i = XRec i (Pat i)
+data MatchPat i
+type LMatchPat i = XRec i (MatchPat i)
View Lorry Controller Status