summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRyan Scott <ryan.gl.scott@gmail.com>2023-04-01 10:20:35 -0400
committerMarge Bot <ben+marge-bot@smart-cactus.org>2023-04-04 11:09:51 -0400
commit071139c30ab95e6a292bec8ae0dcb6bf2be6308d (patch)
tree07d781797008624e1383dc088e659f2f55dda570
parenteed0d9307b3f48b6a2e45dbb246610cf4ab73896 (diff)
downloadhaskell-071139c30ab95e6a292bec8ae0dcb6bf2be6308d.tar.gz
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.
-rw-r--r--compiler/GHC/ThToHs.hs5
-rw-r--r--testsuite/tests/th/T23203.hs30
-rw-r--r--testsuite/tests/th/T23203.stderr28
-rw-r--r--testsuite/tests/th/all.T1
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'])