diff options
author | jackohughes <jack@jackohughes.com> | 2022-04-11 19:41:02 +0000 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2022-05-13 12:10:34 -0400 |
commit | 668a9ef496f9df7e628397c4de9a0a4fcdcd7e6a (patch) | |
tree | 11a79dacda0b6c7cf550dc5c6d34af82fa965620 | |
parent | 3bf938b6c5e1190f3a55e149deaec2f6309d398f (diff) | |
download | haskell-668a9ef496f9df7e628397c4de9a0a4fcdcd7e6a.tar.gz |
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
-rw-r--r-- | compiler/GHC/Core/TyCo/Ppr.hs | 2 | ||||
-rw-r--r-- | compiler/GHC/Hs/Type.hs | 3 | ||||
-rw-r--r-- | compiler/GHC/Iface/Type.hs | 11 | ||||
-rw-r--r-- | compiler/GHC/Tc/Types/Evidence.hs | 4 | ||||
-rw-r--r-- | compiler/GHC/Utils/Outputable.hs | 6 | ||||
-rw-r--r-- | testsuite/tests/printer/Test20315.hs | 3 | ||||
-rw-r--r-- | testsuite/tests/printer/Test20315.stderr | 7 | ||||
-rw-r--r-- | testsuite/tests/printer/all.T | 1 |
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']) |