[Git][ghc/ghc][master] Improved pretty-printing of unboxed TH sums and tuples, fixes #24997

[Marge Bot (@marge-bot)]

Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
bc1d435e by Mario Blažević at 2024-06-30T00:48:20-04:00
Improved pretty-printing of unboxed TH sums and tuples, fixes #24997

- - - - -


6 changed files:

- libraries/ghc-boot-th/GHC/Internal/TH/Ppr.hs
- testsuite/tests/th/T12403.stdout
- testsuite/tests/th/T12478_4.stderr
- + testsuite/tests/th/T24997.hs
- + testsuite/tests/th/T24997.stdout
- testsuite/tests/th/all.T


Changes:

=====================================
libraries/ghc-boot-th/GHC/Internal/TH/Ppr.hs
=====================================
@@ -12,7 +12,8 @@ import Text.PrettyPrint (render)
 import GHC.Internal.TH.PprLib
 import GHC.Internal.TH.Syntax
 import Data.Word ( Word8 )
-import Data.Char ( toLower, chr)
+import Data.Char ( toLower, chr )
+import Data.List ( intersperse )
 import GHC.Show  ( showMultiLineString )
 import GHC.Lexeme( isVarSymChar )
 import Data.Ratio ( numerator, denominator )
@@ -836,7 +837,7 @@ 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 _ (UnboxedSumT arity)    = hashParens $ hsep $ replicate (arity-1) bar
 pprType _ ArrowT                 = parens (text "->")
 pprType _ MulArrowT              = text "FUN"
 pprType _ ListT                  = text "[]"
@@ -929,6 +930,12 @@ pprTyApp p (PromotedTupleT 1, args) = pprTyApp p (PromotedT (tupleDataName 1), a
 pprTyApp _ (PromotedTupleT n, args)
  | length args == n, Just args' <- traverse fromTANormal args
  = quoteParens (commaSep args')
+pprTyApp _ (UnboxedTupleT n, args)
+ | length args == n, Just args' <- traverse fromTANormal args
+ = hashParens (commaSep args')
+pprTyApp _ (UnboxedSumT n, args)
+ | length args == n, Just args' <- traverse fromTANormal args
+ = hashParens (sep $ intersperse bar $ map ppr args')
 pprTyApp p (fun, args) =
   parensIf (p >= appPrec) $ pprParendType fun <+> sep (map pprParendTypeArg args)
 


=====================================
testsuite/tests/th/T12403.stdout
=====================================
@@ -1 +1 @@
-data Main.T = Main.T ((# , #) GHC.Types.Int GHC.Types.Int)
+data Main.T = Main.T (# GHC.Types.Int, GHC.Types.Int #)


=====================================
testsuite/tests/th/T12478_4.stderr
=====================================
@@ -1,6 +1,6 @@
-
 T12478_4.hs:7:7: error: [GHC-97721]
     • Illegal sum arity: 1
         Sums must have an arity of at least 2
-      When splicing a TH type: (#  #) GHC.Tuple.Unit
+      When splicing a TH type: (# GHC.Tuple.Unit #)
     • In the untyped splice: $(unboxedSumT 1 `appT` conT ''())
+


=====================================
testsuite/tests/th/T24997.hs
=====================================
@@ -0,0 +1,10 @@
+{-# LANGUAGE Haskell2010, TemplateHaskell, UnboxedSums #-}
+
+import Language.Haskell.TH (runQ, Type (UnboxedSumT, UnboxedTupleT))
+import Language.Haskell.TH.Ppr (pprint)
+
+main = do
+  runQ [t| (# Int | Char | Bool #) |] >>= putStrLn . pprint
+  runQ [t| (# Int, Char, Bool #) |] >>= putStrLn . pprint
+  runQ [t| $(pure (UnboxedTupleT 3)) Int Char |] >>= putStrLn . pprint
+  runQ [t| $(pure (UnboxedSumT 3)) Int Char |] >>= putStrLn . pprint


=====================================
testsuite/tests/th/T24997.stdout
=====================================
@@ -0,0 +1,4 @@
+(# GHC.Types.Int | GHC.Types.Char | GHC.Types.Bool #)
+(# GHC.Types.Int, GHC.Types.Char, GHC.Types.Bool #)
+(# ,, #) GHC.Types.Int GHC.Types.Char
+(# | | #) GHC.Types.Int GHC.Types.Char


=====================================
testsuite/tests/th/all.T
=====================================
@@ -616,3 +616,4 @@ test('T24702a', normal, compile, [''])
 test('T24702b', normal, compile, [''])
 test('T24837', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T24911', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T24997', normal, compile_and_run, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bc1d435e399d8376b4e33d5d936424ff76cb686a

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/bc1d435e399d8376b4e33d5d936424ff76cb686a
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/20240630/177c67ff/attachment-0001.html>