From 2c0f8ddbdf351ed84395afa04a2654a7cbe2ad35 Mon Sep 17 00:00:00 2001
From: Andrei Borzenkov <andreyborzenkov2002@gmail.com>
Date: Thu, 2 May 2024 17:08:46 +0400
Subject: [PATCH] Improve pattern to type pattern transformation (23739)
`pat_to_type_pat` function now can handle more patterns:
- TuplePat
- ListPat
- LitPat
- NPat
- ConPat
Allowing these new constructors in type patterns significantly
increases possible shapes of type patterns without `type` keyword.
This patch also changes how lookups in `lookupOccRnConstr` are
performed, because we need to fall back into
types when we didn't find a constructor on data level to perform
`ConPat` to type transformation properly.
---
compiler/GHC/Hs/Type.hs | 47 +++++++
compiler/GHC/Rename/Env.hs | 26 +++-
compiler/GHC/Rename/Pat.hs | 43 +-----
compiler/GHC/Tc/Gen/App.hs | 19 +--
compiler/GHC/Tc/Gen/Head.hs | 44 +-----
compiler/GHC/Tc/Gen/HsType.hs | 25 +++-
compiler/GHC/Tc/Gen/Pat.hs | 133 +++++++++++++-----
compiler/GHC/Tc/Utils/Env.hs | 42 ++++++
.../tests/rename/should_fail/T19843c.stderr | 9 +-
.../type-data/should_fail/TDPattern.stderr | 7 +-
.../tests/typecheck/should_compile/T23739a.hs | 65 +++++++++
.../tests/typecheck/should_compile/all.T | 1 +
.../tests/typecheck/should_fail/T23739b.hs | 14 ++
.../typecheck/should_fail/T23739b.stderr | 21 +++
testsuite/tests/typecheck/should_fail/all.T | 2 +-
15 files changed, 356 insertions(+), 142 deletions(-)
create mode 100644 testsuite/tests/typecheck/should_compile/T23739a.hs
create mode 100644 testsuite/tests/typecheck/should_fail/T23739b.hs
create mode 100644 testsuite/tests/typecheck/should_fail/T23739b.stderr
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 2d401e1807b3..73f76062456f 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -38,6 +38,7 @@ module GHC.Hs.Type (
HsWildCardBndrs(..),
HsPatSigType(..), HsPSRn(..),
HsTyPat(..), HsTyPatRn(..),
+ HsTyPatRnBuilder(..), tpBuilderExplicitTV, tpBuilderPatSig, buildHsTyPatRn, builderFromHsTyPatRn,
HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType,
HsTupleSort(..),
HsContext, LHsContext, fromMaybeContext,
@@ -128,6 +129,7 @@ import Data.Maybe
import Data.Data (Data)
import qualified Data.Semigroup as S
+import GHC.Data.Bag
{-
************************************************************************
@@ -245,6 +247,51 @@ data HsTyPatRn = HsTPRn
}
deriving Data
+-- | A variant of HsTyPatRn that uses Bags for efficient concatenation.
+-- See Note [Implicit and explicit type variable binders] in GHC.Rename.Pat
+data HsTyPatRnBuilder =
+ HsTPRnB {
+ hstpb_nwcs :: Bag Name,
+ hstpb_imp_tvs :: Bag Name,
+ hstpb_exp_tvs :: Bag Name
+ }
+
+tpBuilderExplicitTV :: Name -> HsTyPatRnBuilder
+tpBuilderExplicitTV name = mempty {hstpb_exp_tvs = unitBag name}
+
+tpBuilderPatSig :: HsPSRn -> HsTyPatRnBuilder
+tpBuilderPatSig HsPSRn {hsps_nwcs, hsps_imp_tvs} =
+ mempty {
+ hstpb_nwcs = listToBag hsps_nwcs,
+ hstpb_imp_tvs = listToBag hsps_imp_tvs
+ }
+
+instance Semigroup HsTyPatRnBuilder where
+ HsTPRnB nwcs1 imp_tvs1 exptvs1 <> HsTPRnB nwcs2 imp_tvs2 exptvs2 =
+ HsTPRnB
+ (nwcs1 `unionBags` nwcs2)
+ (imp_tvs1 `unionBags` imp_tvs2)
+ (exptvs1 `unionBags` exptvs2)
+
+instance Monoid HsTyPatRnBuilder where
+ mempty = HsTPRnB emptyBag emptyBag emptyBag
+
+buildHsTyPatRn :: HsTyPatRnBuilder -> HsTyPatRn
+buildHsTyPatRn HsTPRnB {hstpb_nwcs, hstpb_imp_tvs, hstpb_exp_tvs} =
+ HsTPRn {
+ hstp_nwcs = bagToList hstpb_nwcs,
+ hstp_imp_tvs = bagToList hstpb_imp_tvs,
+ hstp_exp_tvs = bagToList hstpb_exp_tvs
+ }
+
+builderFromHsTyPatRn :: HsTyPatRn -> HsTyPatRnBuilder
+builderFromHsTyPatRn HsTPRn{hstp_nwcs, hstp_imp_tvs, hstp_exp_tvs} =
+ HsTPRnB {
+ hstpb_nwcs = listToBag hstp_nwcs,
+ hstpb_imp_tvs = listToBag hstp_imp_tvs,
+ hstpb_exp_tvs = listToBag hstp_exp_tvs
+ }
+
type instance XXHsPatSigType (GhcPass _) = DataConCantHappen
type instance XXHsTyPat (GhcPass _) = DataConCantHappen
diff --git a/compiler/GHC/Rename/Env.hs b/compiler/GHC/Rename/Env.hs
index 52c163e5f3ca..b953e9d355c5 100644
--- a/compiler/GHC/Rename/Env.hs
+++ b/compiler/GHC/Rename/Env.hs
@@ -1031,8 +1031,32 @@ lookupOccRn = lookupOccRn' WL_Anything
-- lookupOccRnConstr looks up an occurrence of a RdrName and displays
-- constructors and pattern synonyms as suggestions if it is not in scope
+--
+-- There is a fallback to the type level, when the first lookup fails.
+-- This is required to implement a pat-to-type transformation
+-- (See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat)
+-- Consider this example:
+--
+-- data VisProxy a where VP :: forall a -> VisProxy a
+--
+-- f :: VisProxy Int -> ()
+-- f (VP Int) = ()
+--
+-- Here `Int` is actually a type, but it stays on position where
+-- we expect a data constructor.
+--
+-- In all other cases we just use this additional lookup for better
+-- error messaging (See Note [Promotion]).
lookupOccRnConstr :: RdrName -> RnM Name
-lookupOccRnConstr = lookupOccRn' WL_Constructor
+lookupOccRnConstr rdr_name
+ = do { mb_gre <- lookupOccRn_maybe rdr_name
+ ; case mb_gre of
+ Just gre -> return $ greName gre
+ Nothing -> do
+ { mb_ty_gre <- lookup_promoted rdr_name
+ ; case mb_ty_gre of
+ Just gre -> return $ greName gre
+ Nothing -> reportUnboundName' WL_Constructor rdr_name} }
-- lookupOccRnRecField looks up an occurrence of a RdrName and displays
-- record fields as suggestions if it is not in scope
diff --git a/compiler/GHC/Rename/Pat.hs b/compiler/GHC/Rename/Pat.hs
index 6dfbd2c68009..1ab350fffc65 100644
--- a/compiler/GHC/Rename/Pat.hs
+++ b/compiler/GHC/Rename/Pat.hs
@@ -71,7 +71,6 @@ import GHC.Types.SourceText
import GHC.Utils.Misc
import GHC.Data.FastString ( uniqCompareFS )
import GHC.Data.List.SetOps( removeDups )
-import GHC.Data.Bag ( Bag, unitBag, unionBags, emptyBag, listToBag, bagToList )
import GHC.Utils.Outputable
import GHC.Utils.Panic.Plain
import GHC.Types.SrcLoc
@@ -89,7 +88,6 @@ import Data.Functor.Identity ( Identity (..) )
import qualified Data.List.NonEmpty as NE
import Data.Maybe
import Data.Ratio
-import qualified Data.Semigroup as S
import Control.Monad.Trans.Writer.CPS
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
@@ -1242,43 +1240,6 @@ lookupTypeOccTPRnM rdr_name = liftRnFV $ do
name <- lookupTypeOccRn rdr_name
pure (name, unitFV name)
--- | A variant of HsTyPatRn that uses Bags for efficient concatenation.
--- See Note [Implicit and explicit type variable binders]
-data HsTyPatRnBuilder =
- HsTPRnB {
- hstpb_nwcs :: Bag Name,
- hstpb_imp_tvs :: Bag Name,
- hstpb_exp_tvs :: Bag Name
- }
-
-tpb_exp_tv :: Name -> HsTyPatRnBuilder
-tpb_exp_tv name = mempty {hstpb_exp_tvs = unitBag name}
-
-tpb_hsps :: HsPSRn -> HsTyPatRnBuilder
-tpb_hsps HsPSRn {hsps_nwcs, hsps_imp_tvs} =
- mempty {
- hstpb_nwcs = listToBag hsps_nwcs,
- hstpb_imp_tvs = listToBag hsps_imp_tvs
- }
-
-instance Semigroup HsTyPatRnBuilder where
- HsTPRnB nwcs1 imp_tvs1 exptvs1 <> HsTPRnB nwcs2 imp_tvs2 exptvs2 =
- HsTPRnB
- (nwcs1 `unionBags` nwcs2)
- (imp_tvs1 `unionBags` imp_tvs2)
- (exptvs1 `unionBags` exptvs2)
-
-instance Monoid HsTyPatRnBuilder where
- mempty = HsTPRnB emptyBag emptyBag emptyBag
-
-buildHsTyPatRn :: HsTyPatRnBuilder -> HsTyPatRn
-buildHsTyPatRn HsTPRnB {hstpb_nwcs, hstpb_imp_tvs, hstpb_exp_tvs} =
- HsTPRn {
- hstp_nwcs = bagToList hstpb_nwcs,
- hstp_imp_tvs = bagToList hstpb_imp_tvs,
- hstp_exp_tvs = bagToList hstpb_exp_tvs
- }
-
rn_lty_pat :: LHsType GhcPs -> TPRnM (LHsType GhcRn)
rn_lty_pat (L l hs_ty) = do
hs_ty' <- rn_ty_pat hs_ty
@@ -1292,7 +1253,7 @@ rn_ty_pat_var lrdr@(L l rdr) = do
then do -- binder
name <- liftTPRnCps $ newPatName (LamMk True) lrdr
- tellTPB (tpb_exp_tv name)
+ tellTPB (tpBuilderExplicitTV name)
pure (L l name)
else do -- usage
@@ -1413,7 +1374,7 @@ rn_ty_pat (HsKindSig an ty ki) = do
~(HsPS hsps ki') <- liftRnWithCont $
rnHsPatSigKind AlwaysBind ctxt (HsPS noAnn ki)
ty' <- rn_lty_pat ty
- tellTPB (tpb_hsps hsps)
+ tellTPB (tpBuilderPatSig hsps)
pure (HsKindSig an ty' ki')
rn_ty_pat (HsSpliceTy _ splice) = do
diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs
index 614248803949..c83e746fa7aa 100644
--- a/compiler/GHC/Tc/Gen/App.hs
+++ b/compiler/GHC/Tc/Gen/App.hs
@@ -56,7 +56,6 @@ import GHC.Types.Name.Env
import GHC.Types.Name.Reader
import GHC.Types.SrcLoc
import GHC.Types.Var.Env ( emptyTidyEnv, mkInScopeSet )
-import GHC.Types.SourceText
import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
@@ -899,18 +898,12 @@ expr_to_type earg =
where
unwrap_op_tv (L _ (HsTyVar _ _ op_id)) = return op_id
unwrap_op_tv _ = failWith $ TcRnIllformedTypeArgument (L l e)
- go (L l e@(HsOverLit _ lit)) =
- do { tylit <- case ol_val lit of
- HsIntegral n -> return $ HsNumTy NoSourceText (il_value n)
- HsIsString _ s -> return $ HsStrTy NoSourceText s
- HsFractional _ -> failWith $ TcRnIllformedTypeArgument (L l e)
- ; return (L l (HsTyLit noExtField tylit)) }
- go (L l e@(HsLit _ lit)) =
- do { tylit <- case lit of
- HsChar _ c -> return $ HsCharTy NoSourceText c
- HsString _ s -> return $ HsStrTy NoSourceText s
- _ -> failWith $ TcRnIllformedTypeArgument (L l e)
- ; return (L l (HsTyLit noExtField tylit)) }
+ go (L l (HsOverLit _ lit))
+ | Just tylit <- tyLitFromOverloadedLit (ol_val lit)
+ = return (L l (HsTyLit noExtField tylit))
+ go (L l (HsLit _ lit))
+ | Just tylit <- tyLitFromLit lit
+ = return (L l (HsTyLit noExtField tylit))
go (L l (ExplicitTuple _ tup_args boxity))
-- Neither unboxed tuples (#e1,e2#) nor tuple sections (e1,,e2,) can be promoted
| isBoxed boxity
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index 27791327820f..346bcc950cc0 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -37,8 +37,6 @@ import GHC.Hs
import GHC.Hs.Syn.Type
import GHC.Tc.Gen.HsType
-import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) )
-
import GHC.Tc.Gen.Bind( chooseInferredQuantifiers )
import GHC.Tc.Gen.Sig( tcUserTypeSig, tcInstSig )
import GHC.Tc.TyCl.PatSyn( patSynBuilderOcc )
@@ -78,15 +76,14 @@ import GHC.Builtin.Types( multiplicityTy )
import GHC.Builtin.Names
import GHC.Builtin.Names.TH( liftStringName, liftName )
-import GHC.Driver.Env
import GHC.Driver.DynFlags
import GHC.Utils.Misc
import GHC.Utils.Outputable as Outputable
import GHC.Utils.Panic
-import qualified GHC.LanguageExtensions as LangExt
import GHC.Data.Maybe
import Control.Monad
+import GHC.Rename.Unbound (WhatLooking(WL_Anything))
@@ -1164,46 +1161,11 @@ tc_infer_id id_name
AGlobal (AConLike (RealDataCon con)) -> tcInferDataCon con
AGlobal (AConLike (PatSynCon ps)) -> tcInferPatSyn id_name ps
- (tcTyThingTyCon_maybe -> Just tc) -> fail_tycon tc -- TyCon or TcTyCon
- ATyVar name _ -> fail_tyvar name
+ (tcTyThingTyCon_maybe -> Just tc) -> failIllegalTyCon WL_Anything tc -- TyCon or TcTyCon
+ ATyVar name _ -> failIllegalTyVal name
_ -> failWithTc $ TcRnExpectedValueId thing }
where
- fail_tycon tc = do
- gre <- getGlobalRdrEnv
- let nm = tyConName tc
- pprov = case lookupGRE_Name gre nm of
- Just gre -> nest 2 (pprNameProvenance gre)
- Nothing -> empty
- err | isClassTyCon tc = ClassTE
- | otherwise = TyConTE
- fail_with_msg dataName nm pprov err
-
- fail_tyvar nm =
- let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm))
- in fail_with_msg varName nm pprov TyVarTE
-
- fail_with_msg whatName nm pprov err = do
- (import_errs, hints) <- get_suggestions whatName
- unit_state <- hsc_units <$> getTopEnv
- let
- -- TODO: unfortunate to have to convert to SDoc here.
- -- This should go away once we refactor ErrInfo.
- hint_msg = vcat $ map ppr hints
- import_err_msg = vcat $ map ppr import_errs
- info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg }
- failWithTc $ TcRnMessageWithInfo unit_state (
- mkDetailedMessage info (TcRnIllegalTermLevelUse nm err))
-
- get_suggestions ns = do
- required_type_arguments <- xoptM LangExt.RequiredTypeArguments
- if required_type_arguments && isVarNameSpace ns
- then return ([], []) -- See Note [Suppress hints with RequiredTypeArguments]
- else do
- let occ = mkOccNameFS ns (occNameFS (occName id_name))
- lcl_env <- getLocalRdrEnv
- unknownNameSuggestions lcl_env WL_Anything (mkRdrUnqual occ)
-
return_id id = return (HsVar noExtField (noLocA id), idType id)
{- Note [Suppress hints with RequiredTypeArguments]
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index 69684d63f1cb..fdf1de02d0da 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -73,7 +73,10 @@ module GHC.Tc.Gen.HsType (
HoleMode(..),
-- Error messages
- funAppCtxt, addTyConFlavCtxt
+ funAppCtxt, addTyConFlavCtxt,
+
+ -- Utils
+ tyLitFromLit, tyLitFromOverloadedLit,
) where
import GHC.Prelude hiding ( head, init, last, tail )
@@ -140,6 +143,7 @@ import qualified Data.List.NonEmpty as NE
import Data.List ( mapAccumL )
import Control.Monad
import Data.Tuple( swap )
+import GHC.Types.SourceText
{-
----------------------------
@@ -4689,3 +4693,22 @@ addTyConFlavCtxt :: Name -> TyConFlavour tc -> TcM a -> TcM a
addTyConFlavCtxt name flav
= addErrCtxt $ hsep [ text "In the", ppr flav
, text "declaration for", quotes (ppr name) ]
+
+{-
+************************************************************************
+* *
+ Utils for constructing TyLit
+* *
+************************************************************************
+-}
+
+
+tyLitFromLit :: HsLit GhcRn -> Maybe (HsTyLit GhcRn)
+tyLitFromLit (HsString x str) = Just (HsStrTy x str)
+tyLitFromLit (HsChar x char) = Just (HsCharTy x char)
+tyLitFromLit _ = Nothing
+
+tyLitFromOverloadedLit :: OverLitVal -> Maybe (HsTyLit GhcRn)
+tyLitFromOverloadedLit (HsIntegral n) = Just $ HsNumTy NoSourceText (il_value n)
+tyLitFromOverloadedLit (HsIsString _ s) = Just $ HsStrTy NoSourceText s
+tyLitFromOverloadedLit HsFractional{} = Nothing
diff --git a/compiler/GHC/Tc/Gen/Pat.hs b/compiler/GHC/Tc/Gen/Pat.hs
index 3b6ddc0d8a40..f7a7771f50a5 100644
--- a/compiler/GHC/Tc/Gen/Pat.hs
+++ b/compiler/GHC/Tc/Gen/Pat.hs
@@ -78,6 +78,8 @@ import Language.Haskell.Syntax.Basic (FieldLabelString(..))
import Data.List( partition )
import Data.Maybe (isJust)
+import Control.Monad.Trans.Writer.CPS
+import Control.Monad.Trans.Class
{-
************************************************************************
@@ -504,56 +506,109 @@ tc_forall_pat tv _ pat thing_inside
; let pat' = XPat $ ExpansionPat pat (EmbTyPat arg_ty tp)
; return (pat', result) }
+
-- Convert a Pat into the equivalent HsTyPat.
-- See `expr_to_type` (GHC.Tc.Gen.App) for the HsExpr counterpart.
-- The `TcM` monad is only used to fail on ill-formed type patterns.
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)
+pat_to_type_pat pat = do
+ (ty, x) <- runWriterT (pat_to_type pat)
+ pure (HsTP (buildHsTyPatRn x) ty)
+
+pat_to_type :: Pat GhcRn -> WriterT HsTyPatRnBuilder TcM (LHsType GhcRn)
+pat_to_type (EmbTyPat _ (HsTP x t)) =
+ do { tell (builderFromHsTyPatRn x)
+ ; return t }
+pat_to_type (VarPat _ lname) =
+ do { tell (tpBuilderExplicitTV (unLoc lname))
+ ; return b }
where b = noLocA (HsTyVar noAnn NotPromoted lname)
- x = HsTPRn { hstp_nwcs = []
- , hstp_imp_tvs = []
- , hstp_exp_tvs = [unLoc lname] }
-pat_to_type_pat (WildPat _) = return (HsTP x b)
+pat_to_type (WildPat _) = return b
where b = noLocA (HsWildCardTy noExtField)
- x = HsTPRn { hstp_nwcs = []
- , hstp_imp_tvs = []
- , hstp_exp_tvs = [] }
-pat_to_type_pat (SigPat _ pat sig_ty)
- = do { HsTP x_hstp t <- pat_to_type_pat (unLoc pat)
+pat_to_type (SigPat _ pat sig_ty)
+ = do { t <- pat_to_type (unLoc pat)
; let { !(HsPS x_hsps k) = sig_ty
- ; x = append_hstp_hsps x_hstp x_hsps
; b = noLocA (HsKindSig noAnn t k) }
- ; return (HsTP x b) }
- where
- -- Quadratic for nested signatures ((p :: t1) :: t2)
- -- but those are unlikely to occur in practice.
- append_hstp_hsps :: HsTyPatRn -> HsPSRn -> HsTyPatRn
- append_hstp_hsps t p
- = HsTPRn { hstp_nwcs = hstp_nwcs t ++ hsps_nwcs p
- , hstp_imp_tvs = hstp_imp_tvs t ++ hsps_imp_tvs p
- , hstp_exp_tvs = hstp_exp_tvs t }
-pat_to_type_pat (ParPat _ pat)
- = do { HsTP x t <- pat_to_type_pat (unLoc pat)
- ; return (HsTP x (noLocA (HsParTy noAnn t))) }
-pat_to_type_pat (SplicePat (HsUntypedSpliceTop mod_finalizers pat) splice) = do
- { HsTP x t <- pat_to_type_pat pat
- ; return (HsTP x (noLocA (HsSpliceTy (HsUntypedSpliceTop mod_finalizers t) splice))) }
-pat_to_type_pat pat =
- -- There are other cases to handle (ConPat, ListPat, TuplePat, etc), but these
- -- would always be rejected by the unification in `tcHsTyPat`, so it's fine to
- -- skip them here. This won't continue to be the case when visible forall is
- -- permitted in data constructors:
- --
- -- data T a where { Typed :: forall a -> a -> T a }
- -- g :: T Int -> Int
- -- g (Typed Int x) = x -- Note the `Int` type pattern
- --
- -- See ticket #18389. When this feature lands, it would be best to extend
- -- `pat_to_type_pat` to handle as many pattern forms as possible.
+ ; tell (tpBuilderPatSig x_hsps)
+ ; return b }
+pat_to_type (ParPat _ pat)
+ = do { t <- pat_to_type (unLoc pat)
+ ; return (noLocA (HsParTy noAnn t)) }
+pat_to_type (SplicePat (HsUntypedSpliceTop mod_finalizers pat) splice) = do
+ { t <- pat_to_type pat
+ ; return (noLocA (HsSpliceTy (HsUntypedSpliceTop mod_finalizers t) splice)) }
+
+pat_to_type (TuplePat _ pats Boxed)
+ = do { tys <- traverse (pat_to_type . unLoc) pats
+ ; let t = noLocA (HsExplicitTupleTy noExtField tys)
+ ; pure t }
+pat_to_type (ListPat _ pats)
+ = do { tys <- traverse (pat_to_type . unLoc) pats
+ ; let t = noLocA (HsExplicitListTy NoExtField NotPromoted tys)
+ ; pure t }
+
+pat_to_type (LitPat _ lit)
+ | Just ty_lit <- tyLitFromLit lit
+ = do { let t = noLocA (HsTyLit noExtField ty_lit)
+ ; pure t }
+pat_to_type (NPat _ (L _ lit) _ _)
+ | Just ty_lit <- tyLitFromOverloadedLit (ol_val lit)
+ = do { let t = noLocA (HsTyLit noExtField ty_lit)
+ ; pure t}
+
+pat_to_type (ConPat _ lname (InfixCon left right))
+ = do { lty <- pat_to_type (unLoc left)
+ ; rty <- pat_to_type (unLoc right)
+ ; let { t = noLocA (HsOpTy noAnn NotPromoted lty lname rty)}
+ ; pure t }
+pat_to_type (ConPat _ lname (PrefixCon invis_args vis_args))
+ = do { let { appHead = noLocA (HsTyVar noAnn NotPromoted lname)}
+ ; ty_invis <- foldM apply_invis_arg appHead invis_args
+ ; tys_vis <- traverse (pat_to_type . unLoc) vis_args
+ ; let t = foldl' mkHsAppTy ty_invis tys_vis
+ ; pure t }
+ where
+ apply_invis_arg :: LHsType GhcRn -> HsConPatTyArg GhcRn -> WriterT HsTyPatRnBuilder TcM (LHsType GhcRn)
+ apply_invis_arg !t (HsConPatTyArg _ (HsTP argx arg))
+ = do { tell (builderFromHsTyPatRn argx)
+ ; pure (mkHsAppKindTy noExtField t arg)}
+
+pat_to_type pat = lift $
failWith $ TcRnIllformedTypePattern pat
-- This failure is the only use of the TcM monad in `pat_to_type_pat`
+{-
+Note [Pattern to type (P2T) conversion]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this:
+
+ data T a b where
+ MkT :: forall a. forall b -> a -> b -> T a b
+ -- NB: `a` is invisible, but `b` is required
+
+ f (MkT @[Int] (Maybe Bool) x y) = ...
+
+The second type argument of `MkT` is Required, so we write it without
+an `@` sign in the pattern match. So the (Maybe Bool) will be
+ * parsed and renamed as a term pattern
+ * converted to a type when typechecking the pattern-match: the P2T conversion
+
+This is the only place we have P2T. In type-lambdas, the "pattern" is always a
+type variable:
+
+ f :: forall a -> a -> blah
+ f b (x::b) = ...
+
+The `b` argument must be a simple variable; we can't pattern-match on types.
+
+The function `pat_to_type` does the P2T conversion:
+ pat_to_type :: Pat GhcRn -> WriterT HsTyPatRnBuilder TcM (LHsType GhcRn)
+
+It is arranged as a writer monad, where the `HsTyPatRnBuilder` accumulates the
+binders bound by the type. (We could discover these binders by a subsequent
+traversal, that would mean writing another traversal.)
+-}
+
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)
diff --git a/compiler/GHC/Tc/Utils/Env.hs b/compiler/GHC/Tc/Utils/Env.hs
index 6ddcb2cfd006..ca0704560545 100644
--- a/compiler/GHC/Tc/Utils/Env.hs
+++ b/compiler/GHC/Tc/Utils/Env.hs
@@ -28,6 +28,7 @@ module GHC.Tc.Utils.Env(
tcLookupLocatedClass, tcLookupAxiom,
lookupGlobal, lookupGlobal_maybe,
addTypecheckedBinds,
+ failIllegalTyCon, failIllegalTyVal,
-- Local environment
tcExtendKindEnv, tcExtendKindEnvList,
@@ -137,6 +138,7 @@ import Data.List ( intercalate )
import Control.Monad
import GHC.Iface.Errors.Types
import GHC.Types.Error
+import GHC.Rename.Unbound ( unknownNameSuggestions, WhatLooking(..) )
{- *********************************************************************
* *
@@ -278,6 +280,7 @@ tcLookupConLike name = do
thing <- tcLookupGlobal name
case thing of
AConLike cl -> return cl
+ ATyCon tc -> failIllegalTyCon WL_Constructor tc
_ -> wrongThingErr WrongThingConLike (AGlobal thing) name
tcLookupRecSelParent :: HsRecUpdParent GhcRn -> TcM RecSelParent
@@ -349,6 +352,45 @@ tcGetInstEnvs = do { eps <- getEps
instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
lookupThing = tcLookupGlobal
+-- Illegal term-level use of type things
+failIllegalTyCon :: WhatLooking -> TyCon -> TcM a
+failIllegalTyVal :: Name -> TcM a
+(failIllegalTyCon, failIllegalTyVal) = (fail_tycon, fail_tyvar)
+ where
+ fail_tycon what_looking tc = do
+ gre <- getGlobalRdrEnv
+ let nm = tyConName tc
+ pprov = case lookupGRE_Name gre nm of
+ Just gre -> nest 2 (pprNameProvenance gre)
+ Nothing -> empty
+ err | isClassTyCon tc = ClassTE
+ | otherwise = TyConTE
+ fail_with_msg what_looking dataName nm pprov err
+
+ fail_tyvar nm =
+ let pprov = nest 2 (text "bound at" <+> ppr (getSrcLoc nm))
+ in fail_with_msg WL_Anything varName nm pprov TyVarTE
+
+ fail_with_msg what_looking whatName nm pprov err = do
+ (import_errs, hints) <- get_suggestions what_looking whatName nm
+ unit_state <- hsc_units <$> getTopEnv
+ let
+ -- TODO: unfortunate to have to convert to SDoc here.
+ -- This should go away once we refactor ErrInfo.
+ hint_msg = vcat $ map ppr hints
+ import_err_msg = vcat $ map ppr import_errs
+ info = ErrInfo { errInfoContext = pprov, errInfoSupplementary = import_err_msg $$ hint_msg }
+ failWithTc $ TcRnMessageWithInfo unit_state (
+ mkDetailedMessage info (TcRnIllegalTermLevelUse nm err))
+
+ get_suggestions what_looking ns nm = do
+ required_type_arguments <- xoptM LangExt.RequiredTypeArguments
+ if required_type_arguments && isVarNameSpace ns
+ then return ([], []) -- See Note [Suppress hints with RequiredTypeArguments]
+ else do
+ let occ = mkOccNameFS ns (occNameFS (occName nm))
+ lcl_env <- getLocalRdrEnv
+ unknownNameSuggestions lcl_env what_looking (mkRdrUnqual occ)
{-
************************************************************************
* *
diff --git a/testsuite/tests/rename/should_fail/T19843c.stderr b/testsuite/tests/rename/should_fail/T19843c.stderr
index 28f58cd6f1a8..1b5c2bff4a4c 100644
--- a/testsuite/tests/rename/should_fail/T19843c.stderr
+++ b/testsuite/tests/rename/should_fail/T19843c.stderr
@@ -1,4 +1,7 @@
+T19843c.hs:6:6: error: [GHC-01928]
+ • Illegal term-level use of the type constructor ‘Map’
+ • imported from ‘Data.Map’ at T19843c.hs:3:1-22
+ (and originally defined in ‘Data.Map.Internal’)
+ • In the pattern: Map k v
+ In an equation for ‘foo’: foo (Map k v) = undefined
-T19843c.hs:6:6: error: [GHC-76037]
- Not in scope: data constructor ‘Map.Map’
- NB: the module ‘Data.Map’ does not export ‘Map’.
diff --git a/testsuite/tests/type-data/should_fail/TDPattern.stderr b/testsuite/tests/type-data/should_fail/TDPattern.stderr
index 3fecbb1f6b0c..5bd87687701a 100644
--- a/testsuite/tests/type-data/should_fail/TDPattern.stderr
+++ b/testsuite/tests/type-data/should_fail/TDPattern.stderr
@@ -1,3 +1,6 @@
+TDPattern.hs:7:3: error: [GHC-01928]
+ • Illegal term-level use of the type constructor ‘Zero’
+ • defined at TDPattern.hs:4:17
+ • In the pattern: Zero
+ In an equation for ‘f’: f Zero = 0
-TDPattern.hs:7:3: [GHC-76037]
- Not in scope: data constructor ‘Zero’
diff --git a/testsuite/tests/typecheck/should_compile/T23739a.hs b/testsuite/tests/typecheck/should_compile/T23739a.hs
new file mode 100644
index 000000000000..cfdade370352
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T23739a.hs
@@ -0,0 +1,65 @@
+{-# LANGUAGE TypeAbstractions,
+ ExplicitNamespaces,
+ RequiredTypeArguments,
+ DataKinds,
+ NoListTuplePuns,
+ OverloadedStrings #-}
+
+module T23739a where
+
+import Data.Tuple.Experimental
+import GHC.TypeLits
+
+{-
+This code aims to test pattern-to-type transformation
+(See Note [Pattern to type (P2T) conversion] in GHC.Tc.Gen.Pat)
+
+However it relies on a questionable feature, that allows us to have
+equality constraint in scope of type pattern checking. The test
+doesn't establish such behavior, it just abuses it to examine P2T
+transformation.
+
+In the happy future with `forall->` in GADTs we should
+rewrite this test using it.
+-}
+
+f1 :: forall a -> a ~ (Int, Bool) => Unit
+f1 (b,c) = ()
+
+f2 :: forall a -> a ~ (Int : Bool : Double : []) => Unit
+f2 [a,b,c] = ()
+
+f3 :: forall a -> a ~ [Int, Bool, Double] => Unit
+f3 [a,b,c] = ()
+
+f4 :: forall a -> a ~ [Int, Bool, Double] => Unit
+f4 (a : b : c : []) = ()
+
+f5 :: forall a -> a ~ "blah" => Unit
+f5 "blah" = ()
+
+f6 :: forall a -> a ~ 'c' => Unit
+f6 'c' = ()
+
+f7 :: forall a -> a ~ UnconsSymbol "blah" => Unit
+f7 (Just ('b', "lah")) = ()
+
+f8 :: forall a -> Unit
+f8 _ = ()
+
+f9 :: forall a -> a ~ 42 => Unit
+f9 42 = ()
+
+f10 :: forall a -> a ~ () => Unit
+f10 () = ()
+
+f11 :: forall a -> a ~ Int => Unit
+f11 Int = ()
+
+f12 :: forall a -> a ~ (Left @Bool @(Maybe b) True) => Unit
+f12 (Left @Bool @(Maybe a) True) = ()
+
+data Tup a = MkTup a a
+
+f13 :: forall a -> a ~ (Int, MkTup 'f' 'g', 42, True, [1,2,3,4,5], (), "blah", "wombat", 'd', UnconsSymbol "corner") => Unit
+f13 (Int, 'f' `MkTup` 'g', 42, True, 1 : 2 : 3 : [4,5], () ,"blah", x, 'd', Just ('c', "orner")) = ()
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index 2b6d2108041d..0bd731ca9f2a 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -915,3 +915,4 @@ test('WarnDefaultedExceptionContext', normal, compile, ['-Wdefaulted-exception-c
test('T24470b', normal, compile, [''])
test('T24566', [], makefile_test, [])
test('T23764', normal, compile, [''])
+test('T23739a', normal, compile, [''])
diff --git a/testsuite/tests/typecheck/should_fail/T23739b.hs b/testsuite/tests/typecheck/should_fail/T23739b.hs
new file mode 100644
index 000000000000..50be90535f08
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T23739b.hs
@@ -0,0 +1,14 @@
+
+module T23739b where
+
+import Data.Tuple.Experimental
+import GHC.TypeLits
+
+g1 :: Int -> Unit
+g1 Int = ()
+
+g2 :: Int
+g2 = Int{}
+
+g3 :: Int
+g3 = Int
diff --git a/testsuite/tests/typecheck/should_fail/T23739b.stderr b/testsuite/tests/typecheck/should_fail/T23739b.stderr
new file mode 100644
index 000000000000..0591016b8e6c
--- /dev/null
+++ b/testsuite/tests/typecheck/should_fail/T23739b.stderr
@@ -0,0 +1,21 @@
+T23739b.hs:8:4: error: [GHC-01928]
+ • Illegal term-level use of the type constructor ‘Int’
+ • imported from ‘Prelude’ at T23739b.hs:2:8-14
+ (and originally defined in ‘GHC.Types’)
+ • In the pattern: Int
+ In an equation for ‘g1’: g1 Int = ()
+
+T23739b.hs:11:6: error: [GHC-01928]
+ • Illegal term-level use of the type constructor ‘Int’
+ • imported from ‘Prelude’ at T23739b.hs:2:8-14
+ (and originally defined in ‘GHC.Types’)
+ • In the expression: Int {}
+ In an equation for ‘g2’: g2 = Int {}
+
+T23739b.hs:14:6: error: [GHC-01928]
+ • Illegal term-level use of the type constructor ‘Int’
+ • imported from ‘Prelude’ at T23739b.hs:2:8-14
+ (and originally defined in ‘GHC.Types’)
+ • In the expression: Int
+ In an equation for ‘g3’: g3 = Int
+
diff --git a/testsuite/tests/typecheck/should_fail/all.T b/testsuite/tests/typecheck/should_fail/all.T
index c052a45b527c..eedbc5c23018 100644
--- a/testsuite/tests/typecheck/should_fail/all.T
+++ b/testsuite/tests/typecheck/should_fail/all.T
@@ -725,4 +725,4 @@ test('T17594g', normal, compile_fail, [''])
test('T24470a', normal, compile_fail, [''])
test('T24553', normal, compile_fail, [''])
-
+test('T23739b', normal, compile_fail, [''])
--
GitLab