Generalize liftData to work over any Quote (#17857)wip/T17857

The Overloaded Quotations proposal generalized the type of `lift`
to work over any `Quote`, but not the type of `liftData`, leading
to #17857. Thankfully, generalizing `liftData` is extremely
straightforward.

Fixes #17857.

5 files changed, 42 insertions, 26 deletions

diff --git a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
index 18300c2d46..f81c92f38d 100644
--- a/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
+++ b/libraries/template-haskell/Language/Haskell/TH/Syntax.hs
@@ -1074,13 +1074,13 @@ nonemptyName = mkNameG DataName "base" "GHC.Base" ":|"
 -- expressions and patterns; @antiQ@ allows you to override type-specific
 -- cases, a common usage is just @const Nothing@, which results in
 -- no overloading.
-dataToQa  ::  forall a k q. Data a
+dataToQa  ::  forall m a k q. (Quote m, Data a)
           =>  (Name -> k)
-          ->  (Lit -> Q q)
-          ->  (k -> [Q q] -> Q q)
-          ->  (forall b . Data b => b -> Maybe (Q q))
+          ->  (Lit -> m q)
+          ->  (k -> [m q] -> m q)
+          ->  (forall b . Data b => b -> Maybe (m q))
           ->  a
-          ->  Q q
+          ->  m q
 dataToQa mkCon mkLit appCon antiQ t =
     case antiQ t of
       Nothing ->
@@ -1117,7 +1117,7 @@ dataToQa mkCon mkLit appCon antiQ t =
                     tyconPkg = tyConPackage tycon
                     tyconMod = tyConModule  tycon
 
-                conArgs :: [Q q]
+                conArgs :: [m q]
                 conArgs = gmapQ (dataToQa mkCon mkLit appCon antiQ) t
             IntConstr n ->
                 mkLit $ IntegerL n
@@ -1159,14 +1159,14 @@ function.  Two complications
   "pack" is defined in a different module than the data type "Text".
   -}
 
--- | 'dataToExpQ' converts a value to a 'Q Exp' representation of the
+-- | 'dataToExpQ' converts a value to a 'Exp' representation of the
 -- same value, in the SYB style. It is generalized to take a function
 -- override type-specific cases; see 'liftData' for a more commonly
 -- used variant.
-dataToExpQ  ::  Data a
-            =>  (forall b . Data b => b -> Maybe (Q Exp))
+dataToExpQ  ::  (Quote m, Data a)
+            =>  (forall b . Data b => b -> Maybe (m Exp))
             ->  a
-            ->  Q Exp
+            ->  m Exp
 dataToExpQ = dataToQa varOrConE litE (foldl appE)
     where
           -- Make sure that VarE is used if the Constr value relies on a
@@ -1176,23 +1176,23 @@ dataToExpQ = dataToQa varOrConE litE (foldl appE)
             case nameSpace s of
                  Just VarName  -> return (VarE s)
                  Just DataName -> return (ConE s)
-                 _ -> fail $ "Can't construct an expression from name "
-                          ++ showName s
+                 _ -> error $ "Can't construct an expression from name "
+                           ++ showName s
           appE x y = do { a <- x; b <- y; return (AppE a b)}
           litE c = return (LitE c)
 
 -- | 'liftData' is a variant of 'lift' in the 'Lift' type class which
 -- works for any type with a 'Data' instance.
-liftData :: Data a => a -> Q Exp
+liftData :: (Quote m, Data a) => a -> m Exp
 liftData = dataToExpQ (const Nothing)
 
--- | 'dataToPatQ' converts a value to a 'Q Pat' representation of the same
+-- | 'dataToPatQ' converts a value to a 'Pat' representation of the same
 -- value, in the SYB style. It takes a function to handle type-specific cases,
 -- alternatively, pass @const Nothing@ to get default behavior.
-dataToPatQ  ::  Data a
-            =>  (forall b . Data b => b -> Maybe (Q Pat))
+dataToPatQ  ::  (Quote m, Data a)
+            =>  (forall b . Data b => b -> Maybe (m Pat))
             ->  a
-            ->  Q Pat
+            ->  m Pat
 dataToPatQ = dataToQa id litP conP
     where litP l = return (LitP l)
           conP n ps =
@@ -1200,8 +1200,8 @@ dataToPatQ = dataToQa id litP conP
                 Just DataName -> do
                     ps' <- sequence ps
                     return (ConP n ps')
-                _ -> fail $ "Can't construct a pattern from name "
-                         ++ showName n
+                _ -> error $ "Can't construct a pattern from name "
+                          ++ showName n
 
 -----------------------------------------------------
 --              Names and uniques
diff --git a/libraries/template-haskell/changelog.md b/libraries/template-haskell/changelog.md
index a6d6307b7e..0b5fb2c10c 100644
--- a/libraries/template-haskell/changelog.md
+++ b/libraries/template-haskell/changelog.md
@@ -3,11 +3,12 @@
 ## 2.17.0.0
 
   * Implement Overloaded Quotations (GHC Proposal #246). This patch modifies a
-     few fundamental things in the API. All the library combinators are generalised
-     to be in terms of a new minimal class `Quote`. The type of `lift` and `liftTyped`
-     are modified to return `m Exp` rather than `Q Exp`. Instances written in terms
-     of `Q` are now disallowed. The types of `unsafeTExpCoerce` and `unTypeQ`
-     are also generalised in terms of `Quote` rather than specific to `Q`.
+    few fundamental things in the API. All the library combinators are generalised
+    to be in terms of a new minimal class `Quote`. The types of `lift`, `liftTyped`,
+    and `liftData` are modified to return `m Exp` rather than `Q Exp`. Instances
+    written in terms of `Q` are now disallowed. The types of `unsafeTExpCoerce`
+    and `unTypeQ` are also generalised in terms of `Quote` rather than specific
+    to `Q`.
 
 ## 2.16.0.0 *TBA*
 
diff --git a/testsuite/tests/quotes/T17857.hs b/testsuite/tests/quotes/T17857.hs
new file mode 100644
index 0000000000..f64f0ce753
--- /dev/null
+++ b/testsuite/tests/quotes/T17857.hs
@@ -0,0 +1,10 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+module T17857 where
+
+import Data.Data
+import Language.Haskell.TH.Syntax
+
+data T = MkT deriving Data
+instance Lift T where
+  lift = liftData
+  liftTyped = unsafeTExpCoerce . lift
diff --git a/testsuite/tests/quotes/all.T b/testsuite/tests/quotes/all.T
index 46f53bce6a..1a5d5242b4 100644
--- a/testsuite/tests/quotes/all.T
+++ b/testsuite/tests/quotes/all.T
@@ -16,6 +16,7 @@ test('T8759a', normal, compile, ['-v0'])
 test('T9824', normal, compile, ['-v0'])
 test('T10384', normal, compile_fail, [''])
 test('T16384', req_th, compile, [''])
+test('T17857', normal, compile, [''])
 
 test('TH_tf2', normal, compile, ['-v0'])
 test('TH_ppr1', normal, compile_and_run, [''])
diff --git a/testsuite/tests/th/T10796b.stderr b/testsuite/tests/th/T10796b.stderr
index 7c7b89171b..84a03ddc86 100644
--- a/testsuite/tests/th/T10796b.stderr
+++ b/testsuite/tests/th/T10796b.stderr
@@ -1,5 +1,9 @@
 
-T10796b.hs:8:16: error:
-    • Can't construct a pattern from name Data.Set.Internal.fromList
+T10796b.hs:8:15: error:
+    • Exception when trying to run compile-time code:
+        Can't construct a pattern from name Data.Set.Internal.fromList
+CallStack (from HasCallStack):
+  error, called at libraries/template-haskell/Language/Haskell/TH/Syntax.hs:1203:22 in template-haskell:Language.Haskell.TH.Syntax
+      Code: (dataToPatQ (const Nothing) (fromList "test"))
     • In the untyped splice:
         $(dataToPatQ (const Nothing) (fromList "test"))