Fix printing of brackets in multiplicities (#20315)

Change mulArrow to allow for printing of correct application precedence
where necessary and update callers of mulArrow to reflect this.

As part of this, move mulArrow from GHC/Utils/Outputtable to GHC/Iface/Type.

Fixes #20315

8 files changed, 27 insertions, 10 deletions

diff --git a/compiler/GHC/Core/TyCo/Ppr.hs b/compiler/GHC/Core/TyCo/Ppr.hs
index 5f1a802dfe..d78e90f0c9 100644
--- a/compiler/GHC/Core/TyCo/Ppr.hs
+++ b/compiler/GHC/Core/TyCo/Ppr.hs
@@ -238,7 +238,7 @@ debug_ppr_ty prec ty@(FunTy { ft_af = af, ft_mult = mult, ft_arg = arg, ft_res =
             VisArg   -> case mult of
                           One -> lollipop
                           Many -> arrow
-                          w -> mulArrow (ppr w)
+                          w -> mulArrow (const ppr) w
             InvisArg -> case mult of
                           Many -> darrow
                           _ -> pprPanic "unexpected multiplicity" (ppr ty)
diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs
index de565fcae7..5cb4200ecd 100644
--- a/compiler/GHC/Hs/Type.hs
+++ b/compiler/GHC/Hs/Type.hs
@@ -107,6 +107,7 @@ import GHC.Core.TyCo.Rep ( Type(..) )
 import GHC.Builtin.Types( manyDataConName, oneDataConName, mkTupleStr )
 import GHC.Core.Ppr ( pprOccWithTick)
 import GHC.Core.Type
+import GHC.Iface.Type
 import GHC.Hs.Doc
 import GHC.Types.Basic
 import GHC.Types.SrcLoc
@@ -360,7 +361,7 @@ instance
 pprHsArrow :: (OutputableBndrId pass) => HsArrow (GhcPass pass) -> SDoc
 pprHsArrow (HsUnrestrictedArrow _) = arrow
 pprHsArrow (HsLinearArrow _) = lollipop
-pprHsArrow (HsExplicitMult _ p _) = mulArrow (ppr p)
+pprHsArrow (HsExplicitMult _ p _) = mulArrow (const ppr) p
 
 type instance XConDeclField  (GhcPass _) = EpAnn [AddEpAnn]
 type instance XXConDeclField (GhcPass _) = DataConCantHappen
diff --git a/compiler/GHC/Iface/Type.hs b/compiler/GHC/Iface/Type.hs
index 40dccb6e0e..cb50003fe4 100644
--- a/compiler/GHC/Iface/Type.hs
+++ b/compiler/GHC/Iface/Type.hs
@@ -55,6 +55,7 @@ module GHC.Iface.Type (
         pprIfaceCoercion, pprParendIfaceCoercion,
         splitIfaceSigmaTy, pprIfaceTypeApp, pprUserIfaceForAll,
         pprIfaceCoTcApp, pprTyTcApp, pprIfacePrefixApp,
+        mulArrow,
         ppr_fun_arrow,
         isIfaceTauType,
 
@@ -909,13 +910,19 @@ pprPrecIfaceType :: PprPrec -> IfaceType -> SDoc
 pprPrecIfaceType prec ty =
   hideNonStandardTypes (ppr_ty prec) ty
 
+-- mulArrow takes a pretty printer for the type it is being called on to
+-- allow type applications to be printed with the correct precedence inside
+-- the multiplicity e.g. a %(m n) -> b. See #20315.
+mulArrow :: (PprPrec -> a -> SDoc) -> a -> SDoc
+mulArrow ppr_mult mult = text "%" <> ppr_mult appPrec mult <+> arrow
+
 ppr_fun_arrow :: IfaceMult -> SDoc
 ppr_fun_arrow w
   | (IfaceTyConApp tc _) <- w
   , tc `ifaceTyConHasKey` (getUnique manyDataConTyCon) = arrow
   | (IfaceTyConApp tc _) <- w
   , tc `ifaceTyConHasKey` (getUnique oneDataConTyCon) = lollipop
-  | otherwise = mulArrow (pprIfaceType w)
+  | otherwise = mulArrow pprPrecIfaceType w
 
 ppr_sigma :: PprPrec -> IfaceType -> SDoc
 ppr_sigma ctxt_prec ty
@@ -1718,7 +1725,7 @@ ppr_co ctxt_prec (IfaceFunCo r cow co1 co2)
       = (coercionArrow cow' <> ppr_role r <+> ppr_co funPrec co1) : ppr_fun_tail cow co2
     ppr_fun_tail cow' other_co
       = [coercionArrow cow' <> ppr_role r <+> pprIfaceCoercion other_co]
-    coercionArrow w = mulArrow (ppr_co topPrec w)
+    coercionArrow w = mulArrow ppr_co w
 
 ppr_co _         (IfaceTyConAppCo r tc cos)
   = parens (pprIfaceCoTcApp topPrec tc cos) <> ppr_role r
diff --git a/compiler/GHC/Tc/Types/Evidence.hs b/compiler/GHC/Tc/Types/Evidence.hs
index c6c0c7b0ca..837903a0f7 100644
--- a/compiler/GHC/Tc/Types/Evidence.hs
+++ b/compiler/GHC/Tc/Types/Evidence.hs
@@ -87,6 +87,8 @@ import GHC.Core
 import GHC.Core.Class (Class, classSCSelId )
 import GHC.Core.FVs   ( exprSomeFreeVars )
 
+import GHC.Iface.Type
+
 import GHC.Utils.Misc
 import GHC.Utils.Panic
 import GHC.Utils.Outputable
@@ -1034,7 +1036,7 @@ instance Outputable EvCallStack where
 instance Outputable EvTypeable where
   ppr (EvTypeableTyCon ts _)  = text "TyCon" <+> ppr ts
   ppr (EvTypeableTyApp t1 t2) = parens (ppr t1 <+> ppr t2)
-  ppr (EvTypeableTrFun tm t1 t2) = parens (ppr t1 <+> mulArrow (ppr tm) <+> ppr t2)
+  ppr (EvTypeableTrFun tm t1 t2) = parens (ppr t1 <+> mulArrow (const ppr) tm <+> ppr t2)
   ppr (EvTypeableTyLit t1)    = text "TyLit" <> ppr t1
 
 
diff --git a/compiler/GHC/Utils/Outputable.hs b/compiler/GHC/Utils/Outputable.hs
index 782dbd45fc..f424076e04 100644
--- a/compiler/GHC/Utils/Outputable.hs
+++ b/compiler/GHC/Utils/Outputable.hs
@@ -36,7 +36,7 @@ module GHC.Utils.Outputable (
         semi, comma, colon, dcolon, space, equals, dot, vbar,
         arrow, lollipop, larrow, darrow, arrowt, larrowt, arrowtt, larrowtt,
         lambda,
-        lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore, mulArrow,
+        lparen, rparen, lbrack, rbrack, lbrace, rbrace, underscore,
         blankLine, forAllLit, bullet,
         (<>), (<+>), hcat, hsep,
         ($$), ($+$), vcat,
@@ -736,10 +736,6 @@ rbrack     = docToSDoc $ Pretty.rbrack
 lbrace     = docToSDoc $ Pretty.lbrace
 rbrace     = docToSDoc $ Pretty.rbrace
 
-mulArrow :: SDoc -> SDoc
-mulArrow d = text "%" <> d <+> arrow
-
-
 forAllLit :: SDoc
 forAllLit = unicodeSyntax (char '∀') (text "forall")
 
diff --git a/testsuite/tests/printer/Test20315.hs b/testsuite/tests/printer/Test20315.hs
new file mode 100644
index 0000000000..bff072596d
--- /dev/null
+++ b/testsuite/tests/printer/Test20315.hs
@@ -0,0 +1,3 @@
+{-# LANGUAGE LinearTypes #-}
+
+f = id :: a %(m n) -> a
diff --git a/testsuite/tests/printer/Test20315.stderr b/testsuite/tests/printer/Test20315.stderr
new file mode 100644
index 0000000000..061459f23b
--- /dev/null
+++ b/testsuite/tests/printer/Test20315.stderr
@@ -0,0 +1,7 @@
+
+Test20315.hs:3:5: error:
+    • Couldn't match type ‘'Many’ with ‘m1 n1’
+      Expected: a1 %(m1 n1) -> a1
+        Actual: a1 -> a1
+    • In the expression: id :: a %(m n) -> a
+      In an equation for ‘f’: f = id :: a %(m n) -> a
diff --git a/testsuite/tests/printer/all.T b/testsuite/tests/printer/all.T
index 12b3960a7a..7852a8adbe 100644
--- a/testsuite/tests/printer/all.T
+++ b/testsuite/tests/printer/all.T
@@ -177,4 +177,5 @@ test('Test20247', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20247'])
 test('Test20256', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20256'])
 test('Test20258', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20258'])
 test('Test20297', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20297'])
+test('Test20315', normal, compile_fail, [''])
 test('Test20846', [ignore_stderr, req_ppr_deps], makefile_test, ['Test20846'])