[Git][ghc/ghc][master] Fix and test for issue #24111, TH.Ppr output of pattern synonyms

[Marge Bot (@marge-bot)]

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


Commits:
5b51b2a2 by Mario Blažević at 2023-10-28T07:07:33-04:00
Fix and test for issue #24111, TH.Ppr output of pattern synonyms

- - - - -


4 changed files:

- libraries/template-haskell/Language/Haskell/TH/Ppr.hs
- + testsuite/tests/th/T24111.hs
- + testsuite/tests/th/T24111.stdout
- testsuite/tests/th/all.T


Changes:

=====================================
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


=====================================
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


=====================================
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"


=====================================
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, [''])



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/5b51b2a24cbe69070a2f34efd93de55d807b836b
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/20231028/f0934a3d/attachment-0001.html>