Pretty-print HsArgPar applications correctly (#19737)wip/T19737

Previously, the `Outputable` instance for `HsArg` was being used to
pretty-print each `HsArgPar` in a list of `HsArg`s individually, which
simply doesn't work. In lieu of the `Outputable` instance, we now use
a dedicated `pprHsArgsApp` function to print a list of `HsArg`s as a single
unit. I have also added documentation to the `Outputable` instance for `HsArg`
to more clearly signpost that it is only suitable for debug pretty-printing.

Fixes #19737.

6 files changed, 88 insertions, 16 deletions

diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs
index 9f3f6469e5..9f7b278ef3 100644
--- a/compiler/GHC/Hs/Decls.hs
+++ b/compiler/GHC/Hs/Decls.hs
@@ -810,17 +810,7 @@ pprHsFamInstLHS :: (OutputableBndrId p)
 pprHsFamInstLHS thing bndrs typats fixity mb_ctxt
    = hsep [ pprHsOuterFamEqnTyVarBndrs bndrs
           , pprLHsContext mb_ctxt
-          , pp_pats typats ]
-   where
-     pp_pats (patl:patr:pats)
-       | Infix <- fixity
-       = let pp_op_app = hsep [ ppr patl, pprInfixOcc thing, ppr patr ] in
-         case pats of
-           [] -> pp_op_app
-           _  -> hsep (parens pp_op_app : map ppr pats)
-
-     pp_pats pats = hsep [ pprPrefixOcc thing
-                         , hsep (map ppr pats)]
+          , pprHsArgsApp thing fixity typats ]
 
 instance OutputableBndrId p
        => Outputable (ClsInstDecl (GhcPass p)) where
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index a666a87519..917063d6f4 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -37,7 +37,7 @@ module GHC.Hs.Type (
         HsContext, LHsContext, fromMaybeContext,
         HsTyLit(..),
         HsIPName(..), hsIPNameFS,
-        HsArg(..), numVisibleArgs,
+        HsArg(..), numVisibleArgs, pprHsArgsApp,
         LHsTypeArg, lhsTypeArgSrcSpan,
         OutputableBndrFlag,
 
diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs
index f23072c04a..a9214be736 100644
--- a/compiler/Language/Haskell/Syntax/Type.hs
+++ b/compiler/Language/Haskell/Syntax/Type.hs
@@ -34,7 +34,7 @@ module Language.Haskell.Syntax.Type (
         HsContext, LHsContext,
         HsTyLit(..),
         HsIPName(..), hsIPNameFS,
-        HsArg(..), numVisibleArgs,
+        HsArg(..), numVisibleArgs, pprHsArgsApp,
         LHsTypeArg,
 
         LBangType, BangType,
@@ -70,6 +70,7 @@ import GHC.Core.DataCon( HsSrcBang(..), HsImplBang(..),
 import GHC.Core.Type
 import GHC.Hs.Doc
 import GHC.Types.Basic
+import GHC.Types.Fixity
 import GHC.Types.SrcLoc
 import GHC.Utils.Outputable
 import GHC.Data.FastString
@@ -1214,10 +1215,56 @@ numVisibleArgs = count is_vis
 -- type level equivalent
 type LHsTypeArg p = HsArg (LHsType p) (LHsKind p)
 
+-- | @'pprHsArgsApp' id fixity args@ pretty-prints an application of @id@
+-- to @args@, using the @fixity@ to tell whether @id@ should be printed prefix
+-- or infix. Examples:
+--
+-- @
+-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsValArg Int]                        = T \@Bool Int
+-- pprHsArgsApp T Prefix [HsTypeArg Bool, HsArgPar, HsValArg Int]              = (T \@Bool) Int
+-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double]                    = Char ++ Double
+-- pprHsArgsApp (++) Infix [HsValArg Char, HsValArg Double, HsVarArg Ordering] = (Char ++ Double) Ordering
+-- @
+pprHsArgsApp :: (OutputableBndr id, Outputable tm, Outputable ty)
+             => id -> LexicalFixity -> [HsArg tm ty] -> SDoc
+pprHsArgsApp thing fixity (argl:argr:args)
+  | Infix <- fixity
+  = let pp_op_app = hsep [ ppr_single_hs_arg argl
+                         , pprInfixOcc thing
+                         , ppr_single_hs_arg argr ] in
+    case args of
+      [] -> pp_op_app
+      _  -> ppr_hs_args_prefix_app (parens pp_op_app) args
+
+pprHsArgsApp thing _fixity args
+  = ppr_hs_args_prefix_app (pprPrefixOcc thing) args
+
+-- | Pretty-print a prefix identifier to a list of 'HsArg's.
+ppr_hs_args_prefix_app :: (Outputable tm, Outputable ty)
+                        => SDoc -> [HsArg tm ty] -> SDoc
+ppr_hs_args_prefix_app acc []         = acc
+ppr_hs_args_prefix_app acc (arg:args) =
+  case arg of
+    HsValArg{}  -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args
+    HsTypeArg{} -> ppr_hs_args_prefix_app (acc <+> ppr_single_hs_arg arg) args
+    HsArgPar{}  -> ppr_hs_args_prefix_app (parens acc) args
+
+-- | Pretty-print an 'HsArg' in isolation.
+ppr_single_hs_arg :: (Outputable tm, Outputable ty)
+                  => HsArg tm ty -> SDoc
+ppr_single_hs_arg (HsValArg tm)    = ppr tm
+ppr_single_hs_arg (HsTypeArg _ ty) = char '@' <> ppr ty
+-- GHC shouldn't be constructing ASTs such that this case is ever reached.
+-- Still, it's possible some wily user might construct their own AST that
+-- allows this to be reachable, so don't fail here.
+ppr_single_hs_arg (HsArgPar{})     = empty
+
+-- | This instance is meant for debug-printing purposes. If you wish to
+-- pretty-print an application of 'HsArg's, use 'pprHsArgsApp' instead.
 instance (Outputable tm, Outputable ty) => Outputable (HsArg tm ty) where
-  ppr (HsValArg tm)    = ppr tm
-  ppr (HsTypeArg _ ty) = char '@' <> ppr ty
-  ppr (HsArgPar sp)    = text "HsArgPar"  <+> ppr sp
+  ppr (HsValArg tm)     = text "HsValArg"  <+> ppr tm
+  ppr (HsTypeArg sp ty) = text "HsTypeArg" <+> ppr sp <+> ppr ty
+  ppr (HsArgPar sp)     = text "HsArgPar"  <+> ppr sp
 {-
 Note [HsArgPar]
 A HsArgPar indicates that everything to the left of this in the argument list is
diff --git a/testsuite/tests/th/T19737.hs b/testsuite/tests/th/T19737.hs
new file mode 100644
index 0000000000..72ec1fe053
--- /dev/null
+++ b/testsuite/tests/th/T19737.hs
@@ -0,0 +1,14 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -ddump-splices #-}
+module T19737 where
+
+import Language.Haskell.TH
+
+type family T a
+
+$(pure [ TySynInstD (TySynEqn Nothing (ConT ''T `AppT` ConT ''Char) (ConT ''Char))
+       , TySynInstD (TySynEqn Nothing (ParensT (ConT ''T) `AppT` ConT ''Int) (ConT ''Int))
+       , TySynInstD (TySynEqn Nothing (ParensT (ConT ''T `AppT` ConT ''Bool)) (ConT ''Bool))
+       , TySynInstD (TySynEqn Nothing (ParensT (ParensT (ConT ''T `AppT` ParensT (ConT ''Double)))) (ConT ''Double))
+       ])
diff --git a/testsuite/tests/th/T19737.stderr b/testsuite/tests/th/T19737.stderr
new file mode 100644
index 0000000000..ba1465b26a
--- /dev/null
+++ b/testsuite/tests/th/T19737.stderr
@@ -0,0 +1,20 @@
+T19737.hs:(10,2)-(14,9): Splicing declarations
+    pure
+      [TySynInstD
+         (TySynEqn Nothing (ConT ''T `AppT` ConT ''Char) (ConT ''Char)),
+       TySynInstD
+         (TySynEqn
+            Nothing (ParensT (ConT ''T) `AppT` ConT ''Int) (ConT ''Int)),
+       TySynInstD
+         (TySynEqn
+            Nothing (ParensT (ConT ''T `AppT` ConT ''Bool)) (ConT ''Bool)),
+       TySynInstD
+         (TySynEqn
+            Nothing
+            (ParensT (ParensT (ConT ''T `AppT` ParensT (ConT ''Double))))
+            (ConT ''Double))]
+  ======>
+    type instance T Char = Char
+    type instance (T) Int = Int
+    type instance (T Bool) = Bool
+    type instance ((T (Double))) = Double
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 857c9f3659..fb3bc7fb49 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -523,3 +523,4 @@ test('T19363', normal, compile_and_run, [''])
 test('T19377', normal, compile, [''])
 test('T17804', normal, compile, [''])
 test('T19470', only_ways(['ghci']), ghci_script, ['T19470.script'])
+test('T19737', normal, compile, [''])