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.

1 files changed, 22 insertions, 22 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