From 305f229d30fb6c6f5f08dc3032b96f9dc1987215 Mon Sep 17 00:00:00 2001 From: Vladislav Zavialov Date: Wed, 4 Dec 2019 14:47:15 +0300 Subject: Parenthesize the * kind in TH.Ppr --- .../template-haskell/Language/Haskell/TH/Ppr.hs | 31 +++++++++++++--------- testsuite/tests/th/T11463.stdout | 2 +- testsuite/tests/th/TH_PprStar.hs | 12 +++++++++ testsuite/tests/th/TH_PprStar.stderr | 2 ++ testsuite/tests/th/TH_TyInstWhere2.stderr | 2 +- testsuite/tests/th/all.T | 1 + 6 files changed, 36 insertions(+), 14 deletions(-) create mode 100644 testsuite/tests/th/TH_PprStar.hs create mode 100644 testsuite/tests/th/TH_PprStar.stderr 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']) -- cgit v1.2.1