[Git][ghc/ghc][master] 4 commits: Added pprType with precedence argument, as a prerequisite to fix issues #21723 and #21942.
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Tue Aug 23 02:06:44 UTC 2022
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
b946232c by Mario Blažević at 2022-08-22T22:06:21-04:00
Added pprType with precedence argument, as a prerequisite to fix issues #21723 and #21942.
* refines the precedence levels, adding `qualPrec` and `funPrec` to better control parenthesization
* `pprParendType`, `pprFunArgType`, and `instance Ppr Type` all just call `pprType` with proper precedence
* `ParensT` constructor is now always printed parenthesized
* adds the precedence argument to `pprTyApp` as well, as it needs to keep track and pass it down
* using `>=` instead of former `>` to match the Core type printing logic
* some test outputs have changed, losing extraneous parentheses
- - - - -
fe4ff0f7 by Mario Blažević at 2022-08-22T22:06:21-04:00
Fix and test for issue #21723
- - - - -
33968354 by Mario Blažević at 2022-08-22T22:06:21-04:00
Test for issue #21942
- - - - -
c9655251 by Mario Blažević at 2022-08-22T22:06:21-04:00
Updated the changelog
- - - - -
11 changed files:
- libraries/template-haskell/Language/Haskell/TH/Ppr.hs
- libraries/template-haskell/changelog.md
- testsuite/tests/th/T15845.stderr
- + testsuite/tests/th/T21723.hs
- + testsuite/tests/th/T21723.stdout
- + testsuite/tests/th/T21942.hs
- + testsuite/tests/th/T21942.stdout
- testsuite/tests/th/T9262.stderr
- testsuite/tests/th/TH_reifyExplicitForAllFams.stderr
- testsuite/tests/th/TH_unresolvedInfix.stdout
- testsuite/tests/th/all.T
Changes:
=====================================
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
=====================================
@@ -23,10 +23,12 @@ nestDepth :: Int
nestDepth = 4
type Precedence = Int
-appPrec, opPrec, unopPrec, sigPrec, noPrec :: Precedence
-appPrec = 4 -- Argument of a function application
-opPrec = 3 -- Argument of an infix operator
-unopPrec = 2 -- Argument of an unresolved infix operator
+appPrec, opPrec, unopPrec, funPrec, qualPrec, sigPrec, noPrec :: Precedence
+appPrec = 6 -- Argument of a function or type application
+opPrec = 5 -- Argument of an infix operator
+unopPrec = 4 -- Argument of an unresolved infix operator
+funPrec = 3 -- Argument of a function arrow
+qualPrec = 2 -- Forall-qualified type or result of a function arrow
sigPrec = 1 -- Argument of an explicit type signature
noPrec = 0 -- Others
@@ -220,7 +222,7 @@ pprExp _ (CompE ss) =
pprExp _ (ArithSeqE d) = ppr d
pprExp _ (ListE es) = brackets (commaSep es)
pprExp i (SigE e t) = parensIf (i > noPrec) $ pprExp sigPrec e
- <+> dcolon <+> ppr t
+ <+> dcolon <+> pprType sigPrec t
pprExp _ (RecConE nm fs) = pprName' Applied nm <> braces (pprFields fs)
pprExp _ (RecUpdE e fs) = pprExp appPrec e <> braces (pprFields fs)
pprExp i (StaticE e) = parensIf (i >= appPrec) $
@@ -792,60 +794,63 @@ pprStrictType :: (Strict, Type) -> Doc
pprStrictType = pprBangType
------------------------------
-pprParendType :: Type -> Doc
-pprParendType (VarT v) = pprName' Applied v
+pprType :: Precedence -> Type -> Doc
+pprType _ (VarT v) = pprName' Applied v
-- `Applied` is used here instead of `ppr` because of infix names (#13887)
-pprParendType (ConT c) = pprName' Applied c
-pprParendType (TupleT 0) = text "()"
-pprParendType (TupleT 1) = pprParendType (ConT (tupleTypeName 1))
-pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma))
-pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma
-pprParendType (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar
-pprParendType ArrowT = parens (text "->")
-pprParendType MulArrowT = text "FUN"
-pprParendType ListT = text "[]"
-pprParendType (LitT l) = pprTyLit l
-pprParendType (PromotedT c) = text "'" <> pprName' Applied c
-pprParendType (PromotedTupleT 0) = text "'()"
-pprParendType (PromotedTupleT 1) = pprParendType (PromotedT (tupleDataName 1))
-pprParendType (PromotedTupleT n) = quoteParens (hcat (replicate (n-1) comma))
-pprParendType PromotedNilT = text "'[]"
-pprParendType PromotedConsT = text "'(:)"
-pprParendType StarT = char '*'
-pprParendType ConstraintT = text "Constraint"
-pprParendType (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k)
-pprParendType WildCardT = char '_'
-pprParendType t@(InfixT {}) = parens (pprInfixT t)
-pprParendType t@(UInfixT {}) = parens (pprInfixT t)
-pprParendType t@(PromotedInfixT {}) = parens (pprInfixT t)
-pprParendType t@(PromotedUInfixT {}) = parens (pprInfixT t)
-pprParendType (ParensT t) = ppr t
-pprParendType tuple | (TupleT n, args) <- split tuple
- , length args == n
- = parens (commaSep args)
-pprParendType (ImplicitParamT n t) = text ('?':n) <+> text "::" <+> ppr t
-pprParendType EqualityT = text "(~)"
-pprParendType t@(ForallT {}) = parens (ppr t)
-pprParendType t@(ForallVisT {}) = parens (ppr t)
-pprParendType t@(AppT {}) = parens (ppr t)
-pprParendType t@(AppKindT {}) = parens (ppr t)
-
-pprInfixT :: Type -> Doc
-pprInfixT = \case
- (InfixT x n y) -> with x n y "" ppr
- (UInfixT x n y) -> with x n y "" pprInfixT
- (PromotedInfixT x n y) -> with x n y "'" ppr
- (PromotedUInfixT x n y) -> with x n y "'" pprInfixT
- t -> ppr t
+pprType _ (ConT c) = pprName' Applied c
+pprType _ (TupleT 0) = text "()"
+pprType p (TupleT 1) = pprType p (ConT (tupleTypeName 1))
+pprType _ (TupleT n) = parens (hcat (replicate (n-1) comma))
+pprType _ (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma
+pprType _ (UnboxedSumT arity) = hashParens $ hcat $ replicate (arity-1) bar
+pprType _ ArrowT = parens (text "->")
+pprType _ MulArrowT = text "FUN"
+pprType _ ListT = text "[]"
+pprType _ (LitT l) = pprTyLit l
+pprType _ (PromotedT c) = text "'" <> pprName' Applied c
+pprType _ (PromotedTupleT 0) = text "'()"
+pprType p (PromotedTupleT 1) = pprType p (PromotedT (tupleDataName 1))
+pprType _ (PromotedTupleT n) = quoteParens (hcat (replicate (n-1) comma))
+pprType _ PromotedNilT = text "'[]"
+pprType _ PromotedConsT = text "'(:)"
+pprType _ StarT = char '*'
+pprType _ ConstraintT = text "Constraint"
+pprType _ (SigT ty k) = parens (ppr ty <+> text "::" <+> ppr k)
+pprType _ WildCardT = char '_'
+pprType p t@(InfixT {}) = pprInfixT p t
+pprType p t@(UInfixT {}) = pprInfixT p t
+pprType p t@(PromotedInfixT {}) = pprInfixT p t
+pprType p t@(PromotedUInfixT {}) = pprInfixT p t
+pprType _ (ParensT t) = parens (pprType noPrec t)
+pprType p (ImplicitParamT n ty) =
+ parensIf (p >= sigPrec) $ text ('?':n) <+> text "::" <+> pprType sigPrec ty
+pprType _ EqualityT = text "(~)"
+pprType p (ForallT tvars ctxt ty) =
+ parensIf (p >= funPrec) $ sep [pprForall tvars ctxt, pprType qualPrec ty]
+pprType p (ForallVisT tvars ty) =
+ parensIf (p >= funPrec) $ sep [pprForallVis tvars [], pprType qualPrec ty]
+pprType p t at AppT{} = pprTyApp p (split t)
+pprType p t at AppKindT{} = pprTyApp p (split t)
+
+------------------------------
+pprParendType :: Type -> Doc
+pprParendType = pprType appPrec
+
+pprInfixT :: Precedence -> Type -> Doc
+pprInfixT p = \case
+ InfixT x n y -> with x n y "" opPrec
+ UInfixT x n y -> with x n y "" unopPrec
+ PromotedInfixT x n y -> with x n y "'" opPrec
+ PromotedUInfixT x n y -> with x n y "'" unopPrec
+ t -> pprParendType t
where
- with x n y prefix ppr' = ppr' x <+> text prefix <> pprName' Infix n <+> ppr' y
+ with x n y prefix p' =
+ parensIf
+ (p >= p')
+ (pprType opPrec x <+> text prefix <> pprName' Infix n <+> pprType opPrec y)
instance Ppr Type where
- ppr (ForallT tvars ctxt ty) = sep [pprForall tvars ctxt, ppr ty]
- ppr (ForallVisT tvars ty) = sep [pprForallVis tvars [], ppr ty]
- ppr ty = pprTyApp (split ty)
- -- Works, in a degenerate way, for SigT, and puts parens round (ty :: kind)
- -- See Note [Pretty-printing kind signatures]
+ ppr = pprType noPrec
instance Ppr TypeArg where
ppr (TANormal ty) = parensIf (isStarT ty) (ppr ty)
ppr (TyArg ki) = char '@' <> parensIf (isStarT ki) (ppr ki)
@@ -866,38 +871,40 @@ parens around it. E.g. the parens are required here:
type instance F Int = (Bool :: *)
So we always print a SigT with parens (see #10050). -}
-pprTyApp :: (Type, [TypeArg]) -> Doc
-pprTyApp (MulArrowT, [TANormal (PromotedT c), TANormal arg1, TANormal arg2])
- | c == oneName = sep [pprFunArgType arg1 <+> text "%1 ->", ppr arg2]
- | c == manyName = sep [pprFunArgType arg1 <+> text "->", ppr arg2]
-pprTyApp (MulArrowT, [TANormal argm, TANormal arg1, TANormal arg2]) =
- sep [pprFunArgType arg1 <+> text "%" <> ppr argm <+> text "->", ppr arg2]
-pprTyApp (ArrowT, [TANormal arg1, TANormal arg2]) = sep [pprFunArgType arg1 <+> text "->", ppr arg2]
-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)
+pprTyApp :: Precedence -> (Type, [TypeArg]) -> Doc
+pprTyApp p app@(MulArrowT, [TANormal (PromotedT c), TANormal arg1, TANormal arg2])
+ | p >= funPrec = parens (pprTyApp noPrec app)
+ | c == oneName = sep [pprFunArgType arg1 <+> text "%1 ->", pprType qualPrec arg2]
+ | c == manyName = sep [pprFunArgType arg1 <+> text "->", pprType qualPrec arg2]
+pprTyApp p (MulArrowT, [TANormal argm, TANormal arg1, TANormal arg2]) =
+ parensIf (p >= funPrec) $
+ sep [pprFunArgType arg1 <+> text "%" <> pprType appPrec argm <+> text "->",
+ pprType qualPrec arg2]
+pprTyApp p (ArrowT, [TANormal arg1, TANormal arg2]) =
+ parensIf (p >= funPrec) $
+ sep [pprFunArgType arg1 <+> text "->", pprType qualPrec arg2]
+pprTyApp p (EqualityT, [TANormal arg1, TANormal arg2]) =
+ parensIf (p >= opPrec) $
+ sep [pprType opPrec arg1 <+> text "~", pprType opPrec arg2]
+pprTyApp _ (ListT, [TANormal arg]) = brackets (pprType noPrec arg)
+pprTyApp p (TupleT 1, args) = pprTyApp p (ConT (tupleTypeName 1), args)
+pprTyApp _ (TupleT n, args)
| length args == n, Just args' <- traverse fromTANormal args
= parens (commaSep args')
-pprTyApp (PromotedTupleT n, args)
+pprTyApp p (PromotedTupleT 1, args) = pprTyApp p (PromotedT (tupleDataName 1), args)
+pprTyApp _ (PromotedTupleT n, args)
| length args == n, Just args' <- traverse fromTANormal args
= quoteParens (commaSep args')
-pprTyApp (fun, args) = pprParendType fun <+> sep (map pprParendTypeArg args)
+pprTyApp p (fun, args) =
+ parensIf (p >= appPrec) $ 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)
-pprFunArgType ty@(ForallVisT {}) = parens (ppr ty)
-pprFunArgType ty@(((MulArrowT `AppT` _) `AppT` _) `AppT` _) = parens (ppr ty)
-pprFunArgType ty@((ArrowT `AppT` _) `AppT` _) = parens (ppr ty)
-pprFunArgType ty@(SigT _ _) = parens (ppr ty)
-pprFunArgType ty = ppr ty
+-- Print the type to the left of @->@. Everything except forall and (->) binds more tightly than (->).
+pprFunArgType :: Type -> Doc
+pprFunArgType = pprType funPrec
data ForallVisFlag = ForallVis -- forall a -> {...}
| ForallInvis -- forall a. {...}
=====================================
libraries/template-haskell/changelog.md
=====================================
@@ -1,5 +1,10 @@
# Changelog for [`template-haskell` package](http://hackage.haskell.org/package/template-haskell)
+## 2.20.0.0
+
+ * The `Ppr.pprInfixT` function has gained a `Precedence` argument.
+ * The values of named precedence levels like `Ppr.appPrec` have changed.
+
## 2.19.0.0
* Add `DefaultD` constructor to support Haskell `default` declarations.
=====================================
testsuite/tests/th/T15845.stderr
=====================================
@@ -1,5 +1,5 @@
data family T15845.F1 (a_0 :: *) (b_1 :: *) :: *
-data instance forall (a_2 :: *) (b_3 :: *). T15845.F1 ([a_2]) b_3
+data instance forall (a_2 :: *) (b_3 :: *). T15845.F1 [a_2] b_3
= T15845.MkF1
data family T15845.F2 (a_0 :: *) :: *
data instance forall (a_1 :: *). T15845.F2 a_1 = T15845.MkF2
=====================================
testsuite/tests/th/T21723.hs
=====================================
@@ -0,0 +1,8 @@
+module Main where
+
+import Language.Haskell.TH
+
+main :: IO ()
+main = do
+ putStrLn $ pprint (InfixT (ArrowT `AppT` StarT `AppT` StarT) (mkName ":>:") StarT)
+ putStrLn $ pprint (InfixT (ParensT $ ArrowT `AppT` StarT `AppT` StarT) (mkName ":>:") StarT)
=====================================
testsuite/tests/th/T21723.stdout
=====================================
@@ -0,0 +1,2 @@
+(* -> *) :>: *
+(* -> *) :>: *
=====================================
testsuite/tests/th/T21942.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE LinearTypes, TemplateHaskell #-}
+
+module Main where
+
+import Language.Haskell.TH
+
+main :: IO ()
+main = runQ [t| forall a m n. a %(m n) -> a |] >>= putStrLn . pprint
=====================================
testsuite/tests/th/T21942.stdout
=====================================
@@ -0,0 +1 @@
+forall a_0 m_1 n_2 . a_0 %(m_1 n_2) -> a_0
=====================================
testsuite/tests/th/T9262.stderr
=====================================
@@ -1 +1 @@
-instance GHC.Classes.Eq a_0 => GHC.Classes.Eq ([a_0])
+instance GHC.Classes.Eq a_0 => GHC.Classes.Eq [a_0]
=====================================
testsuite/tests/th/TH_reifyExplicitForAllFams.stderr
=====================================
@@ -3,13 +3,13 @@ data instance forall (a_1 :: *). TH_reifyExplicitForAllFams.F (GHC.Maybe.Maybe a
= TH_reifyExplicitForAllFams.MkF a_1
class TH_reifyExplicitForAllFams.C (a_0 :: *)
where {type TH_reifyExplicitForAllFams.G (a_0 :: *) (b_1 :: *) :: *}
-instance TH_reifyExplicitForAllFams.C ([a_2])
+instance TH_reifyExplicitForAllFams.C [a_2]
type family TH_reifyExplicitForAllFams.G (a_0 :: *) (b_1 :: *) :: *
type instance forall (a_2 :: *)
- (b_3 :: *). TH_reifyExplicitForAllFams.G ([a_2])
+ (b_3 :: *). TH_reifyExplicitForAllFams.G [a_2]
b_3 = Data.Proxy.Proxy b_3
type family TH_reifyExplicitForAllFams.H (a_0 :: *) (b_1 :: *) :: * where
- forall (x_2 :: *) (y_3 :: *). TH_reifyExplicitForAllFams.H ([x_2])
+ forall (x_2 :: *) (y_3 :: *). TH_reifyExplicitForAllFams.H [x_2]
(Data.Proxy.Proxy y_3) = Data.Either.Either x_2
y_3
forall (z_4 :: *). TH_reifyExplicitForAllFams.H z_4
=====================================
testsuite/tests/th/TH_unresolvedInfix.stdout
=====================================
@@ -44,5 +44,5 @@ N :+ (N :+ N :+ N)
(N)
N :+ (N :+ N :+ N)
(N)
-(Int + (Int + Int + Int))
-Int
+Int + (Int + (Int + Int))
+(Int)
=====================================
testsuite/tests/th/all.T
=====================================
@@ -553,3 +553,5 @@ test('T20711', normal, compile_and_run, [''])
test('T20868', normal, compile_and_run, [''])
test('Lift_ByteArray', normal, compile_and_run, [''])
test('T21920', normal, compile_and_run, [''])
+test('T21723', normal, compile_and_run, [''])
+test('T21942', normal, compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fb7c2d99f7df880b00b0d31ee7436c6d8eb3ba15...c96552517acc55ba307add250d499d97dc203677
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/fb7c2d99f7df880b00b0d31ee7436c6d8eb3ba15...c96552517acc55ba307add250d499d97dc203677
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20220822/27bd7c11/attachment-0001.html>
More information about the ghc-commits
mailing list