diff options
-rw-r--r-- | compiler/GHC/Tc/Deriv/Generate.hs | 28 | ||||
-rw-r--r-- | testsuite/tests/deriving/should_compile/T14682.stderr | 8 | ||||
-rw-r--r-- | testsuite/tests/quotes/T20688.hs | 7 | ||||
-rw-r--r-- | testsuite/tests/quotes/all.T | 1 |
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']) |