Type patterns (#22478, #18986)

Improved name resolution and type checking of type patterns in constructors:

1. HsTyPat: a new dedicated data type that represents type patterns in
   HsConPatDetails instead of reusing HsPatSigType

2. rnHsTyPat: a new function that renames a type
   pattern and collects its binders into three groups:
    - explicitly bound type variables, excluding locally bound
      variables
    - implicitly bound type variables from kind signatures
      (only if ScopedTypeVariables are enabled)
    - named wildcards (only from kind signatures)
2a. rnHsPatSigTypeBindingVars: removed in favour of rnHsTyPat
2b. rnImplcitTvBndrs: removed because no longer needed

3. collect_pat: updated to collect type variable binders from type patterns
   (this means that types and terms use the same infrastructure to detect
   conflicting bindings, unused variables and name shadowing)
3a. CollVarTyVarBinders: a new CollectFlag constructor that enables
    collection of type variables

4. tcHsTyPat: a new function that typechecks type patterns, capable of
   handling polymorphic kinds.
   See Note [Type patterns: binders and unifiers]

Examples of code that is now accepted:

   f = \(P @A) -> \(P @A) -> ...  -- triggers -Wname-shadowing

   g :: forall a. Proxy a -> ...
   g (P @A) = ...                 -- also triggers -Wname-shadowing

   h (P @($(TH.varT (TH.mkName "t")))) = ...
                                  -- t is bound at splice time

   j (P @(a :: (x,x))) = ...      -- (x,x) is no longer rejected

   data T where
     MkT :: forall (f :: forall k. k -> Type).
       f Int -> f Maybe -> T
   k :: T -> ()
   k (MkT @f (x :: f Int) (y :: f Maybe)) = ()
                                  -- f :: forall k. k -> Type

Examples of code that is rejected with better error messages:

  f (Left @A @A _) = ...
  -- new message:
  --     • Conflicting definitions for ‘a’
  --       Bound at: Test.hs:1:11
  --                 Test.hs:1:14

Examples of code that is now rejected:

  {-# OPTIONS_GHC -Werror=unused-matches #-}
  f (P @A) = ()
  -- Defined but not used: type variable ‘a’

compiler/GHC/Hs/Decls.hs

@@ -49,7 +49,7 @@ module GHC.Hs.Decls (
   TyFamDefltDecl, LTyFamDefltDecl,
   DataFamInstDecl(..), LDataFamInstDecl,
   pprDataFamInstFlavour, pprTyFamInstDecl, pprHsFamInstLHS,
-  FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsTyPats,
+  FamEqn(..), TyFamInstEqn, LTyFamInstEqn, HsFamEqnPats,
   LClsInstDecl, ClsInstDecl(..),
 
   -- ** Standalone deriving declarations
@@ -867,7 +867,7 @@ pprDataFamInstFlavour DataFamInstDecl
 pprHsFamInstLHS :: (OutputableBndrId p)
    => IdP (GhcPass p)
    -> HsOuterFamEqnTyVarBndrs (GhcPass p)
-   -> HsTyPats (GhcPass p)
+   -> HsFamEqnPats (GhcPass p)
    -> LexicalFixity
    -> Maybe (LHsContext (GhcPass p))
    -> SDoc

compiler/GHC/Hs/Instances.hs

@@ -488,6 +488,11 @@ deriving instance Data (HsPatSigType GhcPs)
 deriving instance Data (HsPatSigType GhcRn)
 deriving instance Data (HsPatSigType GhcTc)
 
+-- deriving instance (DataIdLR p p) => Data (HsTyPat p)
+deriving instance Data (HsTyPat GhcPs)
+deriving instance Data (HsTyPat GhcRn)
+deriving instance Data (HsTyPat GhcTc)
+
 -- deriving instance (DataIdLR p p) => Data (HsForAllTelescope p)
 deriving instance Data (HsForAllTelescope GhcPs)
 deriving instance Data (HsForAllTelescope GhcRn)

compiler/GHC/Hs/Pat.hs

@@ -28,7 +28,7 @@ module GHC.Hs.Pat (
         HsPatExpansion(..),
         XXPatGhcTc(..),
 
-        HsConPatDetails, hsConPatArgs,
+        HsConPatDetails, hsConPatArgs, hsConPatTyArgs,
         HsConPatTyArg(..),
         HsRecFields(..), HsFieldBind(..), LHsFieldBind,
         HsRecField, LHsRecField,
@@ -260,7 +260,7 @@ hsRecUpdFieldOcc = fmap unambiguousFieldOcc . hfbLHS
 ************************************************************************
 -}
 
-instance Outputable (HsPatSigType p) => Outputable (HsConPatTyArg p) where
+instance Outputable (HsTyPat p) => Outputable (HsConPatTyArg p) where
   ppr (HsConPatTyArg _ ty) = char '@' <> ppr ty
 
 instance (Outputable arg, Outputable (XRec p (HsRecField p arg)), XRec p RecFieldsDotDot ~ Located RecFieldsDotDot)

compiler/GHC/Hs/Type.hs

@@ -37,6 +37,7 @@ module GHC.Hs.Type (
         HsOuterTyVarBndrs(..), HsOuterFamEqnTyVarBndrs, HsOuterSigTyVarBndrs,
         HsWildCardBndrs(..),
         HsPatSigType(..), HsPSRn(..),
+        HsTyPat(..), HsTyPatRn(..),
         HsSigType(..), LHsSigType, LHsSigWcType, LHsWcType,
         HsTupleSort(..),
         HsContext, LHsContext, fromMaybeContext,
@@ -68,14 +69,15 @@ module GHC.Hs.Type (
         hsOuterTyVarNames, hsOuterExplicitBndrs, mapHsOuterImplicit,
         mkHsOuterImplicit, mkHsOuterExplicit,
         mkHsImplicitSigType, mkHsExplicitSigType,
-        mkHsWildCardBndrs, mkHsPatSigType,
+        mkHsWildCardBndrs, mkHsPatSigType, mkHsTyPat,
         mkEmptyWildCardBndrs,
         mkHsForAllVisTele, mkHsForAllInvisTele,
         mkHsQTvs, hsQTvExplicit, emptyLHsQTvs,
         isHsKindedTyVar, hsTvbAllKinded,
         hsScopedTvs, hsScopedKvs, hsWcScopedTvs, dropWildCards,
         hsTyVarName, hsAllLTyVarNames, hsLTyVarLocNames,
-        hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsExplicitLTyVarNames,
+        hsLTyVarName, hsLTyVarNames, hsForAllTelescopeNames,
+        hsLTyVarLocName, hsExplicitLTyVarNames,
         splitLHsInstDeclTy, getLHsInstDeclHead, getLHsInstDeclClass_maybe,
         splitLHsPatSynTy,
         splitLHsForAllTyInvis, splitLHsForAllTyInvis_KP, splitLHsQualTy,
@@ -218,6 +220,10 @@ type instance XHsPS GhcPs = EpAnnCO
 type instance XHsPS GhcRn = HsPSRn
 type instance XHsPS GhcTc = HsPSRn
 
+type instance XHsTP GhcPs = EpAnnCO
+type instance XHsTP GhcRn = HsTyPatRn
+type instance XHsTP GhcTc = DataConCantHappen
+
 -- | The extension field for 'HsPatSigType', which is only used in the
 -- renamer onwards. See @Note [Pattern signature binders and scoping]@.
 data HsPSRn = HsPSRn
@@ -226,7 +232,22 @@ data HsPSRn = HsPSRn
   }
   deriving Data
 
+-- HsTyPatRn is the extension field for `HsTyPat`, after renaming
+-- E.g. pattern K @(Maybe (_x, a, b::Proxy k)
+-- In the type pattern @(Maybe ...):
+--    '_x' is a named wildcard
+--    'a'  is explicitly bound
+--    'k'  is implicitly bound
+-- See Note [Implicit and explicit type variable binders] in GHC.Rename.Pat
+data HsTyPatRn = HsTPRn
+  { hstp_nwcs    :: [Name] -- ^ Wildcard names
+  , hstp_imp_tvs :: [Name] -- ^ Implicitly bound variable names
+  , hstp_exp_tvs :: [Name] -- ^ Explicitly bound variable names
+  }
+  deriving Data
+
 type instance XXHsPatSigType (GhcPass _) = DataConCantHappen
+type instance XXHsTyPat      (GhcPass _) = DataConCantHappen
 
 type instance XHsSig (GhcPass _) = NoExtField
 type instance XXHsSigType (GhcPass _) = DataConCantHappen
@@ -275,6 +296,10 @@ mkHsPatSigType :: EpAnnCO -> LHsType GhcPs -> HsPatSigType GhcPs
 mkHsPatSigType ann x = HsPS { hsps_ext  = ann
                             , hsps_body = x }
 
+mkHsTyPat :: EpAnnCO -> LHsType GhcPs -> HsTyPat GhcPs
+mkHsTyPat ann x = HsTP { hstp_ext  = ann
+                       , hstp_body = x }
+
 mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing
 mkEmptyWildCardBndrs x = HsWC { hswc_body = x
                               , hswc_ext  = [] }
@@ -449,6 +474,10 @@ hsLTyVarName = hsTyVarName . unLoc
 hsLTyVarNames :: [LHsTyVarBndr flag (GhcPass p)] -> [IdP (GhcPass p)]
 hsLTyVarNames = map hsLTyVarName
 
+hsForAllTelescopeNames :: HsForAllTelescope (GhcPass p) -> [IdP (GhcPass p)]
+hsForAllTelescopeNames (HsForAllVis _ bndrs) = hsLTyVarNames bndrs
+hsForAllTelescopeNames (HsForAllInvis _ bndrs) = hsLTyVarNames bndrs
+
 hsExplicitLTyVarNames :: LHsQTyVars (GhcPass p) -> [IdP (GhcPass p)]
 -- Explicit variables only
 hsExplicitLTyVarNames qtvs = map hsLTyVarName (hsQTvExplicit qtvs)
@@ -1061,6 +1090,11 @@ instance (OutputableBndrId p)
     ppr (HsPS { hsps_body = ty }) = ppr ty
 
 
+instance (OutputableBndrId p)
+       => Outputable (HsTyPat (GhcPass p)) where
+    ppr (HsTP { hstp_body = ty }) = ppr ty
+
+
 instance (OutputableBndrId p)
        => Outputable (HsTyLit (GhcPass p)) where
     ppr = ppr_tylit

compiler/GHC/Hs/Utils.hs

@@ -1184,18 +1184,26 @@ collectPatsBinders flag pats = foldr (collect_lpat flag) [] pats
 
 -------------
 
--- | Indicate if evidence binders have to be collected.
+-- | Indicate if evidence binders and type variable binders have
+--   to be collected.
 --
--- This type is used as a boolean (should we collect evidence binders or not?)
--- but also to pass an evidence that the AST has been typechecked when we do
--- want to collect evidence binders, otherwise these binders are not available.
+-- This type enumerates the modes of collecting bound variables
+--                     | evidence |   type    |   term    |  ghc  |
+--                     | binders  | variables | variables |  pass |
+--                     --------------------------------------------
+-- CollNoDictBinders   |  no      |    no     |    yes    |  any  |
+-- CollWithDictBinders |  yes     |    no     |    yes    | GhcTc |
+-- CollVarTyVarBinders |  no      |    yes    |    yes    | GhcRn |
 --
 -- See Note [Dictionary binders in ConPatOut]
 data CollectFlag p where
     -- | Don't collect evidence binders
     CollNoDictBinders   :: CollectFlag p
     -- | Collect evidence binders
     CollWithDictBinders :: CollectFlag GhcTc
+    -- | Collect variable and type variable binders, but no evidence binders
+    CollVarTyVarBinders :: CollectFlag GhcRn
+
 
 collect_lpat :: forall p. CollectPass p
              => CollectFlag p
@@ -1223,19 +1231,33 @@ collect_pat flag pat bndrs = case pat of
   LitPat _ _            -> bndrs
   NPat {}               -> bndrs
   NPlusKPat _ n _ _ _ _ -> unXRec @p n : bndrs
-  SigPat _ pat _        -> collect_lpat flag pat bndrs
+  SigPat _ pat sig      -> case flag of
+    CollVarTyVarBinders -> collect_lpat flag pat bndrs
+                            ++ collectPatSigBndrs sig
+    _                   -> collect_lpat flag pat bndrs
   XPat ext              -> collectXXPat @p flag ext bndrs
   SplicePat ext _       -> collectXSplicePat @p flag ext bndrs
   -- See Note [Dictionary binders in ConPatOut]
   ConPat {pat_args=ps}  -> case flag of
     CollNoDictBinders   -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)
     CollWithDictBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)
                            ++ collectEvBinders (cpt_binds (pat_con_ext pat))
+    CollVarTyVarBinders -> foldr (collect_lpat flag) bndrs (hsConPatArgs ps)
+                           ++ concatMap collectConPatTyArgBndrs (hsConPatTyArgs ps)
 
 collectEvBinders :: TcEvBinds -> [Id]
 collectEvBinders (EvBinds bs)   = foldr add_ev_bndr [] bs
 collectEvBinders (TcEvBinds {}) = panic "ToDo: collectEvBinders"
 
+collectConPatTyArgBndrs :: HsConPatTyArg GhcRn -> [Name]
+collectConPatTyArgBndrs (HsConPatTyArg _ tp) = collectTyPatBndrs tp
+
+collectTyPatBndrs :: HsTyPat GhcRn -> [Name]
+collectTyPatBndrs (HsTP (HsTPRn nwcs imp_tvs exp_tvs) _) = nwcs ++ imp_tvs ++ exp_tvs
+
+collectPatSigBndrs :: HsPatSigType GhcRn -> [Name]
+collectPatSigBndrs (HsPS (HsPSRn nwcs imp_tvs) _) = nwcs ++ imp_tvs
+
 add_ev_bndr :: EvBind -> [Id] -> [Id]
 add_ev_bndr (EvBind { eb_lhs = b }) bs | isId b    = b:bs
                                        | otherwise = bs

compiler/GHC/HsToCore/Quote.hs

@@ -2095,7 +2095,7 @@ repP (ConPat NoExtField dc details)
  = do { con_str <- lookupLOcc dc
       ; case details of
          PrefixCon tyargs ps -> do { qs <- repLPs ps
-                                   ; let unwrapTyArg (HsConPatTyArg _ t) = unLoc (hsps_body t)
+                                   ; let unwrapTyArg (HsConPatTyArg _ t) = unLoc (hstp_body t)
                                    ; ts <- repListM typeTyConName (repTy . unwrapTyArg) tyargs
                                    ; repPcon con_str ts qs }
          RecCon rec   -> do { fps <- repListM fieldPatTyConName rep_fld (rec_flds rec)

compiler/GHC/Iface/Ext/Ast.hs

@@ -507,11 +507,11 @@ taScopes
   :: Scope
   -> Scope
   -> [HsConPatTyArg (GhcPass a)]
-  -> [TScoped (HsPatSigType (GhcPass a))]
+  -> [TScoped (HsTyPat (GhcPass a))]
 taScopes scope rhsScope xs =
   map (\(RS sc a) -> TS (ResolvedScopes [scope, sc]) (unLoc a)) $
-    listScopes rhsScope (map (\(HsConPatTyArg _ hsps) -> L (getLoc $ hsps_body hsps) hsps) xs)
-  -- We make the HsPatSigType into a Located one by using the location of the underlying LHsType.
+    listScopes rhsScope (map (\(HsConPatTyArg _ hstp) -> L (getLoc $ hstp_body hstp) hstp) xs)
+  -- We make the HsTyPat into a Located one by using the location of the underlying LHsType.
   -- We then strip off the redundant location information afterward, and take the union of the given scope and those to the right when forming the TS.
 
 -- | 'listScopes' specialised to 'TVScoped' things
@@ -1039,7 +1039,7 @@ instance HiePass p => ToHie (PScoped (LocatedA (Pat (GhcPass p)))) where
             ExpansionPat _ p -> [ toHie $ PS rsp scope pscope (L ospan p) ]
     where
       contextify :: a ~ LPat (GhcPass p) => HsConDetails (HsConPatTyArg GhcRn) a (HsRecFields (GhcPass p) a)
-                 -> HsConDetails (TScoped (HsPatSigType GhcRn)) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))
+                 -> HsConDetails (TScoped (HsTyPat GhcRn)) (PScoped a) (RContext (HsRecFields (GhcPass p) (PScoped a)))
       contextify (PrefixCon tyargs args) =
         PrefixCon (taScopes scope argscope tyargs)
                   (patScopes rsp scope pscope args)
@@ -1062,6 +1062,12 @@ instance ToHie (TScoped (HsPatSigType GhcRn)) where
       ]
   -- See Note [Scoping Rules for SigPat]
 
+instance ToHie (TScoped (HsTyPat GhcRn)) where
+  toHie (TS sc (HsTP (HsTPRn wcs imp_tvs exp_tvs) body@(L span _))) = concatM $
+      [ bindingsOnly $ map (C $ TyVarBind (mkScopeA span) sc) (wcs ++ imp_tvs ++ exp_tvs)
+      , toHie body
+      ]
+
 instance ( ToHie (LocatedA (body (GhcPass p)))
          , HiePass p
          , AnnoBody p body

compiler/GHC/Parser/PostProcess.hs

@@ -1838,7 +1838,7 @@ instance DisambECP (PatBuilder GhcPs) where
   mkHsAppTypePV l p at t = do
     cs <- getCommentsFor (locA l)
     let anns = EpAnn (spanAsAnchor (getLocA t)) NoEpAnns cs
-    return $ L l (PatBuilderAppType p at (mkHsPatSigType anns t))
+    return $ L l (PatBuilderAppType p at (mkHsTyPat anns t))
   mkHsIfPV l _ _ _ _ _ _ = addFatalError $ mkPlainErrorMsgEnvelope l PsErrIfThenElseInPat
   mkHsDoPV l _ _ _       = addFatalError $ mkPlainErrorMsgEnvelope l PsErrDoNotationInPat
   mkHsParPV l lpar p rpar   = return $ L (noAnnSrcSpan l) (PatBuilderPar lpar p rpar)

compiler/GHC/Parser/Types.hs

@@ -55,7 +55,7 @@ data PatBuilder p
   = PatBuilderPat (Pat p)
   | PatBuilderPar (LHsToken "(" p) (LocatedA (PatBuilder p)) (LHsToken ")" p)
   | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p))
-  | PatBuilderAppType (LocatedA (PatBuilder p)) (LHsToken "@" p) (HsPatSigType GhcPs)
+  | PatBuilderAppType (LocatedA (PatBuilder p)) (LHsToken "@" p) (HsTyPat GhcPs)
   | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName)
                     (LocatedA (PatBuilder p)) (EpAnn [AddEpAnn])
   | PatBuilderVar (LocatedN RdrName)