Parenthesize the * kind in TH.Pprwip/star-prec

6 files changed, 36 insertions, 14 deletions

diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index ef9a718111..d2e1855da2 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -791,12 +791,17 @@ instance Ppr Type where
        -- Works, in a degenerate way, for SigT, and puts parens round (ty :: kind)
        -- See Note [Pretty-printing kind signatures]
 instance Ppr TypeArg where
-    ppr (TANormal ty) = ppr ty
-    ppr (TyArg ki) = char '@' <> ppr ki
+    ppr (TANormal ty) = parensIf (isStarT ty) (ppr ty)
+    ppr (TyArg ki) = char '@' <> parensIf (isStarT ki) (ppr ki)
 
 pprParendTypeArg :: TypeArg -> Doc
-pprParendTypeArg (TANormal ty) = pprParendType ty
-pprParendTypeArg (TyArg ki) = char '@' <> pprParendType ki
+pprParendTypeArg (TANormal ty) = parensIf (isStarT ty) (pprParendType ty)
+pprParendTypeArg (TyArg ki) = char '@' <> parensIf (isStarT ki) (pprParendType ki)
+
+isStarT :: Type -> Bool
+isStarT StarT = True
+isStarT _ = False
+
 {- Note [Pretty-printing kind signatures]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 GHC's parser only recognises a kind signature in a type when there are
@@ -810,18 +815,20 @@ pprTyApp (ArrowT, [TANormal arg1, TANormal arg2]) = sep [pprFunArgType arg1 <+>
 pprTyApp (EqualityT, [TANormal arg1, TANormal arg2]) =
     sep [pprFunArgType arg1 <+> text "~", ppr arg2]
 pprTyApp (ListT, [TANormal arg]) = brackets (ppr arg)
+pprTyApp (TupleT 1, args) = pprTyApp (ConT (tupleTypeName 1), args)
+pprTyApp (PromotedTupleT 1, args) = pprTyApp (PromotedT (tupleDataName 1), args)
 pprTyApp (TupleT n, args)
- | length args == n
- = if n == 1
-   then pprTyApp (ConT (tupleTypeName 1), args)
-   else parens (commaSep args)
+ | length args == n, Just args' <- traverse fromTANormal args
+ = parens (commaSep args')
 pprTyApp (PromotedTupleT n, args)
- | length args == n
- = if n == 1
-   then pprTyApp (PromotedT (tupleDataName 1), args)
-   else quoteParens (commaSep args)
+ | length args == n, Just args' <- traverse fromTANormal args
+ = quoteParens (commaSep args')
 pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendTypeArg args)
 
+fromTANormal :: TypeArg -> Maybe Type
+fromTANormal (TANormal arg) = Just arg
+fromTANormal (TyArg _) = Nothing
+
 pprFunArgType :: Type -> Doc    -- Should really use a precedence argument
 -- Everything except forall and (->) binds more tightly than (->)
 pprFunArgType ty@(ForallT {})                 = parens (ppr ty)
diff --git a/testsuite/tests/th/T11463.stdout b/testsuite/tests/th/T11463.stdout
index d33038a10e..fe61aff45c 100644
--- a/testsuite/tests/th/T11463.stdout
+++ b/testsuite/tests/th/T11463.stdout
@@ -1,2 +1,2 @@
 data Main.Proxy1 (a_0 :: Main.Id1 k_1) = Main.Proxy1
-data Main.Proxy2 (a_0 :: Main.Id2 * k_1) = Main.Proxy2
+data Main.Proxy2 (a_0 :: Main.Id2 (*) k_1) = Main.Proxy2
diff --git a/testsuite/tests/th/TH_PprStar.hs b/testsuite/tests/th/TH_PprStar.hs
new file mode 100644
index 0000000000..db12fc4ed6
--- /dev/null
+++ b/testsuite/tests/th/TH_PprStar.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell, TypeApplications, ExplicitForAll, StarIsType #-}
+{-# OPTIONS -Wno-star-is-type #-}
+
+module TH_PprStar where
+
+import Data.Proxy
+import Language.Haskell.TH
+import System.IO
+
+do t <- [t| (Proxy @(*) String -> *) -> Either * ((* -> *) -> *) |]
+   runIO $ do hPutStrLn stderr (pprint t)
+   return []
diff --git a/testsuite/tests/th/TH_PprStar.stderr b/testsuite/tests/th/TH_PprStar.stderr
new file mode 100644
index 0000000000..22c8f8dd6c
--- /dev/null
+++ b/testsuite/tests/th/TH_PprStar.stderr
@@ -0,0 +1,2 @@
+(Data.Proxy.Proxy @(*) GHC.Base.String -> *) ->
+Data.Either.Either (*) ((* -> *) -> *)
diff --git a/testsuite/tests/th/TH_TyInstWhere2.stderr b/testsuite/tests/th/TH_TyInstWhere2.stderr
index c79af948a6..bbeabab267 100644
--- a/testsuite/tests/th/TH_TyInstWhere2.stderr
+++ b/testsuite/tests/th/TH_TyInstWhere2.stderr
@@ -6,5 +6,5 @@ TH_TyInstWhere2.hs:8:2: warning:
 
 TH_TyInstWhere2.hs:14:2: warning:
     type family F1_0 (a_1 :: k_2) :: * where
-    F1_0 @* GHC.Types.Int = GHC.Types.Bool
+    F1_0 @(*) GHC.Types.Int = GHC.Types.Bool
     F1_0 @GHC.Types.Bool 'GHC.Types.False = GHC.Types.Char
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 9e07d5035b..9075591e10 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -494,3 +494,4 @@ test('T17394', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T17379a', normal, compile_fail, [''])
 test('T17379b', normal, compile_fail, [''])
 test('T17461', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('TH_PprStar', normal, compile, ['-v0 -dsuppress-uniques'])