Make INLINE pragmas for pattern synonyms work with TH

Previously, the code for converting `INLINE <name>` pragmas from TH splices
used `vNameN`, which assumed that `<name>` must live in the variable namespace.
Pattern synonyms, on the other hand, live in the constructor namespace. I've
fixed the issue by switching to `vcNameN` instead, which works for both the
variable and constructor namespaces.

Fixes #23203.

4 files changed, 63 insertions, 1 deletions

diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs
index 991674db34..724f15f602 100644
--- a/compiler/GHC/ThToHs.hs
+++ b/compiler/GHC/ThToHs.hs
@@ -851,7 +851,10 @@ cvt_conv TH.JavaScript = JavaScriptCallConv
 
 cvtPragmaD :: Pragma -> CvtM (Maybe (LHsDecl GhcPs))
 cvtPragmaD (InlineP nm inline rm phases)
-  = do { nm' <- vNameN nm
+  = do { -- NB: Use vcNameN here, which works for both the variable namespace
+         -- (e.g., `INLINE`d functions) and the constructor namespace
+         -- (e.g., `INLINE`d pattern synonyms, cf. #23203)
+         nm' <- vcNameN nm
        ; let dflt = dfltActivation inline
        ; let src TH.NoInline  = "{-# NOINLINE"
              src TH.Inline    = "{-# INLINE"
diff --git a/testsuite/tests/th/T23203.hs b/testsuite/tests/th/T23203.hs
new file mode 100644
index 0000000000..0f8971698d
--- /dev/null
+++ b/testsuite/tests/th/T23203.hs
@@ -0,0 +1,30 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TemplateHaskell #-}
+module T23203 where
+
+import Language.Haskell.TH
+
+data D = MkD Int
+
+$(do let -- The original example from #23203
+         genPat1 :: Q [Dec]
+         genPat1 = sequence [
+             patSynD name (prefixPatSyn []) unidir wildP
+           , pure $ PragmaD $ InlineP name Inline FunLike AllPhases
+           ]
+           where name = mkName "A"
+
+         -- A slightly more complicated example that also puts an INLINE pragma
+         -- on a field name in a record pattern synonym
+         genPat2 :: Q [Dec]
+         genPat2 = sequence [
+             patSynD con_name (recordPatSyn [fld_name]) implBidir (conP 'MkD [varP fld_name])
+           , pure $ PragmaD $ InlineP con_name Inline FunLike AllPhases
+           , pure $ PragmaD $ InlineP fld_name Inline FunLike AllPhases
+           ]
+           where con_name = mkName "P"
+                 fld_name = mkName "fld"
+
+     decs1 <- genPat1
+     decs2 <- genPat2
+     pure (decs1 ++ decs2))
diff --git a/testsuite/tests/th/T23203.stderr b/testsuite/tests/th/T23203.stderr
new file mode 100644
index 0000000000..5f6fb3fa82
--- /dev/null
+++ b/testsuite/tests/th/T23203.stderr
@@ -0,0 +1,28 @@
+T23203.hs:(9,2)-(30,27): Splicing declarations
+    do let genPat1 :: Q [Dec]
+           genPat1
+             = sequence
+                 [patSynD name (prefixPatSyn []) unidir wildP,
+                  pure $ PragmaD $ InlineP name Inline FunLike AllPhases]
+             where
+                 name = mkName "A"
+           genPat2 :: Q [Dec]
+           genPat2
+             = sequence
+                 [patSynD
+                    con_name (recordPatSyn [fld_name]) implBidir
+                    (conP 'MkD [varP fld_name]),
+                  pure $ PragmaD $ InlineP con_name Inline FunLike AllPhases,
+                  pure $ PragmaD $ InlineP fld_name Inline FunLike AllPhases]
+             where
+                 con_name = mkName "P"
+                 fld_name = mkName "fld"
+       decs1 <- genPat1
+       decs2 <- genPat2
+       pure (decs1 ++ decs2)
+  ======>
+    pattern A <- _
+    {-# INLINE A #-}
+    pattern P{fld} = MkD fld
+    {-# INLINE P #-}
+    {-# INLINE fld #-}
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 2b792da6e2..20586f17b8 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -558,3 +558,4 @@ test('T22818', normal, compile, ['-v0'])
 test('T22819', normal, compile, ['-v0'])
 test('TH_fun_par', normal, compile, [''])
 test('T23036', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
+test('T23203', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])