Fix #19363 by using pprName' {Applied,Infix} in the right placeswip/T19363

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.

5 files changed, 83 insertions, 27 deletions

diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index 20487c904f..47585b9f9d 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -75,7 +75,7 @@ ppr_sig v ty = pprName' Applied v <+> dcolon <+> ppr ty
 
 pprFixity :: Name -> Fixity -> Doc
 pprFixity _ f | f == defaultFixity = empty
-pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> ppr v
+pprFixity v (Fixity i d) = ppr_fix d <+> int i <+> pprName' Infix v
     where ppr_fix InfixR = text "infixr"
           ppr_fix InfixL = text "infixl"
           ppr_fix InfixN = text "infix"
@@ -216,7 +216,7 @@ pprExp _ (ArithSeqE d) = ppr d
 pprExp _ (ListE es) = brackets (commaSep es)
 pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e
                                           <+> dcolon <+> ppr t
-pprExp _ (RecConE nm fs) = ppr nm <> braces (pprFields fs)
+pprExp _ (RecConE nm fs) = pprName' Applied nm <> braces (pprFields fs)
 pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)
 pprExp i (StaticE e) = parensIf (i >= appPrec) $
                          text "static"<+> pprExp appPrec e
@@ -225,7 +225,7 @@ pprExp _ (LabelE s) = text "#" <> text s
 pprExp _ (ImplicitParamVarE n) = text ('?' : n)
 
 pprFields :: [(Name,Exp)] -> Doc
-pprFields = sep . punctuate comma . map (\(s,e) -> ppr s <+> equals <+> ppr e)
+pprFields = sep . punctuate comma . map (\(s,e) -> pprName' Applied s <+> equals <+> ppr e)
 
 pprMaybeExp :: Precedence -> Maybe Exp -> Doc
 pprMaybeExp _ Nothing = empty
@@ -328,9 +328,9 @@ pprPat i (AsP v p)    = parensIf (i > noPrec) $ ppr v <> text "@"
                                                       <> pprPat appPrec p
 pprPat _ WildP        = text "_"
 pprPat _ (RecP nm fs)
- = parens $     ppr nm
+ = parens $     pprName' Applied nm
             <+> braces (sep $ punctuate comma $
-                        map (\(s,p) -> ppr s <+> equals <+> ppr p) fs)
+                        map (\(s,p) -> pprName' Applied s <+> equals <+> ppr p) fs)
 pprPat _ (ListP ps) = brackets (commaSep ps)
 pprPat i (SigP p t) = parensIf (i > noPrec) $ ppr p <+> dcolon <+> ppr t
 pprPat _ (ViewP e p) = parens $ pprExp noPrec e <+> text "->" <+> pprPat noPrec p
@@ -411,10 +411,10 @@ ppr_dec _ (DefaultSigD n ty)
 ppr_dec _ (PatSynD name args dir pat)
   = text "pattern" <+> pprNameArgs <+> ppr dir <+> pprPatRHS
   where
-    pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> ppr name <+> ppr a2
-                | otherwise                 = ppr name <+> ppr args
+    pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> pprName' Infix name <+> ppr a2
+                | otherwise                 = pprName' Applied name <+> ppr args
     pprPatRHS   | ExplBidir cls <- dir = hang (ppr pat <+> text "where")
-                                           nestDepth (ppr name <+> ppr cls)
+                                           nestDepth (pprName' Applied name <+> ppr cls)
                 | otherwise            = ppr pat
 ppr_dec _ (PatSynSigD name ty)
   = pprPatSynSig name ty
@@ -508,13 +508,13 @@ ppr_tySyn :: Doc -> Maybe Name -> Doc -> Type -> Doc
 ppr_tySyn maybeInst t argsDoc rhs
   = text "type" <+> maybeInst
     <+> case t of
-         Just n -> ppr n <+> argsDoc
+         Just n -> pprName' Applied n <+> argsDoc
          Nothing -> argsDoc
     <+> text "=" <+> ppr rhs
 
 ppr_tf_head :: TypeFamilyHead -> Doc
 ppr_tf_head (TypeFamilyHead tc tvs res inj)
-  = ppr tc <+> hsep (map ppr tvs) <+> ppr res <+> maybeInj
+  = pprName' Applied tc <+> hsep (map ppr tvs) <+> ppr res <+> maybeInj
   where
     maybeInj | (Just inj') <- inj = ppr inj'
              | otherwise          = empty
@@ -547,13 +547,13 @@ instance Ppr Foreign where
      <+> showtextl callconv
      <+> showtextl safety
      <+> text (show impent)
-     <+> ppr as
+     <+> pprName' Applied as
      <+> dcolon <+> ppr typ
     ppr (ExportF callconv expent as typ)
         = text "foreign export"
       <+> showtextl callconv
       <+> text (show expent)
-      <+> ppr as
+      <+> pprName' Applied as
       <+> dcolon <+> ppr typ
 
 ------------------------------
@@ -563,13 +563,13 @@ instance Ppr Pragma where
      <+> ppr inline
      <+> ppr rm
      <+> ppr phases
-     <+> ppr n
+     <+> pprName' Applied n
      <+> text "#-}"
     ppr (SpecialiseP n ty inline phases)
        =   text "{-# SPECIALISE"
        <+> maybe empty ppr inline
        <+> ppr phases
-       <+> sep [ ppr n <+> dcolon
+       <+> sep [ pprName' Applied n <+> dcolon
                , nest 2 $ ppr ty ]
        <+> text "#-}"
     ppr (SpecialiseInstP inst)
@@ -590,13 +590,13 @@ instance Ppr Pragma where
     ppr (AnnP tgt expr)
        = text "{-# ANN" <+> target1 tgt <+> ppr expr <+> text "#-}"
       where target1 ModuleAnnotation    = text "module"
-            target1 (TypeAnnotation t)  = text "type" <+> ppr t
-            target1 (ValueAnnotation v) = ppr v
+            target1 (TypeAnnotation t)  = text "type" <+> pprName' Applied t
+            target1 (ValueAnnotation v) = pprName' Applied v
     ppr (LineP line file)
        = text "{-# LINE" <+> int line <+> text (show file) <+> text "#-}"
     ppr (CompleteP cls mty)
-       = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map ppr cls)
-                <+> maybe empty (\ty -> dcolon <+> ppr ty) mty <+> text "#-}"
+       = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map (pprName' Applied) cls)
+                <+> maybe empty (\ty -> dcolon <+> pprName' Applied ty) mty <+> text "#-}"
 
 ------------------------------
 instance Ppr Inline where
@@ -627,10 +627,10 @@ instance Ppr Clause where
 
 ------------------------------
 instance Ppr Con where
-    ppr (NormalC c sts) = ppr c <+> sep (map pprBangType sts)
+    ppr (NormalC c sts) = pprName' Applied c <+> sep (map pprBangType sts)
 
     ppr (RecC c vsts)
-        = ppr c <+> braces (sep (punctuate comma $ map pprVarBangType vsts))
+        = pprName' Applied c <+> braces (sep (punctuate comma $ map pprVarBangType vsts))
 
     ppr (InfixC st1 c st2) = pprBangType st1
                          <+> pprName' Infix c
@@ -663,7 +663,7 @@ instance Ppr PatSynDir where
 instance Ppr PatSynArgs where
   ppr (PrefixPatSyn args) = sep $ map ppr args
   ppr (InfixPatSyn a1 a2) = ppr a1 <+> ppr a2
-  ppr (RecordPatSyn sels) = braces $ sep (punctuate comma (map ppr sels))
+  ppr (RecordPatSyn sels) = braces $ sep (punctuate comma (map (pprName' Applied) sels))
 
 commaSepApplied :: [Name] -> Doc
 commaSepApplied = commaSepWith (pprName' Applied)
@@ -702,7 +702,7 @@ pprGadtRHS sts ty
 ------------------------------
 pprVarBangType :: VarBangType -> Doc
 -- Slight infelicity: with print non-atomic type with parens
-pprVarBangType (v, bang, t) = ppr v <+> dcolon <+> pprBangType (bang, t)
+pprVarBangType (v, bang, t) = pprName' Applied v <+> dcolon <+> pprBangType (bang, t)
 
 ------------------------------
 pprBangType :: BangType -> Doc
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, [''])