Fix #19363 by using pprName' {Applied,Infix} in the right places

It was revealed in #19363 that the Template Haskell pretty-printer implemented
in `Language.Haskell.TH.Ppr` did not pretty-print infix names or symbolic names
correctly in certain situations, such as in data constructor declarations or
fixity declarations. Easily fixed by using `pprName' Applied` (which always
parenthesizes symbolic names in prefix position) or `pprName' Infix` (which
always surrounds alphanumeric names with backticks in infix position) in the
right spots.

Fixes #19363.

4 files changed, 61 insertions, 5 deletions

diff --git a/testsuite/tests/th/T19363.hs b/testsuite/tests/th/T19363.hs
new file mode 100644
index 0000000000..41cd26c715
--- /dev/null
+++ b/testsuite/tests/th/T19363.hs
@@ -0,0 +1,35 @@
+{-# Language PatternSynonyms #-}
+{-# Language TemplateHaskell #-}
+{-# Language TypeFamilies #-}
+{-# Language TypeOperators #-}
+
+module Main where
+
+import Language.Haskell.TH
+
+main =  runQ [d| data Operator = (:*) Int | (:**) { (^**) :: Int }
+
+                 data (%*%) = (:%*%)
+                 {-# COMPLETE (:%*%) :: (%*%) #-}
+                 {-# ANN type (%*%) "yargh" #-}
+
+                 f = (:**) { (^**) = 42 }
+                 infix 5 `f`
+
+                 (%%) :: [a] -> [a] -> [a]
+                 (%%) = (++)
+                 {-# INLINE (%%) #-}
+                 {-# SPECIALISE (%%) :: String -> String -> String #-}
+                 {-# ANN (%%) "blah" #-}
+
+                 g (:**) { (^**) = x } = x
+
+                 pattern a `H` b = (a, b)
+                 pattern (:***) { (^***) } <- (:**) (^***) where
+                   (:***) (^***) = (:**) (^***)
+
+                 foreign import ccall unsafe "blah" (<^>) :: Int
+
+                 type family (<%>) a
+                 type (<%%>) a = a
+               |] >>= putStrLn . pprint
diff --git a/testsuite/tests/th/T19363.stdout b/testsuite/tests/th/T19363.stdout
new file mode 100644
index 0000000000..b6d2c30790
--- /dev/null
+++ b/testsuite/tests/th/T19363.stdout
@@ -0,0 +1,20 @@
+data Operator_0
+    = (:*_1) GHC.Types.Int | (:**_2) {(^**_3) :: GHC.Types.Int}
+data (%*%_4) = (:%*%_5)
+{-# COMPLETE (:%*%_5) :: (%*%_4) #-}
+{-# ANN type (%*%_4) "yargh" #-}
+f_6 = (:**_2){(^**_3) = 42}
+infix 5 `f_6`
+(%%_7) :: [a_8] -> [a_8] -> [a_8]
+(%%_7) = (GHC.Base.++)
+{-# INLINE (%%_7) #-}
+{-# SPECIALISE (%%_7) ::
+                 GHC.Base.String -> GHC.Base.String -> GHC.Base.String #-}
+{-# ANN (%%_7) "blah" #-}
+g_9 ((:**_2) {(^**_3) = x_10}) = x_10
+pattern a_11 `H_12` b_13 = (a_11, b_13)
+pattern (:***_14) {(^***_15)} <- (:**_2) (^***_15) where
+                                     (:***_14) (^***_16) = (:**_2) (^***_16)
+foreign import ccall unsafe "static blah" (<^>_17) :: GHC.Types.Int
+type family (<%>_18) a_19
+type (<%%>_20) a_21 = a_21
diff --git a/testsuite/tests/th/T8761.stderr b/testsuite/tests/th/T8761.stderr
index eb45ff46eb..03f5086423 100644
--- a/testsuite/tests/th/T8761.stderr
+++ b/testsuite/tests/th/T8761.stderr
@@ -1,5 +1,5 @@
 pattern Q1 x1_0 x2_1 x3_2 <- ((x1_0, x2_1), [x3_2], _, _)
-pattern x1_0 Q2 x2_1 = GHC.Tuple.Solo (x1_0, x2_1)
+pattern x1_0 `Q2` x2_1 = GHC.Tuple.Solo (x1_0, x2_1)
 pattern Q3 {qx3, qy3, qz3} <- ((qx3, qy3), [qz3]) where
                                   Q3 qx3 qy3 qz3 = ((qx3, qy3), [qz3])
 T8761.hs:(16,1)-(39,13): Splicing declarations
@@ -83,8 +83,8 @@ T8761.hs:(71,1)-(105,39): Splicing declarations
                   forall a. (Num a, Eq a) => forall b. a -> b -> ([a], Ex)
         pattern Pure x y <- ([x, 1], MkEx y)
         pattern Purep ::
-                  forall a.
-                  (Num a, Eq a) => forall b. Show b => a -> b -> ([a], ExProv)
+                  forall a. (Num a, Eq a) =>
+                            forall b. Show b => a -> b -> ([a], ExProv)
         pattern Purep x y <- ([x, 1], MkExProv y)
         pattern Pep :: () => forall a. Show a => a -> ExProv
         pattern Pep x <- MkExProv x
@@ -111,8 +111,8 @@ T8761.hs:(71,1)-(105,39): Splicing declarations
               forall a. (Num a, Eq a) => forall b. a -> b -> ([a], Ex)
     pattern Pure x y <- ([x, 1], MkEx y)
     pattern Purep ::
-              forall a.
-              (Num a, Eq a) => forall b. Show b => a -> b -> ([a], ExProv)
+              forall a. (Num a, Eq a) =>
+                        forall b. Show b => a -> b -> ([a], ExProv)
     pattern Purep x y <- ([x, 1], MkExProv y)
     pattern Pep :: () => forall a. Show a => a -> ExProv
     pattern Pep x <- MkExProv x
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 866bbdef31..235c0148f7 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -518,4 +518,5 @@ test('T18388', normal, compile, [''])
 test('T18612', normal, compile, [''])
 test('T18740c', normal, compile_fail, [''])
 test('T18740d', normal, compile_fail, [''])
+test('T19363', normal, compile_and_run, [''])
 test('T19377', normal, compile, [''])