[Git][ghc/ghc][wip/int-index/emb-type] 3 commits: WIP: check case of
Vladislav Zavialov (@int-index)
gitlab at gitlab.haskell.org
Fri Oct 28 00:13:18 UTC 2022
Vladislav Zavialov pushed to branch wip/int-index/emb-type at Glasgow Haskell Compiler / GHC
Commits:
f07a42f5 by Vladislav Zavialov at 2022-10-27T23:53:31+04:00
WIP: check case of
- - - - -
30a01330 by Vladislav Zavialov at 2022-10-28T02:23:41+04:00
WIP: remove panic in tc_forall_pat
- - - - -
61ca2685 by Vladislav Zavialov at 2022-10-28T03:42:42+04:00
Proper filtering in tcMatch
- - - - -
10 changed files:
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Errors/Ppr.hs
- compiler/GHC/Tc/Errors/Types.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Pat.hs
- + testsuite/tests/vdq-rta/should_fail/T22326_fail_caseof.hs
- + testsuite/tests/vdq-rta/should_fail/T22326_fail_caseof.stderr
- + testsuite/tests/vdq-rta/should_fail/T22326_fail_raw_pat.hs
- + testsuite/tests/vdq-rta/should_fail/T22326_fail_raw_pat.stderr
- testsuite/tests/vdq-rta/should_fail/all.T
Changes:
=====================================
compiler/GHC/Rename/Pat.hs
=====================================
@@ -644,7 +644,7 @@ rnEmbTyPatAndThen _ toktype (HsWC _ (L l (HsTyVar _ NotPromoted lrdr)))
$ HsWC [] (L l (HsTyVar noAnn NotPromoted lnm))
}
rnEmbTyPatAndThen _ _ lty =
- liftCps $ failWith $ TcRnIllformedTypePattern lty
+ liftCps $ failWith $ TcRnIllformedTypePattern (Right lty)
--------------------
rnConPatAndThen :: NameMaker
=====================================
compiler/GHC/Tc/Errors/Ppr.hs
=====================================
@@ -1153,14 +1153,19 @@ instance Diagnostic TcRnMessage where
False -> text (TH.pprint item))
TcRnReportCustomQuasiError _ msg -> mkSimpleDecorated $ text msg
TcRnInterfaceLookupError _ sdoc -> mkSimpleDecorated sdoc
- TcRnIllformedTypePattern ty
+ TcRnIllformedTypePattern (Left p)
+ -> mkSimpleDecorated $
+ hang (text "Ill-formed type pattern:") 2 (ppr p) $$
+ text "Expected a type pattern introduced with the"
+ <+> quotes (text "type") <+> text "keyword."
+ TcRnIllformedTypePattern (Right ty)
-> mkSimpleDecorated $
hang (text "Ill-formed type pattern:") 2 (ppr ty) $$
text "Only variables and wildcards are allowed."
TcRnIllegalTypePattern
-> mkSimpleDecorated $
text "Illegal type pattern." $$
- text "A type pattern must be checked against a visible forall." -- TODO (int-index): better error message
+ text "A type pattern must be checked against a visible forall."
TcRnIllegalTyVarInPat name
-> mkSimpleDecorated $
text "Illegal type variable binding in a pattern:" <+> quotes (ppr name)
@@ -1172,7 +1177,7 @@ instance Diagnostic TcRnMessage where
TcRnIllegalTypeExpr
-> mkSimpleDecorated $
text "Illegal type expression." $$
- text "A type expression must be used to instantiate a visible forall." -- TODO (int-index): better error message
+ text "A type expression must be used to instantiate a visible forall."
diagnosticReason = \case
TcRnUnknownMessage m
=====================================
compiler/GHC/Tc/Errors/Types.hs
=====================================
@@ -2545,7 +2545,7 @@ data TcRnMessage where
-}
TcRnInterfaceLookupError :: !Name -> !SDoc -> TcRnMessage
- TcRnIllformedTypePattern :: !(LHsWcType GhcPs) -> TcRnMessage
+ TcRnIllformedTypePattern :: !(Either (Pat GhcRn) (LHsWcType GhcPs)) -> TcRnMessage
TcRnIllegalTypePattern :: TcRnMessage
TcRnIllegalTyVarInPat :: !Name -> TcRnMessage
TcRnIllformedTypeArgument :: !(LHsExpr GhcRn) -> TcRnMessage
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -79,6 +79,7 @@ import GHC.Types.SrcLoc
import Control.Monad
import Control.Arrow ( second )
import qualified Data.List.NonEmpty as NE
+import Data.Maybe (mapMaybe)
{-
************************************************************************
@@ -230,7 +231,7 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
-- when in inference mode, so we must do it ourselves,
-- here, using expTypeToType
= do { tcEmitBindingUsage bottomUE
- ; pat_tys <- mapM scaledExpTypeToType [ty | ExpFunPatTy ty <- pat_tys] -- TODO(int-index): handle ExpForallPatTy?
+ ; pat_tys <- mapM scaledExpTypeToType (filter_out_forall_pat_tys pat_tys)
; rhs_ty <- expTypeToType rhs_ty
; return (MG { mg_alts = L l []
, mg_ext = MatchGroupTc pat_tys rhs_ty origin
@@ -240,12 +241,19 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
= do { umatches <- mapM (tcCollectingUsage . tcMatch ctxt pat_tys rhs_ty) matches
; let (usages,matches') = unzip umatches
; tcEmitBindingUsage $ supUEs usages
- ; pat_tys <- mapM readScaledExpType [ty | ExpFunPatTy ty <- pat_tys] -- TODO(int-index): handle ExpForallPatTy?
+ ; pat_tys <- mapM readScaledExpType (filter_out_forall_pat_tys pat_tys)
; rhs_ty <- readExpType rhs_ty
; traceTc "tcMatches" (ppr matches' $$ ppr pat_tys $$ ppr rhs_ty)
; return (MG { mg_alts = L l matches'
, mg_ext = MatchGroupTc pat_tys rhs_ty origin
}) }
+ where
+ -- We filter out foralls because we have no use for them in HsToCore.
+ filter_out_forall_pat_tys :: [ExpPatType] -> [Scaled ExpSigmaTypeFRR]
+ filter_out_forall_pat_tys = mapMaybe match_fun_pat_ty
+ where
+ match_fun_pat_ty (ExpFunPatTy t) = Just t
+ match_fun_pat_ty _ = Nothing
-------------
tcMatch :: (AnnoBody body) => TcMatchCtxt body
@@ -264,8 +272,7 @@ tcMatch ctxt pat_tys rhs_ty match
tcGRHSs ctxt grhss rhs_ty
; return (Match { m_ext = noAnn
, m_ctxt = mc_what ctxt
- -- FIXME(int-index): instead of filtering here, handle the type patterns in the desugarer
- , m_pats = let { ughhh (L _ EmbTyPat{}) = False; ughhh (L _ (ParPat _ _ p _)) = ughhh p; ughhh _ = True } in filter ughhh pats'
+ , m_pats = filter_out_type_pats pats'
, m_grhss = grhss' }) }
-- For (\x -> e), tcExpr has already said "In the expression \x->e"
@@ -275,6 +282,14 @@ tcMatch ctxt pat_tys rhs_ty match
LambdaExpr -> thing_inside
_ -> addErrCtxt (pprMatchInCtxt match) thing_inside
+ -- We filter out type patterns because we have no use for them in HsToCore.
+ -- Type variable bindings have already been converted to HsWrappers.
+ filter_out_type_pats :: [LPat GhcTc] -> [LPat GhcTc]
+ filter_out_type_pats = filterByList (map is_fun_pat_ty pat_tys)
+ where
+ is_fun_pat_ty ExpFunPatTy{} = True
+ is_fun_pat_ty _ = False
+
-------------
tcGRHSs :: AnnoBody body
=> TcMatchCtxt body -> GRHSs GhcRn (LocatedA (body GhcRn)) -> ExpRhoType
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -389,8 +389,7 @@ tc_forall_pat tv penv (EmbTyPat _ toktype lty) thing_inside
| HsWC _ (L l (HsWildCardTy _)) <- lty
= do { r <- thing_inside
; return (EmbTyPat (tyVarKind tv) toktype lty, r) }
-tc_forall_pat tv penv pat thing_inside =
- pprPanic "tc_forall_pat" (ppr pat)
+tc_forall_pat _ _ pat _ = failWith $ TcRnIllformedTypePattern (Left pat)
tc_pat :: Scaled ExpSigmaTypeFRR
-- ^ Fully refined result type
=====================================
testsuite/tests/vdq-rta/should_fail/T22326_fail_caseof.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE RequiredTypeArguments #-}
+
+module T22326_fail_caseof where
+
+f :: Int -> Bool
+f x =
+ case x of
+ (type _) -> True
+ _ -> False
\ No newline at end of file
=====================================
testsuite/tests/vdq-rta/should_fail/T22326_fail_caseof.stderr
=====================================
@@ -0,0 +1,10 @@
+
+T22326_fail_caseof.hs:9:6: error: [GHC-70206]
+ • Illegal type pattern.
+ A type pattern must be checked against a visible forall.
+ • In the pattern: type _
+ In a case alternative: (type _) -> True
+ In the expression:
+ case x of
+ (type _) -> True
+ _ -> False
=====================================
testsuite/tests/vdq-rta/should_fail/T22326_fail_raw_pat.hs
=====================================
@@ -0,0 +1,7 @@
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE RequiredTypeArguments #-}
+
+module T22326_fail_raw_pat where
+
+f :: forall (a :: k) -> ()
+f x = ()
\ No newline at end of file
=====================================
testsuite/tests/vdq-rta/should_fail/T22326_fail_raw_pat.stderr
=====================================
@@ -0,0 +1,5 @@
+
+T22326_fail_raw_pat.hs:7:3: error: [GHC-88754]
+ • Ill-formed type pattern: x
+ Expected a type pattern introduced with the ‘type’ keyword.
+ • In an equation for ‘f’: f x = ()
=====================================
testsuite/tests/vdq-rta/should_fail/all.T
=====================================
@@ -4,5 +4,7 @@ test('T22326_fail_ext3', normal, compile_fail, [''])
test('T22326_fail_top', normal, compile_fail, [''])
test('T22326_fail_app', normal, compile_fail, [''])
test('T22326_fail_notInScope', normal, compile_fail, [''])
+test('T22326_fail_raw_pat', normal, compile_fail, [''])
test('T22326_fail_raw_arg', normal, compile_fail, [''])
-test('T22326_fail_pat', normal, compile_fail, [''])
\ No newline at end of file
+test('T22326_fail_pat', normal, compile_fail, [''])
+test('T22326_fail_caseof', normal, compile_fail, [''])
\ No newline at end of file
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a996954002285fa5b09986b4a8b387180d0f39ad...61ca26859420a05c20bca27a7cd1e30c750236c7
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/a996954002285fa5b09986b4a8b387180d0f39ad...61ca26859420a05c20bca27a7cd1e30c750236c7
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/20221027/1d70ee1d/attachment-0001.html>
More information about the ghc-commits
mailing list