[Git][ghc/ghc][master] Fix TH pretty-printer's parenthesization
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Wed Sep 27 21:34:17 UTC 2023
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
b02f8042 by Mario Blažević at 2023-09-27T17:33:28-04:00
Fix TH pretty-printer's parenthesization
This PR Fixes `Language.Haskell.TH.Ppr.pprint` so it correctly emits parentheses where needed.
Fixes #23962, #23968, #23971, and #23986
- - - - -
12 changed files:
- libraries/template-haskell/Language/Haskell/TH/Ppr.hs
- testsuite/tests/th/T11463.stdout
- + testsuite/tests/th/T23962.hs
- + testsuite/tests/th/T23962.stdout
- + testsuite/tests/th/T23968.hs
- + testsuite/tests/th/T23968.stdout
- + testsuite/tests/th/T23971.hs
- + testsuite/tests/th/T23971.stdout
- + testsuite/tests/th/T23986.hs
- + testsuite/tests/th/T23986.stdout
- testsuite/tests/th/TH_PprStar.stderr
- testsuite/tests/th/all.T
Changes:
=====================================
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
=====================================
@@ -407,7 +407,7 @@ ppr_dec isTop (NewtypeD ctxt t xs ksig c decs)
ppr_dec isTop (TypeDataD t xs ksig cs)
= ppr_type_data isTop empty [] (Just t) (hsep (map ppr xs)) ksig cs []
ppr_dec _ (ClassD ctxt c xs fds ds)
- = text "class" <+> pprCxt ctxt <+> ppr c <+> hsep (map ppr xs) <+> ppr fds
+ = text "class" <+> pprCxt ctxt <+> pprName' Applied c <+> hsep (map ppr xs) <+> ppr fds
$$ where_clause ds
ppr_dec _ (InstanceD o ctxt i ds) =
text "instance" <+> maybe empty ppr_overlap o <+> pprCxt ctxt <+> ppr i
@@ -420,7 +420,7 @@ ppr_dec _ (DefaultD tys) =
text "default" <+> parens (sep $ punctuate comma $ map ppr tys)
ppr_dec _ (PragmaD p) = ppr p
ppr_dec isTop (DataFamilyD tc tvs kind)
- = text "data" <+> maybeFamily <+> ppr tc <+> hsep (map ppr tvs) <+> maybeKind
+ = text "data" <+> maybeFamily <+> pprName' Applied tc <+> hsep (map ppr tvs) <+> maybeKind
where
maybeFamily | isTop = text "family"
| otherwise = empty
@@ -552,7 +552,7 @@ ppr_typedef data_or_newtype isTop maybeInst ctxt t argsDoc ksig cs decs
ppr_deriv_clause :: DerivClause -> Doc
ppr_deriv_clause (DerivClause ds ctxt)
= text "deriving" <+> pp_strat_before
- <+> ppr_cxt_preds ctxt
+ <+> ppr_cxt_preds appPrec ctxt
<+> pp_strat_after
where
-- @via@ is unique in that in comes /after/ the class being derived,
@@ -871,11 +871,11 @@ pprInfixT p = \case
instance Ppr Type where
ppr = pprType noPrec
instance Ppr TypeArg where
- ppr (TANormal ty) = parensIf (isStarT ty) (ppr ty)
+ ppr (TANormal ty) = ppr ty
ppr (TyArg ki) = char '@' <> parensIf (isStarT ki) (ppr ki)
pprParendTypeArg :: TypeArg -> Doc
-pprParendTypeArg (TANormal ty) = parensIf (isStarT ty) (pprParendType ty)
+pprParendTypeArg (TANormal ty) = pprParendType ty
pprParendTypeArg (TyArg ki) = char '@' <> parensIf (isStarT ki) (pprParendType ki)
isStarT :: Type -> Bool
@@ -980,14 +980,12 @@ instance Ppr Role where
------------------------------
pprCxt :: Cxt -> Doc
pprCxt [] = empty
-pprCxt ts = ppr_cxt_preds ts <+> text "=>"
-
-ppr_cxt_preds :: Cxt -> Doc
-ppr_cxt_preds [] = empty
-ppr_cxt_preds [t at ImplicitParamT{}] = parens (ppr t)
-ppr_cxt_preds [t at ForallT{}] = parens (ppr t)
-ppr_cxt_preds [t] = ppr t
-ppr_cxt_preds ts = parens (commaSep ts)
+pprCxt ts = ppr_cxt_preds funPrec ts <+> text "=>"
+
+ppr_cxt_preds :: Precedence -> Cxt -> Doc
+ppr_cxt_preds _ [] = text "()"
+ppr_cxt_preds p [t] = pprType p t
+ppr_cxt_preds _ ts = parens (commaSep ts)
------------------------------
instance Ppr Range where
=====================================
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
=====================================
testsuite/tests/th/T23962.hs
=====================================
@@ -0,0 +1,9 @@
+{-# LANGUAGE Haskell2010, KindSignatures, StarIsType, TemplateHaskell #-}
+
+import Data.Typeable (Proxy (Proxy))
+import Language.Haskell.TH (runQ)
+import Language.Haskell.TH.Ppr (pprint)
+
+main =
+ runQ [|typeOf (Proxy :: Proxy *)|]
+ >>= putStrLn . pprint
=====================================
testsuite/tests/th/T23962.stdout
=====================================
@@ -0,0 +1 @@
+typeOf (Data.Proxy.Proxy :: Data.Proxy.Proxy *)
=====================================
testsuite/tests/th/T23968.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE Haskell2010, TemplateHaskell, TypeFamilies, TypeOperators #-}
+
+import Language.Haskell.TH (runQ)
+import Language.Haskell.TH.Ppr (pprint)
+
+main =
+ runQ [d|data family (a + b) c d|]
+ >>= putStrLn . pprint
=====================================
testsuite/tests/th/T23968.stdout
=====================================
@@ -0,0 +1 @@
+data family (+_0) a_1 b_2 c_3 d_4
=====================================
testsuite/tests/th/T23971.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE Haskell2010, MultiParamTypeClasses, TypeOperators, TemplateHaskell #-}
+
+import Language.Haskell.TH (runQ)
+import Language.Haskell.TH.Ppr (pprint)
+
+main =
+ runQ [d|class a ## b|]
+ >>= putStrLn . pprint
=====================================
testsuite/tests/th/T23971.stdout
=====================================
@@ -0,0 +1 @@
+class (##_0) a_1 b_2
=====================================
testsuite/tests/th/T23986.hs
=====================================
@@ -0,0 +1,12 @@
+{-# LANGUAGE Haskell2010, DeriveAnyClass, MultiParamTypeClasses, QuantifiedConstraints, TemplateHaskell #-}
+
+import Control.Monad.Reader (MonadReader)
+import Language.Haskell.TH (runQ)
+import Language.Haskell.TH.Ppr (pprint)
+
+class C a b
+
+main = do
+ runQ [d|data Foo deriving (C a)|] >>= putStrLn . pprint
+ runQ [d|newtype Foo m a = MkFoo (m a) deriving (forall r. MonadReader r)|] >>= putStrLn . pprint
+ runQ [d|class (forall r. MonadReader r m) => MonadReaderPlus m|] >>= putStrLn . pprint
=====================================
testsuite/tests/th/T23986.stdout
=====================================
@@ -0,0 +1,7 @@
+data Foo_0 deriving (Main.C a_1)
+newtype Foo_0 m_1 a_2
+ = MkFoo_3 (m_1 a_2)
+ deriving (forall r_4 . Control.Monad.Reader.Class.MonadReader r_4)
+class (forall r_0 .
+ Control.Monad.Reader.Class.MonadReader r_0
+ m_1) => MonadReaderPlus_2 m_1
=====================================
testsuite/tests/th/TH_PprStar.stderr
=====================================
@@ -1,2 +1,2 @@
(Data.Proxy.Proxy @(*) GHC.Base.String -> *) ->
-Data.Either.Either (*) ((* -> *) -> *)
+Data.Either.Either * ((* -> *) -> *)
=====================================
testsuite/tests/th/all.T
=====================================
@@ -589,3 +589,7 @@ test('T23829_hasty', normal, compile_fail, [''])
test('T23829_hasty_b', normal, compile_fail, [''])
test('T23927', normal, compile_and_run, [''])
test('T23954', normal, compile_and_run, [''])
+test('T23962', normal, compile_and_run, [''])
+test('T23968', normal, compile_and_run, [''])
+test('T23971', normal, compile_and_run, [''])
+test('T23986', normal, compile_and_run, [''])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b02f8042b79305a45b9fd1fd7d4f4ffa59a382dd
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b02f8042b79305a45b9fd1fd7d4f4ffa59a382dd
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/20230927/50eb3dc4/attachment-0001.html>
More information about the ghc-commits
mailing list