From 5b51b2a24cbe69070a2f34efd93de55d807b836b Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Mario=20Bla=C5=BEevi=C4=87?= <blamario@protonmail.com>
Date: Thu, 26 Oct 2023 09:28:33 -0400
Subject: [PATCH] Fix and test for issue #24111, TH.Ppr output of pattern
synonyms
---
.../template-haskell/Language/Haskell/TH/Ppr.hs | 9 +++++----
testsuite/tests/th/T24111.hs | 12 ++++++++++++
testsuite/tests/th/T24111.stdout | 7 +++++++
testsuite/tests/th/all.T | 1 +
4 files changed, 25 insertions(+), 4 deletions(-)
create mode 100644 testsuite/tests/th/T24111.hs
create mode 100644 testsuite/tests/th/T24111.stdout
diff --git a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
index a654cb384303..65be9831770d 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Ppr.hs
@@ -14,7 +14,7 @@ import Language.Haskell.TH.Syntax
import Data.Word ( Word8 )
import Data.Char ( toLower, chr)
import GHC.Show ( showMultiLineString )
-import GHC.Lexeme( startsVarSym )
+import GHC.Lexeme( isVarSymChar )
import Data.Ratio ( numerator, denominator )
import Data.Foldable ( toList )
import Prelude hiding ((<>))
@@ -122,8 +122,8 @@ isSymOcc :: Name -> Bool
isSymOcc n
= case nameBase n of
[] -> True -- Empty name; weird
- (c:_) -> startsVarSym c
- -- c.f. OccName.startsVarSym in GHC itself
+ (c:_) -> isVarSymChar c
+ -- c.f. isVarSymChar in GHC itself
pprInfixExp :: Exp -> Doc
pprInfixExp (VarE v) = pprName' Infix v
@@ -471,7 +471,8 @@ ppr_dec _ (PatSynD name args dir pat)
pprNameArgs | InfixPatSyn a1 a2 <- args = ppr a1 <+> pprName' Infix name <+> ppr a2
| otherwise = pprName' Applied name <+> ppr args
pprPatRHS | ExplBidir cls <- dir = hang (ppr pat <+> text "where")
- nestDepth (pprName' Applied name <+> ppr cls)
+ nestDepth
+ (vcat $ (pprName' Applied name <+>) . ppr <$> cls)
| otherwise = ppr pat
ppr_dec _ (PatSynSigD name ty)
= pprPatSynSig name ty
diff --git a/testsuite/tests/th/T24111.hs b/testsuite/tests/th/T24111.hs
new file mode 100644
index 000000000000..8296f28992e6
--- /dev/null
+++ b/testsuite/tests/th/T24111.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE Haskell2010, PatternSynonyms, TemplateHaskell, ViewPatterns #-}
+
+import Language.Haskell.TH (runQ)
+import Language.Haskell.TH.Ppr (pprint)
+
+main = do
+ runQ [d|pattern (:+) :: Int -> Int -> (Int, Int);
+ pattern x :+ y = (x, y)|] >>= putStrLn . pprint
+ runQ [d|pattern A :: Int -> String;
+ pattern A n <- (read -> n) where {
+ A 0 = "hi";
+ A 1 = "bye"}|] >>= putStrLn . pprint
diff --git a/testsuite/tests/th/T24111.stdout b/testsuite/tests/th/T24111.stdout
new file mode 100644
index 000000000000..1a30bb8fd790
--- /dev/null
+++ b/testsuite/tests/th/T24111.stdout
@@ -0,0 +1,7 @@
+pattern (:+_0) :: GHC.Types.Int ->
+ GHC.Types.Int -> (GHC.Types.Int, GHC.Types.Int)
+pattern x_1 :+_0 y_2 = (x_1, y_2)
+pattern A_0 :: GHC.Types.Int -> GHC.Base.String
+pattern A_0 n_1 <- (Text.Read.read -> n_1) where
+ A_0 0 = "hi"
+ A_0 1 = "bye"
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index cdcdd479798e..7f016b50d4aa 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -597,3 +597,4 @@ test('T23962', normal, compile_and_run, [''])
test('T23968', normal, compile_and_run, [''])
test('T23971', normal, compile_and_run, [''])
test('T23986', normal, compile_and_run, [''])
+test('T24111', normal, compile_and_run, [''])
--
GitLab