Pretty-print HsArgPar applications correctly (#19737)

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.

1 files changed, 51 insertions, 4 deletions

diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs
index bbe3fe8b24..66c4cb97c7 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