diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs index 1fd5c45aed47e1f871fdf4ce06b31486a25481e5..2aa596949c6109ef6e34eace9b57b324e19c3868 100644 --- a/compiler/GHC/Tc/Errors/Ppr.hs +++ b/compiler/GHC/Tc/Errors/Ppr.hs @@ -1258,9 +1258,7 @@ instance Diagnostic TcRnMessage where TcRnIllformedTypePattern p -> mkSimpleDecorated $ - hang (text "Ill-formed type pattern:") 2 (ppr p) $$ - text "Expected a type pattern introduced with the" - <+> quotes (text "type") <+> text "keyword." + hang (text "Ill-formed type pattern:") 2 (ppr p) TcRnIllegalTypePattern -> mkSimpleDecorated $ text "Illegal type pattern." $$ diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs index 2aaaed941f4f187ecaf00dc9b32ef6af917c7f45..f592cb9c92a5eaea93fb037aece794388d03ee75 100644 --- a/compiler/GHC/Tc/Gen/App.hs +++ b/compiler/GHC/Tc/Gen/App.hs @@ -1100,13 +1100,13 @@ At definition sites we may have type /patterns/ to abstract over type variables fs x = rhs -- Specified: type pattern omitted fs @a (x :: a) = rhs -- Specified: type pattern supplied (NB: not implemented) fr (type a) (x :: a) = rhs -- Required: type pattern is compulsory, `type` qualifier used - fr a (x :: a) = rhs -- Required: type pattern is compulsory, `type` qualifier omitted (NB: not implemented) + fr a (x :: a) = rhs -- Required: type pattern is compulsory, `type` qualifier omitted Type patterns in lambdas work the same way as they do in a function LHS fs = \ x -> rhs -- Specified: type pattern omitted fs = \ @a (x :: a) -> rhs -- Specified: type pattern supplied (NB: not implemented) fr = \ (type a) (x :: a) -> rhs -- Required: type pattern is compulsory, `type` qualifier used - fr = \ a (x :: a) -> rhs -- Required: type pattern is compulsory, `type` qualifier omitted (NB: not implemented) + fr = \ a (x :: a) -> rhs -- Required: type pattern is compulsory, `type` qualifier omitted Type patterns may also occur in a constructor pattern. Consider the following data declaration data T where @@ -1177,7 +1177,7 @@ Syntax of abstractions in Pat * Examples: \ (MkT @a (x :: a)) -> rhs -- ConPat (c.o. Pat) and HsConPatTyArg (c.o. HsConPatTyArg) \ (type a) (x :: a) -> rhs -- EmbTyPat (c.o. Pat) - \ a (x :: a) -> rhs -- VarPat (c.o. Pat) (NB. not implemented) + \ a (x :: a) -> rhs -- VarPat (c.o. Pat) \ @a (x :: a) -> rhs -- to be decided (NB. not implemented) * A HsTyPat is not necessarily a plain variable. At the very least, @@ -1230,7 +1230,7 @@ variable. Only later (in the type checker) will we find out that it stands for the forall-bound type variable `a`. So when RequiredTypeArguments is in effect, we change implicit quantification to take term variables into account; that is, we do not implicitly quantify the signature of `g` to `g :: forall t. t->t` -because of the term-level `t` that is in scope. (NB. not implemented) +because of the term-level `t` that is in scope. See Note [Term variable capture and implicit quantification]. Typechecking type applications diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs index 7734625bb713803ef80e46458c41e2b4c04420d1..845549439f24276e4f4f9981585a2952fc1eb458 100644 --- a/compiler/GHC/Tc/Gen/Pat.hs +++ b/compiler/GHC/Tc/Gen/Pat.hs @@ -390,13 +390,33 @@ tc_tt_pat (ExpForAllPatTy tv) penv pat thing_inside = tc_forall_pat penv (pat, tc_forall_pat :: Checker (Pat GhcRn, TcTyVar) (Pat GhcTc) tc_forall_pat _ (EmbTyPat _ toktype tp, tv) thing_inside + = do { (arg_ty, result) <- tc_ty_pat tp tv thing_inside + ; return (EmbTyPat arg_ty toktype tp, result) } +tc_forall_pat _ (pat, tv) thing_inside + = do { tp <- pat_to_type_pat pat + ; (arg_ty, result) <- tc_ty_pat tp tv thing_inside + ; let pat' = XPat $ ExpansionPat pat (EmbTyPat arg_ty noHsTok tp) + ; return (pat', result) } + +-- Convert a Pat into the equivalent HsTyPat. +pat_to_type_pat :: Pat GhcRn -> TcM (HsTyPat GhcRn) +pat_to_type_pat (EmbTyPat _ _ tp) = return tp +pat_to_type_pat (VarPat _ lname) = return (HsTP x b) + where x = HsTPRn [] [] [unLoc lname] + b = noLocA (HsTyVar noAnn NotPromoted lname) +pat_to_type_pat (WildPat _) = return (HsTP x b) + where x = HsTPRn [] [] [] + b = noLocA (HsWildCardTy noExtField) +pat_to_type_pat pat = failWith $ TcRnIllformedTypePattern pat + +tc_ty_pat :: HsTyPat GhcRn -> TcTyVar -> TcM r -> TcM (TcType, r) +tc_ty_pat tp tv thing_inside = do { (sig_wcs, sig_ibs, arg_ty) <- tcHsTyPat tp (varType tv) ; _ <- unifyType Nothing arg_ty (mkTyVarTy tv) ; result <- tcExtendNameTyVarEnv sig_wcs $ tcExtendNameTyVarEnv sig_ibs $ thing_inside - ; return (EmbTyPat arg_ty toktype tp, result) } -tc_forall_pat _ (pat, _) _ = failWith $ TcRnIllformedTypePattern pat + ; return (arg_ty, result) } tc_pat :: Scaled ExpSigmaTypeFRR -- ^ Fully refined result type diff --git a/testsuite/tests/vdq-rta/should_compile/T23739_idv.hs b/testsuite/tests/vdq-rta/should_compile/T23739_idv.hs new file mode 100644 index 0000000000000000000000000000000000000000..9b1d7160d19306286b4931c54f49ac7fe3df2a62 --- /dev/null +++ b/testsuite/tests/vdq-rta/should_compile/T23739_idv.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE RequiredTypeArguments #-} + +module T23739_idv where + +-- Definition: +idv :: forall a -> a -> a +idv t x = x :: t + +-- Definition (using a lambda) +idv_lam :: forall a -> a -> a +idv_lam = \t x -> x :: t + +-- Definition (eta-reduced) +idv_eta :: forall a -> a -> a +idv_eta = idv + +-- Definition (using vta on the rhs) +idv_vta :: forall a -> a -> a +idv_vta t = id @t + +-- Definition (using sig on the rhs) +idv_sig :: forall a -> a -> a +idv_sig t = id :: t -> t + +-- Definition (using a wildcard) +idv_wild :: forall a -> a -> a +idv_wild _ x = x \ No newline at end of file diff --git a/testsuite/tests/vdq-rta/should_compile/all.T b/testsuite/tests/vdq-rta/should_compile/all.T index 835d7f12fc012aaebcc5858124683f754ce147a0..eb83e2b9da54374caf8fc682fc6f4060c5a46450 100644 --- a/testsuite/tests/vdq-rta/should_compile/all.T +++ b/testsuite/tests/vdq-rta/should_compile/all.T @@ -16,6 +16,7 @@ test('T23738_overlit', normal, compile, ['']) test('T23738_nested', normal, compile, ['']) test('T23738_wild', normal, compile, ['']) test('T23738_sigforall', normal, compile, ['']) +test('T23739_idv', normal, compile, ['']) test('T22326_th_dump1', req_th, compile, ['-v0 -ddump-splices -dsuppress-uniques']) test('T22326_th_pprint1', req_th, compile, ['']) diff --git a/testsuite/tests/vdq-rta/should_fail/T22326_fail_raw_pat.hs b/testsuite/tests/vdq-rta/should_fail/T22326_fail_raw_pat.hs index 2b8ca18a2eafa83e0fa6b0efe88973a4c812fad4..97aba2a08e7d64568209624e8fe37b51104238f4 100644 --- a/testsuite/tests/vdq-rta/should_fail/T22326_fail_raw_pat.hs +++ b/testsuite/tests/vdq-rta/should_fail/T22326_fail_raw_pat.hs @@ -1,7 +1,6 @@ -{-# LANGUAGE ExplicitNamespaces #-} {-# LANGUAGE RequiredTypeArguments #-} module T22326_fail_raw_pat where f :: forall (a :: k) -> () -f x = () \ No newline at end of file +f !x = () \ No newline at end of file diff --git a/testsuite/tests/vdq-rta/should_fail/T22326_fail_raw_pat.stderr b/testsuite/tests/vdq-rta/should_fail/T22326_fail_raw_pat.stderr index cae79feb09f417c1187c92fc2dd51c3dacb0021c..7cdc761f839a4cd45b045adaf23c0c24702a2e81 100644 --- a/testsuite/tests/vdq-rta/should_fail/T22326_fail_raw_pat.stderr +++ b/testsuite/tests/vdq-rta/should_fail/T22326_fail_raw_pat.stderr @@ -1,5 +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 = () +T22326_fail_raw_pat.hs:6:3: error: [GHC-88754] + • Ill-formed type pattern: !x + • In the pattern: !x + In an equation for ‘f’: f !x = ()