[Git][ghc/ghc][wip/or-pats-amendment] Prohibit TyApps
David (@knothed)
gitlab at gitlab.haskell.org
Fri Apr 14 12:50:10 UTC 2023
David pushed to branch wip/or-pats-amendment at Glasgow Haskell Compiler / GHC
Commits:
80d0af35 by David Knothe at 2023-04-14T14:50:03+02:00
Prohibit TyApps
- - - - -
8 changed files:
- compiler/GHC/Hs/Pat.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Utils/Zonk.hs
- compiler/GHC/Types/Error/Codes.hs
Changes:
=====================================
compiler/GHC/Hs/Pat.hs
=====================================
@@ -47,6 +47,8 @@ module GHC.Hs.Pat (
collectEvVarsPat, collectEvVarsPats,
+ patHasTyAppsL,
+
pprParendLPat, pprConArgs,
pprLPat
) where
@@ -732,6 +734,7 @@ collectEvVarsPat pat =
BangPat _ p -> collectEvVarsLPat p
ListPat _ ps -> unionManyBags $ map collectEvVarsLPat ps
TuplePat _ ps _ -> unionManyBags $ map collectEvVarsLPat ps
+ OrPat _ ps -> unionManyBags $ map collectEvVarsLPat ps
SumPat _ p _ _ -> collectEvVarsLPat p
ConPat
{ pat_args = args
@@ -749,6 +752,29 @@ collectEvVarsPat pat =
ExpansionPat _ p -> collectEvVarsPat p
_other_pat -> emptyBag
+{-
+% True if the pattern contains a type application, ignoring nested or-patterns.
+-}
+patHasTyApps :: Pat GhcPs -> Bool
+patHasTyApps pat =
+ case pat of
+ LazyPat _ p -> patHasTyAppsL p
+ AsPat _ _ _ p -> patHasTyAppsL p
+ ParPat _ _ p _ -> patHasTyAppsL p
+ BangPat _ p -> patHasTyAppsL p
+ ListPat _ ps -> any patHasTyAppsL ps
+ TuplePat _ ps _ -> any patHasTyAppsL ps
+ OrPat _ _ -> False -- this prohibits redundant error messages
+ SumPat _ p _ _ -> patHasTyAppsL p
+ ConPat { pat_args = args } -> case args of
+ PrefixCon ts ps -> not (null ts) || any patHasTyAppsL ps
+ RecCon fs -> any (patHasTyAppsL . hfbRHS . unXRec @GhcPs) (rec_flds fs)
+ InfixCon p1 p2 -> any patHasTyAppsL [p1,p2]
+ SigPat _ p _ -> patHasTyAppsL p
+ _other_pat -> False
+
+patHasTyAppsL :: GenLocated l (Pat GhcPs) -> Bool
+patHasTyAppsL = patHasTyApps . unLoc
{-
************************************************************************
* *
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -1220,7 +1220,7 @@ collect_pat flag pat bndrs = case pat of
ListPat _ pats -> foldr (collect_lpat flag) bndrs pats
TuplePat _ pats _ -> foldr (collect_lpat flag) bndrs pats
-- Evidence binders in an OrPat currently aren't visible outside their
- -- binding pattern. This makes error messages more specific.
+ -- binding pattern. This prohibits redundant error messages.
OrPat _ _ -> []
SumPat _ pat _ _ -> collect_lpat flag pat bndrs
LitPat _ _ -> bndrs
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -44,6 +44,7 @@ import {-# SOURCE #-} GHC.Rename.Expr ( rnLExpr )
import {-# SOURCE #-} GHC.Rename.Splice ( rnSplicePat )
import GHC.Hs
+import GHC.Hs.Pat ( patHasTyAppsL )
import GHC.Tc.Errors.Types
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Zonk ( hsOverLitName )
@@ -612,7 +613,12 @@ rnPatAndThen mk (TuplePat _ pats boxed)
rnPatAndThen mk (OrPat _ pats)
= do { pats' <- rnLPatsAndThen mk pats
- ; return (OrPat noExtField pats') }
+ ; let orpat :: Pat GhcRn = OrPat noExtField pats'
+ ; let varBnds = collectPatsBinders CollNoDictBinders pats
+ -- mapM_ (\(b,i) -> pprTraceM ("bnds " ++ show i) b) (zip (map ppr bnds) [0..])
+ ; liftCps $ checkErr (null varBnds) (TcRnOrPatBindsVariables orpat)
+ ; liftCps $ checkErr (not $ any patHasTyAppsL pats) (TcRnOrPatHasVisibleTyApps orpat)
+ ; return orpat }
rnPatAndThen mk (SumPat _ pat alt arity)
= do { pat <- rnLPatAndThen mk pat
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1246,9 +1246,12 @@ instance Diagnostic TcRnMessage where
False -> text (TH.pprint item))
TcRnReportCustomQuasiError _ msg -> mkSimpleDecorated $ text msg
TcRnInterfaceLookupError _ sdoc -> mkSimpleDecorated sdoc
- TcRnOrPatBindsVariables pat vars -> case vars of
- True -> mkSimpleDecorated $ text "An or-pattern may not bind (type) variables:" <+> ppr pat
- False -> mkSimpleDecorated $ text "An or-pattern may not bind (type) variables nor type class or equality constraints:" <+> ppr pat
+ TcRnOrPatBindsVariables pat
+ -> mkSimpleDecorated $
+ text "An or-pattern may not bind variables:" <+> ppr pat
+ TcRnOrPatHasVisibleTyApps pat
+ -> mkSimpleDecorated $
+ text "An or-pattern may not contain visible type applications:" <+> ppr pat
TcRnUnsatisfiedMinimalDef mindef
-> mkSimpleDecorated $
vcat [text "No explicit implementation for"
@@ -2095,6 +2098,8 @@ instance Diagnostic TcRnMessage where
-> ErrorWithoutFlag
TcRnOrPatBindsVariables{}
-> ErrorWithoutFlag
+ TcRnOrPatHasVisibleTyApps{}
+ -> ErrorWithoutFlag
TcRnUnsatisfiedMinimalDef{}
-> WarningWithFlag (Opt_WarnMissingMethods)
TcRnMisplacedInstSig{}
@@ -2673,6 +2678,8 @@ instance Diagnostic TcRnMessage where
-> noHints
TcRnOrPatBindsVariables{}
-> noHints
+ TcRnOrPatHasVisibleTyApps{}
+ -> noHints
TcRnUnsatisfiedMinimalDef{}
-> noHints
TcRnMisplacedInstSig{}
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -2730,15 +2730,24 @@ data TcRnMessage where
-}
TcRnInterfaceLookupError :: !Name -> !SDoc -> TcRnMessage
- {-| TcRnOrPatBindsVariables is an error that happens when an
- or-pattern binds variables or has dictionary or evidence biders, e.g. (one of A, B x).
+ {-| TcRnOrPatBindsVariables is an error that happens when
+ a pattern nested in an or-pattern binds variables, e.g. (one of A; B x).
Test case:
testsuite/tests/typecheck/should_fail/Or3
-}
TcRnOrPatBindsVariables
- :: Pat GhcTc -- the or-pattern
- -> Bool -- True => pattern contains just (type) variables; False => pattern contains other dictionary/evidence binders
+ :: Pat GhcRn -- the or-pattern
+ -> TcRnMessage
+
+ {-| TcRnOrPatHasVisibleTyApps is an error that happens when
+ a pattern nested in an or-pattern uses a visible type application e.g. (one of Just @Int _).
+
+ Test case:
+ todo
+ -}
+ TcRnOrPatHasVisibleTyApps
+ :: Pat GhcRn -- the or-pattern
-> TcRnMessage
{- | TcRnUnsatisfiedMinimalDef is a warning that occurs when a class instance
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -402,7 +402,8 @@ tc_pat pat_ty penv ps_pat thing_inside = case ps_pat of
; return (BangPat x pat', res) }
OrPat _ pats -> do -- or-patterns with variables are rejected later, after zonking
- { (pats', res) <- tc_lpats (map (const pat_ty) pats) penv pats thing_inside
+ { (pats', (res, pat_ct)) <- tc_lpats (map (const pat_ty) pats) penv pats (captureConstraints thing_inside)
+ ; emitConstraints pat_ct
; pat_ty <- expTypeToType (scaledThing pat_ty)
; return (OrPat pat_ty pats', res) }
=====================================
compiler/GHC/Tc/Utils/Zonk.hs
=====================================
@@ -1347,14 +1347,7 @@ zonk_pat env (TuplePat tys pats boxed)
zonk_pat env p@(OrPat ty pats)
= do { ty' <- zonkTcTypeToTypeX env ty
; (env', pats') <- zonkPats env pats
- ; checkNoVarsBound pats' p
; return (env', OrPat ty' pats') }
- where
- checkNoVarsBound :: [LPat GhcTc] -> Pat GhcTc -> TcRn ()
- checkNoVarsBound pats orpat = do
- let bnds = collectPatsBinders CollWithDictBinders pats
- let varBnds = collectPatsBinders CollNoDictBinders pats
- unless (null bnds) $ addErr (TcRnOrPatBindsVariables orpat (varBnds `equalLength` bnds))
zonk_pat env (SumPat tys pat alt arity )
= do { tys' <- mapM (zonkTcTypeToTypeX env) tys
=====================================
compiler/GHC/Types/Error/Codes.hs
=====================================
@@ -473,6 +473,7 @@ type family GhcDiagnosticCode c = n | n -> c where
GhcDiagnosticCode "TcRnSpecialiseNotVisible" = 85337
GhcDiagnosticCode "TcRnIllegalTypeOperatorDecl" = 50649
GhcDiagnosticCode "TcRnOrPatBindsVariables" = 81303
+ GhcDiagnosticCode "TcRnOrPatHasVisibleTyApps" = 28418
GhcDiagnosticCode "TcRnBindVarAlreadyInScope" = 69710
GhcDiagnosticCode "TcRnBindMultipleVariables" = 92957
GhcDiagnosticCode "TcRnIllegalKind" = 64861
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/80d0af35c2f2b469185ec41d233fc5ea919eebd5
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/80d0af35c2f2b469185ec41d233fc5ea919eebd5
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/20230414/65aa06ab/attachment-0001.html>
More information about the ghc-commits
mailing list