summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorVladislav Zavialov <vlad.z.4096@gmail.com>2019-12-04 14:47:15 +0300
committerVladislav Zavialov <vlad.z.4096@gmail.com>2019-12-04 16:40:54 +0300
commit305f229d30fb6c6f5f08dc3032b96f9dc1987215 (patch)
treefaca98508dc61a10145f7aab2c81d57b2435bedb
parentdf1f00db98f28c71a39e0e2fbbf423d861079edb (diff)
downloadhaskell-wip/star-prec.tar.gz
Parenthesize the * kind in TH.Pprwip/star-prec
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Ppr.hs31
-rw-r--r--testsuite/tests/th/T11463.stdout2
-rw-r--r--testsuite/tests/th/TH_PprStar.hs12
-rw-r--r--testsuite/tests/th/TH_PprStar.stderr2
-rw-r--r--testsuite/tests/th/TH_TyInstWhere2.stderr2
-rw-r--r--testsuite/tests/th/all.T1
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'])