[Git][ghc/ghc][master] Make INLINE pragmas for pattern synonyms work with TH

[Marge Bot (@marge-bot)]

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


Commits:
071139c3 by Ryan Scott at 2023-04-04T11:09:51-04:00
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 changed files:

- compiler/GHC/ThToHs.hs
- + testsuite/tests/th/T23203.hs
- + testsuite/tests/th/T23203.stderr
- testsuite/tests/th/all.T


Changes:

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


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


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


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



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

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/071139c30ab95e6a292bec8ae0dcb6bf2be6308d
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/20230404/508a152b/attachment-0001.html>