Don't use implicit lifting when deriving Liftwip/t20688

It isn't much more complicated to be more precise when deriving Lift so
we now generate

```
data Foo = Foo Int Bool

instance Lift Foo where
  lift (Foo a b) = [| Foo $(lift a) $(lift b) |]
  liftTyped (Foo a b) = [|| Foo $$(lift a) $$(lift b) |]
```

This fixes #20688 which complained about using implicit lifting in the
derived code.

4 files changed, 34 insertions, 10 deletions

diff --git a/compiler/GHC/Tc/Deriv/Generate.hs b/compiler/GHC/Tc/Deriv/Generate.hs
index e3856765ec..a061674af9 100644
--- a/compiler/GHC/Tc/Deriv/Generate.hs
+++ b/compiler/GHC/Tc/Deriv/Generate.hs
@@ -1632,11 +1632,14 @@ Example:
     ==>
 
     instance (Lift a) => Lift (Foo a) where
-        lift (Foo a) = [| Foo a |]
-        lift ((:^:) u v) = [| (:^:) u v |]
+        lift (Foo a) = [| Foo $(lift a) |]
+        lift ((:^:) u v) = [| (:^:) $(lift u) $(lift v) |]
 
-        liftTyped (Foo a) = [|| Foo a ||]
-        liftTyped ((:^:) u v) = [|| (:^:) u v ||]
+        liftTyped (Foo a) = [|| Foo $$(liftTyped a) ||]
+        liftTyped ((:^:) u v) = [|| (:^:) $$(liftTyped u) $$(liftTyped v) ||]
+
+Note that we use explicit splices here in order to not trigger the implicit
+lifting warning in derived code. (See #20688)
 -}
 
 
@@ -1646,15 +1649,18 @@ gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon
   (listToBag [lift_bind, liftTyped_bind], emptyBag)
   where
     lift_bind      = mkFunBindEC 1 loc lift_RDR (nlHsApp pure_Expr)
-                                 (map (pats_etc mk_exp) data_cons)
+                                 (map (pats_etc mk_exp mk_usplice liftName) data_cons)
     liftTyped_bind = mkFunBindEC 1 loc liftTyped_RDR (nlHsApp unsafeCodeCoerce_Expr . nlHsApp pure_Expr)
-                                 (map (pats_etc mk_texp) data_cons)
+                                 (map (pats_etc mk_texp mk_tsplice liftTypedName) data_cons)
 
     mk_exp = ExpBr noExtField
     mk_texp = TExpBr noExtField
+
+    mk_usplice = HsUntypedSplice EpAnnNotUsed DollarSplice
+    mk_tsplice = HsTypedSplice EpAnnNotUsed DollarSplice
     data_cons = getPossibleDataCons tycon tycon_args
 
-    pats_etc mk_bracket data_con
+    pats_etc mk_bracket mk_splice lift_name data_con
       = ([con_pat], lift_Expr)
        where
             con_pat      = nlConVarPat data_con_RDR as_needed
@@ -1663,7 +1669,13 @@ gen_Lift_binds loc (DerivInstTys{ dit_rep_tc = tycon
             as_needed    = take con_arity as_RDRs
             lift_Expr    = noLocA (HsBracket noAnn (mk_bracket br_body))
             br_body      = nlHsApps (Exact (dataConName data_con))
-                                    (map nlHsVar as_needed)
+                                    (map lift_var as_needed)
+
+            lift_var :: RdrName -> LHsExpr (GhcPass 'Parsed)
+            lift_var x   = noLocA (HsSpliceE EpAnnNotUsed (mk_splice x (nlHsPar (mk_lift_expr x))))
+
+            mk_lift_expr :: RdrName -> LHsExpr (GhcPass 'Parsed)
+            mk_lift_expr x = nlHsApps (Exact lift_name) [nlHsVar x]
 
 {-
 ************************************************************************
diff --git a/testsuite/tests/deriving/should_compile/T14682.stderr b/testsuite/tests/deriving/should_compile/T14682.stderr
index 1d84be7b50..632af19788 100644
--- a/testsuite/tests/deriving/should_compile/T14682.stderr
+++ b/testsuite/tests/deriving/should_compile/T14682.stderr
@@ -13,11 +13,15 @@ Derived class instances:
   
   instance Language.Haskell.TH.Syntax.Lift T14682.Foo where
     Language.Haskell.TH.Syntax.lift (T14682.Foo a1 a2)
-      = [| T14682.Foo a1 a2 |]
+      = [| T14682.Foo
+             $(Language.Haskell.TH.Syntax.lift a1)
+             $(Language.Haskell.TH.Syntax.lift a2) |]
         pending(rn) [<a2, Language.Haskell.TH.Syntax.lift a2>,
                      <a1, Language.Haskell.TH.Syntax.lift a1>]
     Language.Haskell.TH.Syntax.liftTyped (T14682.Foo a1 a2)
-      = [|| T14682.Foo a1 a2 ||]
+      = [|| T14682.Foo
+              $$(Language.Haskell.TH.Syntax.liftTyped a1)
+              $$(Language.Haskell.TH.Syntax.liftTyped a2) ||]
   
   instance Data.Data.Data T14682.Foo where
     Data.Data.gfoldl k z (T14682.Foo a1 a2)
diff --git a/testsuite/tests/quotes/T20688.hs b/testsuite/tests/quotes/T20688.hs
new file mode 100644
index 0000000000..53d859c4e8
--- /dev/null
+++ b/testsuite/tests/quotes/T20688.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE DeriveLift #-}
+module T20688 where
+
+import Language.Haskell.TH.Syntax
+
+data Foo = Foo Int Bool
+  deriving (Lift, Show)
diff --git a/testsuite/tests/quotes/all.T b/testsuite/tests/quotes/all.T
index 68a13ca5ab..e441811111 100644
--- a/testsuite/tests/quotes/all.T
+++ b/testsuite/tests/quotes/all.T
@@ -38,3 +38,4 @@ test('TH_nested_splice', normal, compile, [''])
 test('TH_top_splice', normal, compile_fail, [''])
 test('TTH_top_splice', normal, compile_fail, [''])
 test('TH_double_splice', normal, compile_fail, [''])
+test('T20688', normal, compile, ['-Wimplicit-lift -Werror'])