EPA: AnnAt missing for type application in patterns

Ensure that the exact print annotations accurately record the `@` for
code like

    tyApp :: Con k a -> Proxy a
    tyApp (Con @kx @ax (x :: Proxy ax)) = x :: Proxy (ax :: kx)

Closes #19850

9 files changed, 41 insertions, 15 deletions

diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index 17d84c2d02..0b5457c35e 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -198,7 +198,7 @@ type instance XHsWC              GhcTc b = [Name]
 
 type instance XXHsWildCardBndrs (GhcPass _) _ = NoExtCon
 
-type instance XHsPS GhcPs = NoExtField
+type instance XHsPS GhcPs = EpAnn EpaLocation
 type instance XHsPS GhcRn = HsPSRn
 type instance XHsPS GhcTc = HsPSRn
 
@@ -247,9 +247,9 @@ mkHsWildCardBndrs :: thing -> HsWildCardBndrs GhcPs thing
 mkHsWildCardBndrs x = HsWC { hswc_body = x
                            , hswc_ext  = noExtField }
 
-mkHsPatSigType :: LHsType GhcPs -> HsPatSigType GhcPs
-mkHsPatSigType x = HsPS { hsps_ext  = noExtField
-                        , hsps_body = x }
+mkHsPatSigType :: EpAnn EpaLocation -> LHsType GhcPs -> HsPatSigType GhcPs
+mkHsPatSigType ann x = HsPS { hsps_ext  = ann
+                            , hsps_body = x }
 
 mkEmptyWildCardBndrs :: thing -> HsWildCardBndrs GhcRn thing
 mkEmptyWildCardBndrs x = HsWC { hswc_body = x
diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs
index 62d6c6b834..d6b36b9d51 100644
--- a/compiler/GHC/Parser/PostProcess.hs
+++ b/compiler/GHC/Parser/PostProcess.hs
@@ -874,7 +874,7 @@ mkRuleBndrs :: [LRuleTyTmVar] -> [LRuleBndr GhcPs]
 mkRuleBndrs = fmap (fmap cvt_one)
   where cvt_one (RuleTyTmVar ann v Nothing) = RuleBndr ann v
         cvt_one (RuleTyTmVar ann v (Just sig)) =
-          RuleBndrSig ann v (mkHsPatSigType sig)
+          RuleBndrSig ann v (mkHsPatSigType noAnn sig)
 
 -- turns RuleTyTmVars into HsTyVarBndrs - this is more interesting
 mkRuleTyVarBndrs :: [LRuleTyTmVar] -> [LHsTyVarBndr () GhcPs]
@@ -1095,7 +1095,7 @@ checkPat loc (L l e@(PatBuilderVar (L ln c))) tyargs args
   | not (null args) && patIsRec c =
       add_hint (SuggestExtension LangExt.RecursiveDo) $
       patFail (locA l) (ppr e)
-checkPat loc (L _ (PatBuilderAppType f _ t)) tyargs args =
+checkPat loc (L _ (PatBuilderAppType f t)) tyargs args =
   checkPat loc f (t : tyargs) args
 checkPat loc (L _ (PatBuilderApp f e)) [] args = do
   p <- checkLPat e
@@ -1748,7 +1748,10 @@ instance DisambECP (PatBuilder GhcPs) where
   type FunArg (PatBuilder GhcPs) = PatBuilder GhcPs
   superFunArg m = m
   mkHsAppPV l p1 p2      = return $ L l (PatBuilderApp p1 p2)
-  mkHsAppTypePV l p la t = return $ L l (PatBuilderAppType p la (mkHsPatSigType t))
+  mkHsAppTypePV l p la t = do
+    cs <- getCommentsFor (locA l)
+    let anns = EpAnn (spanAsAnchor (combineSrcSpans la (getLocA t))) (EpaSpan (realSrcSpan la)) cs
+    return $ L l (PatBuilderAppType p (mkHsPatSigType anns t))
   mkHsIfPV l _ _ _ _ _ _ = addFatalError $ PsError PsErrIfTheElseInPat [] l
   mkHsDoPV l _ _ _       = addFatalError $ PsError PsErrDoNotationInPat [] l
   mkHsParPV l p an       = return $ L (noAnnSrcSpan l) (PatBuilderPar p an)
@@ -1761,7 +1764,7 @@ instance DisambECP (PatBuilder GhcPs) where
   mkHsTySigPV l b sig anns = do
     p <- checkLPat b
     cs <- getCommentsFor (locA l)
-    return $ L l (PatBuilderPat (SigPat (EpAnn (spanAsAnchor $ locA l) anns cs) p (mkHsPatSigType sig)))
+    return $ L l (PatBuilderPat (SigPat (EpAnn (spanAsAnchor $ locA l) anns cs) p (mkHsPatSigType noAnn sig)))
   mkHsExplicitListPV l xs anns = do
     ps <- traverse checkLPat xs
     cs <- getCommentsFor l
diff --git a/compiler/GHC/Parser/Types.hs b/compiler/GHC/Parser/Types.hs
index 5369367ed2..b42d04f881 100644
--- a/compiler/GHC/Parser/Types.hs
+++ b/compiler/GHC/Parser/Types.hs
@@ -54,7 +54,7 @@ data PatBuilder p
   = PatBuilderPat (Pat p)
   | PatBuilderPar (LocatedA (PatBuilder p)) AnnParen
   | PatBuilderApp (LocatedA (PatBuilder p)) (LocatedA (PatBuilder p))
-  | PatBuilderAppType (LocatedA (PatBuilder p)) SrcSpan (HsPatSigType GhcPs)
+  | PatBuilderAppType (LocatedA (PatBuilder p)) (HsPatSigType GhcPs)
   | PatBuilderOpApp (LocatedA (PatBuilder p)) (LocatedN RdrName)
                     (LocatedA (PatBuilder p)) (EpAnn [AddEpAnn])
   | PatBuilderVar (LocatedN RdrName)
@@ -64,7 +64,7 @@ instance Outputable (PatBuilder GhcPs) where
   ppr (PatBuilderPat p) = ppr p
   ppr (PatBuilderPar (L _ p) _) = parens (ppr p)
   ppr (PatBuilderApp (L _ p1) (L _ p2)) = ppr p1 <+> ppr p2
-  ppr (PatBuilderAppType (L _ p) _ t) = ppr p <+> text "@" <> ppr t
+  ppr (PatBuilderAppType (L _ p) t) = ppr p <+> text "@" <> ppr t
   ppr (PatBuilderOpApp (L _ p1) op (L _ p2) _) = ppr p1 <+> ppr op <+> ppr p2
   ppr (PatBuilderVar v) = ppr v
   ppr (PatBuilderOverLit l) = ppr l
diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index fa558f41ae..f2f9695109 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -874,7 +874,7 @@ cvtRuleBndr (RuleVar n)
 cvtRuleBndr (TypedRuleVar n ty)
   = do { n'  <- vNameN n
        ; ty' <- cvtType ty
-       ; return $ noLoc $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType ty' }
+       ; return $ noLoc $ Hs.RuleBndrSig noAnn n' $ mkHsPatSigType noAnn ty' }
 
 ---------------------------------------------------
 --              Declarations
@@ -1318,7 +1318,7 @@ cvtp (ConP s ts ps)    = do { s' <- cNameN s
                             ; return $ ConPat
                                 { pat_con_ext = noAnn
                                 , pat_con = s'
-                                , pat_args = PrefixCon (map mkHsPatSigType ts') pps
+                                , pat_args = PrefixCon (map (mkHsPatSigType noAnn) ts') pps
                                 }
                             }
 cvtp (InfixP p1 s p2)  = do { s' <- cNameN s; p1' <- cvtPat p1; p2' <- cvtPat p2
@@ -1353,7 +1353,7 @@ cvtp (ListP ps)        = do { ps' <- cvtPats ps
                             ; return
                                    $ ListPat noAnn ps'}
 cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t
-                            ; return $ SigPat noAnn p' (mkHsPatSigType t') }
+                            ; return $ SigPat noAnn p' (mkHsPatSigType noAnn t') }
 cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p
                             ; return $ ViewPat noAnn e' p'}
 
diff --git a/testsuite/tests/printer/Makefile b/testsuite/tests/printer/Makefile
index b6f05c16d1..1d0fc14f87 100644
--- a/testsuite/tests/printer/Makefile
+++ b/testsuite/tests/printer/Makefile
@@ -597,3 +597,8 @@ Test19839:
 Test19840:
 	$(CHECK_PPR)   $(LIBDIR) Test19840.hs
 	$(CHECK_EXACT) $(LIBDIR) Test19840.hs
+
+.PHONY: Test19850
+Test19850:
+	$(CHECK_PPR)   $(LIBDIR) Test19850.hs
+	$(CHECK_EXACT) $(LIBDIR) Test19850.hs
diff --git a/testsuite/tests/printer/Test19850.hs b/testsuite/tests/printer/Test19850.hs
new file mode 100644
index 0000000000..38dc156103
--- /dev/null
+++ b/testsuite/tests/printer/Test19850.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE PatternSynonyms, ViewPatterns #-}
+{-# LANGUAGE ImplicitParams #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Test19850 where
+
+data Proxy (a :: k) = Proxy
+data Con k (a :: k) = Con (Proxy a)
+
+tyApp :: Con k a -> Proxy a
+tyApp (Con @kx @ax (x :: Proxy ax)) = x :: Proxy (ax :: kx)
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index b868427bfd..916ed6bbee 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -135,3 +135,4 @@ test('Test19821', ignore_stderr, makefile_test, ['Test19821'])
 test('Test19834', ignore_stderr, makefile_test, ['Test19834'])
 test('Test19839', ignore_stderr, makefile_test, ['Test19839'])
 test('Test19840', ignore_stderr, makefile_test, ['Test19840'])
+test('Test19850', ignore_stderr, makefile_test, ['Test19850'])
diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs
index 8bcc508288..b4e53efeb6 100644
--- a/utils/check-exact/ExactPrint.hs
+++ b/utils/check-exact/ExactPrint.hs
@@ -3794,7 +3794,9 @@ instance ExactPrint (Pat GhcPs) where
 instance ExactPrint (HsPatSigType GhcPs) where
   getAnnotationEntry = const NoEntryVal
 
-  exact (HsPS _ ty) = markAnnotated ty
+  exact (HsPS an ty) = do
+    markAnnKw an id AnnAt
+    markAnnotated ty
 
 -- ---------------------------------------------------------------------
 
diff --git a/utils/check-exact/Main.hs b/utils/check-exact/Main.hs
index 807ab7290b..4316f2bea0 100644
--- a/utils/check-exact/Main.hs
+++ b/utils/check-exact/Main.hs
@@ -189,7 +189,8 @@ _tt = testOneFile changers "/home/alanz/mysrc/git.haskell.org/worktree/exactprin
  -- "../../testsuite/tests/printer/Test19814.hs" Nothing
  -- "../../testsuite/tests/printer/Test19821.hs" Nothing
  -- "../../testsuite/tests/printer/Test19834.hs" Nothing
- "../../testsuite/tests/printer/Test19840.hs" Nothing
+ -- "../../testsuite/tests/printer/Test19840.hs" Nothing
+ "../../testsuite/tests/printer/Test19850.hs" Nothing
 
 -- cloneT does not need a test, function can be retired