[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