Add Semigroup/Monoid for Q (#18123)

4 files changed, 25 insertions, 0 deletions

diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 60fb9d37ca..d994aa686d 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -33,6 +33,7 @@ import Data.IORef
 import System.IO.Unsafe ( unsafePerformIO )
 import Control.Monad (liftM)
 import Control.Monad.IO.Class (MonadIO (..))
+import Control.Applicative (liftA2)
 import System.IO        ( hPutStrLn, stderr )
 import Data.Char        ( isAlpha, isAlphaNum, isUpper, ord )
 import Data.Int
@@ -206,6 +207,14 @@ instance Applicative Q where
   Q f <*> Q x = Q (f <*> x)
   Q m *> Q n = Q (m *> n)
 
+-- | @since 2.17.0.0
+instance Semigroup a => Semigroup (Q a) where
+  (<>) = liftA2 (<>)
+
+-- | @since 2.17.0.0
+instance Monoid a => Monoid (Q a) where
+  mempty = pure mempty
+
 -----------------------------------------------------
 --
 --              The Quote class
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index 55aab10c0d..24a74e4616 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -22,6 +22,8 @@
   * Fix Show instance for `Bytes`: we were showing the pointer value while we
     want to show the contents (#16457).
 
+  * Add `Semigroup` and `Monoid` instances for `Q` (#18123).
+
 ## 2.16.0.0 *TBA*
 
   * Add support for tuple sections. (#15843) The type signatures of `TupE` and
diff --git a/testsuite/tests/th/T18123.hs b/testsuite/tests/th/T18123.hs
new file mode 100644
index 0000000000..e705ec4480
--- /dev/null
+++ b/testsuite/tests/th/T18123.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE TemplateHaskell, StandaloneDeriving #-}
+module T18123 where
+
+import Language.Haskell.TH
+
+data Point = MkPoint { _x, _y :: Double }
+data Rect = MkRect { _p1, _p2 :: Point }
+
+let
+    deriveEq :: Name -> DecsQ
+    deriveEq name = [d| deriving instance Eq $(conT name) |]
+ in
+    foldMap deriveEq [ ''Point, ''Rect ]
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index af0774d0a9..83844ad396 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -507,3 +507,4 @@ test('TH_PprStar', normal, compile, ['-v0 -dsuppress-uniques'])
 test('TH_StringLift', normal, compile, [''])
 test('TH_BytesShowEqOrd', normal, compile_and_run, [''])
 test('T18121', normal, compile, [''])
+test('T18123', normal, compile, [''])