wipwip/T17594

10 files changed, 23 insertions, 16 deletions

diff --git a/compiler/GHC/Hs/Expr.hs b/compiler/GHC/Hs/Expr.hs
index 436da995a7..09d22102e2 100644
--- a/compiler/GHC/Hs/Expr.hs
+++ b/compiler/GHC/Hs/Expr.hs
@@ -31,6 +31,7 @@ module GHC.Hs.Expr
 #include "HsVersions.h"
 
 import Language.Haskell.Syntax.Expr
+import Language.Haskell.Syntax.Pat
 
 -- friends:
 import GHC.Prelude
diff --git a/compiler/GHC/Hs/Pat.hs b/compiler/GHC/Hs/Pat.hs
index 6efbfb860e..90048eb4e9 100644
--- a/compiler/GHC/Hs/Pat.hs
+++ b/compiler/GHC/Hs/Pat.hs
@@ -628,7 +628,7 @@ conPatNeedsParens p = go
     go (InfixCon {})       = p >= opPrec -- type args should be empty in this case
     go (RecCon {})         = False
 
--- | @'parenthesizePat' p pat@ checks if @'patNeedsParens' p pat@ is true, and
+-- | @'parenthesizeLPat' p pat@ checks if @'patNeedsParens' p pat@ is true, and
 -- if so, surrounds @pat@ with a 'ParPat'. Otherwise, it simply returns @pat@.
 parenthesizePat :: IsPass p
                 => PprPrec
diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs
index a23c1a1868..3e9f27d044 100644
--- a/compiler/GHC/Hs/Utils.hs
+++ b/compiler/GHC/Hs/Utils.hs
@@ -249,7 +249,8 @@ mkHsAppType e t = addCLocAA t_body e (HsAppType noExtField e paren_wct)
 mkHsAppTypes :: LHsExpr GhcRn -> [LHsWcType GhcRn] -> LHsExpr GhcRn
 mkHsAppTypes = foldl' mkHsAppType
 
-mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField)
+mkHsLam :: (IsPass p, XMG (GhcPass p) (LHsExpr (GhcPass p)) ~ NoExtField,
+            Anno (IdGhcP p) ~ SrcSpanAnnN)
         => [LPat (GhcPass p)]
         -> LHsExpr (GhcPass p)
         -> LHsExpr (GhcPass p)
@@ -1158,7 +1159,6 @@ collectStmtBinders flag = \case
 
 
 ----------------- Patterns --------------------------
-
 collectPatBinders
     :: CollectPass p
     => CollectFlag p
@@ -1173,7 +1173,6 @@ collectPatsBinders
     -> [IdP p]
 collectPatsBinders flag pats = foldr (collect_lpat flag) [] pats
 
-
 -------------
 
 -- | Indicate if evidence binders have to be collected.
diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y
index 356a728b23..d0c27ac25b 100644
--- a/compiler/GHC/Parser.y
+++ b/compiler/GHC/Parser.y
@@ -2778,7 +2778,7 @@ aexp    :: { ECP }
                                    unECP $2 >>= \ $2 ->
                                    mkHsNegAppPV (comb2A $1 $>) $2 [mj AnnMinus $1] }
 
-        | '\\' apat apats '->' exp
+        | '\\' typats apats '->' exp
                    {  ECP $
                       unECP $5 >>= \ $5 ->
                       mkHsLamPV (comb2 $1 (reLoc $>)) (\cs -> mkMatchGroup FromSource
@@ -2786,7 +2786,7 @@ aexp    :: { ECP }
                             [reLocA $ sLLlA $1 $>
                                          $ Match { m_ext = EpAnn (glR $1) [mj AnnLam $1] cs
                                                  , m_ctxt = LambdaExpr
-                                                 , m_pats = $2:$3
+                                                 , m_pats = $3
                                                  , m_grhss = unguardedGRHSs (comb2 $4 (reLoc $5)) $5 (EpAnn (glR $4) (GrhsAnn Nothing (mu AnnRarrow $4)) noCom) }])) }
         | 'let' binds 'in' exp          {  ECP $
                                            unECP $4 >>= \ $4 ->
@@ -3284,6 +3284,13 @@ apats  :: { [LPat GhcPs] }
         : apat apats            { $1 : $2 }
         | {- empty -}           { [] }
 
+typat  :: { LHsTyVarBndr Specificity GhcPs }
+        : PREFIX_AT tv_bndr     { $2 }
+
+typats :: { [LHsTyVarBndr Specificity GhcPs] }
+        : typat typats          { $1 : $2 }
+        | {- empty -}           { [] }
+
 -----------------------------------------------------------------------------
 -- Statement sequences
 
diff --git a/compiler/GHC/Parser/Errors.hs b/compiler/GHC/Parser/Errors.hs
index 83812f7673..e3f7e869da 100644
--- a/compiler/GHC/Parser/Errors.hs
+++ b/compiler/GHC/Parser/Errors.hs
@@ -401,7 +401,6 @@ data Hint
    | SuggestLetInDo
    | SuggestPatternSynonyms
    | SuggestInfixBindMaybeAtPat !RdrName
-   | TypeApplicationsInPatternsOnlyDataCons -- ^ Type applications in patterns are only allowed on data constructors
 
 
 data LexErrKind
diff --git a/compiler/GHC/Parser/Errors/Ppr.hs b/compiler/GHC/Parser/Errors/Ppr.hs
index 7b9f2e64a0..cf8ae06744 100644
--- a/compiler/GHC/Parser/Errors/Ppr.hs
+++ b/compiler/GHC/Parser/Errors/Ppr.hs
@@ -616,8 +616,6 @@ pp_hint = \case
          $$ if opIsAt fun
                then perhaps_as_pat
                else empty
-   TypeApplicationsInPatternsOnlyDataCons ->
-     text "Type applications in patterns are only allowed on data constructors."
 
 perhaps_as_pat :: SDoc
 perhaps_as_pat = text "Perhaps you meant an as-pattern, which must not be surrounded by whitespace"
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 2686bc151b..29deab034a 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -58,6 +58,7 @@ module GHC.Parser.PostProcess (
         checkContext,         -- HsType -> P HsContext
         checkPattern,         -- HsExp -> P HsPat
         checkPattern_hints,
+        checkTyVars,
         checkMonadComp,       -- P (HsStmtContext GhcPs)
         checkValDef,          -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl
         checkValSigLhs,
@@ -1091,10 +1092,7 @@ checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args
       { pat_con_ext = noAnn -- AZ: where should this come from?
       , pat_con = L ln c
       , pat_args = PrefixCon tyargs args
-      }
-  | not (null tyargs) =
-      add_hint TypeApplicationsInPatternsOnlyDataCons $
-      patFail (locA l) (ppr e <+> hsep [text "@" <> ppr t | t <- tyargs])
+    }
   | not (null args) && patIsRec c =
       add_hint SuggestRecursiveDo $
       patFail (locA l) (ppr e)
@@ -1106,6 +1104,9 @@ checkPat loc (L _ (PatBuilderApp f e)) [] args = do
 checkPat loc (L l e) [] [] = do
   p <- checkAPat loc e
   return (L l p)
+checkPat loc e tyargs args
+  | not (null tyargs), (_:tyargs') <- tyargs =
+     checkPat loc e tyargs' args
 checkPat loc e _ _ = patFail (locA loc) (ppr e)
 
 checkAPat :: SrcSpanAnnA -> PatBuilder GhcPs -> PV (Pat GhcPs)
diff --git a/compiler/GHC/Tc/Gen/Arrow.hs b/compiler/GHC/Tc/Gen/Arrow.hs
index 7ab31322c9..a22ad04869 100644
--- a/compiler/GHC/Tc/Gen/Arrow.hs
+++ b/compiler/GHC/Tc/Gen/Arrow.hs
@@ -257,7 +257,6 @@ tc_cmd env
        (cmd_stk, res_ty)
   = addErrCtxt (pprMatchInCtxt match)        $
     do  { (co, arg_tys, cmd_stk') <- matchExpectedCmdArgs n_pats cmd_stk
-
                 -- Check the patterns, and the GRHSs inside
         ; (pats', grhss') <- setSrcSpanA mtch_loc                                 $
                              tcPats LambdaExpr pats (map (unrestricted . mkCheckExpType) arg_tys) $
diff --git a/compiler/GHC/Tc/Gen/HsType.hs b/compiler/GHC/Tc/Gen/HsType.hs
index 5a7fb93f48..53b2e9b232 100644
--- a/compiler/GHC/Tc/Gen/HsType.hs
+++ b/compiler/GHC/Tc/Gen/HsType.hs
@@ -71,7 +71,9 @@ module GHC.Tc.Gen.HsType (
         HoleMode(..),
 
         -- Error messages
-        funAppCtxt, addTyConFlavCtxt
+        funAppCtxt, addTyConFlavCtxt,
+
+        tcTyVar, typeLevelMode
    ) where
 
 #include "HsVersions.h"
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 77c436c912..5756556682 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -950,7 +950,8 @@ cvtl e = wrapLA (cvt e)
                                -- oddities that can result from zero-argument
                                -- lambda expressions. See #13856.
     cvt (LamE ps e)    = do { ps' <- cvtPats ps; e' <- cvtl e
-                            ; let pats = map (parenthesizePat appPrec) ps'
+                            ; let pats' = ps'
+                            ; let pats = map (parenthesizePat appPrec) pats'
                             ; th_origin <- getOrigin
                             ; return $ HsLam noExtField (mkMatchGroup th_origin
                                              (noLocA [mkSimpleMatch LambdaExpr