[Git][ghc/ghc][wip/sand-witch/improve-pat-to-ty] Improve pattern to type pattern transformation (23739)

Andrei Borzenkov (@sand-witch) gitlab at gitlab.haskell.org
Wed May 8 12:08:53 UTC 2024



Andrei Borzenkov pushed to branch wip/sand-witch/improve-pat-to-ty at Glasgow Haskell Compiler / GHC


Commits:
cd1f4663 by Andrei Borzenkov at 2024-05-08T16:08:33+04:00
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.

- - - - -


15 changed files:

- compiler/GHC/Hs/Type.hs
- compiler/GHC/Rename/Env.hs
- compiler/GHC/Rename/Pat.hs
- compiler/GHC/Tc/Gen/App.hs
- compiler/GHC/Tc/Gen/Head.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Utils/Env.hs
- testsuite/tests/rename/should_fail/T19843c.stderr
- testsuite/tests/type-data/should_fail/TDPattern.stderr
- + testsuite/tests/typecheck/should_compile/T23739a.hs
- testsuite/tests/typecheck/should_compile/all.T
- + testsuite/tests/typecheck/should_fail/T23739b.hs
- + testsuite/tests/typecheck/should_fail/T23739b.stderr
- testsuite/tests/typecheck/should_fail/all.T


Changes:

=====================================
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
 


=====================================
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


=====================================
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


=====================================
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


=====================================
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]


=====================================
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


=====================================
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)


=====================================
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)
 {-
 ************************************************************************
 *                                                                      *


=====================================
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’.


=====================================
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’


=====================================
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")) = ()


=====================================
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, [''])


=====================================
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


=====================================
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
+


=====================================
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, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cd1f46638626f18ce39cd157640ad2e37dbb9102

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/cd1f46638626f18ce39cd157640ad2e37dbb9102
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/20240508/9dd533b0/attachment-0001.html>


More information about the ghc-commits mailing list