From 3b373838e08e2e2b43fab9f0a008fb60325d31e0 Mon Sep 17 00:00:00 2001
From: Ryan Scott <ryan.gl.scott@gmail.com>
Date: Mon, 7 Aug 2023 13:29:56 -0400
Subject: [PATCH] tcExpr: Push expected types for untyped TH splices inwards
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
In !10911, I deleted a `tcExpr` case for `HsUntypedSplice` in favor of a much
simpler case that simply delegates to `tcApp`. Although this passed the test
suite at the time, this was actually an error, as the previous `tcExpr` case
was critically pushing the expected type inwards. This actually matters for
programs like the one in #23796, which GHC would not accept with type inference
alone—we need full-blown type _checking_ to accept these.
I have added back the previous `tcExpr` case for `HsUntypedSplice` and now
explain why we have two different `HsUntypedSplice` cases (one in `tcExpr` and
another in `splitHsApps`) in `Note [Looking through Template Haskell splices in
splitHsApps]` in `GHC.Tc.Gen.Head`.
Fixes #23796.
---
compiler/GHC/Tc/Gen/Expr.hs | 14 ++++++++++++--
compiler/GHC/Tc/Gen/Head.hs | 18 ++++++++++++++----
testsuite/tests/th/T23796.hs | 8 ++++++++
testsuite/tests/th/all.T | 1 +
4 files changed, 35 insertions(+), 6 deletions(-)
create mode 100644 testsuite/tests/th/T23796.hs
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index f9a14f087a98..9163cdbdd2d3 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -195,7 +195,6 @@ tcExpr :: HsExpr GhcRn -> ExpRhoType -> TcM (HsExpr GhcTc)
-- - ExprWithTySig (e :: type)
-- - HsRecSel overloaded record fields
-- - HsExpanded renamer expansions
--- - HsUntypedSplice untyped Template Haskell splices
-- - HsOpApp operator applications
-- - HsOverLit overloaded literals
-- These constructors are the union of
@@ -209,7 +208,6 @@ tcExpr e@(HsAppType {}) res_ty = tcApp e res_ty
tcExpr e@(ExprWithTySig {}) res_ty = tcApp e res_ty
tcExpr e@(HsRecSel {}) res_ty = tcApp e res_ty
tcExpr e@(XExpr (HsExpanded {})) res_ty = tcApp e res_ty
-tcExpr e@(HsUntypedSplice {}) res_ty = tcApp e res_ty
tcExpr e@(HsOverLit _ lit) res_ty
= do { mb_res <- tcShortCutLit lit res_ty
@@ -579,6 +577,18 @@ tcExpr (HsTypedSplice ext splice) res_ty = tcTypedSplice ext splice res_ty
tcExpr e@(HsTypedBracket _ body) res_ty = tcTypedBracket e body res_ty
tcExpr e@(HsUntypedBracket ps body) res_ty = tcUntypedBracket e body ps res_ty
+tcExpr (HsUntypedSplice splice _) res_ty
+ -- Since `tcApp` deals with `HsUntypedSplice` (in `splitHsApps`), you might
+ -- wonder why we don't delegate to `tcApp` as we do for `HsVar`, etc.
+ -- (See the initial block of equations for `tcExpr`.) But we can't do this
+ -- for `HsUntypedSplice`; to see why, read Wrinkle (UTS1) in
+ -- Note [Looking through Template Haskell splices in splitHsApps] in
+ -- GHC.Tc.Gen.Head.
+ = case splice of
+ HsUntypedSpliceTop mod_finalizers expr
+ -> do { addModFinalizersWithLclEnv mod_finalizers
+ ; tcExpr expr res_ty }
+ HsUntypedSpliceNested {} -> panic "tcExpr: invalid nested splice"
{-
************************************************************************
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index bf2e8af30ab2..038c842d579e 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -803,10 +803,20 @@ handles both of these. This is easy to accomplish, since all the real work in
handling splices and quasiquotes has already been performed by the renamer by
the time we get to `splitHsApps`.
-`tcExpr`, which typechecks expressions, handles `HsUntypedSplice` by simply
-delegating to `tcApp`, which in turn calls `splitHsApps`. This means that
-`splitHsApps` is the unique part of the code that runs an `HsUntypedSplice`'s
-modFinalizers.
+Wrinkle (UTS1):
+ `tcExpr` has a separate case for `HsUntypedSplice`s that do not occur at the
+ head of an application. This is important to handle programs like this one:
+
+ foo :: (forall a. a -> a) -> b -> b
+ foo = $([| \g x -> g x |])
+
+ Here, it is vital that we push the expected type inwards so that `g` gets the
+ type `forall a. a -> a`, and the `tcExpr` case for `HsUntypedSplice` performs
+ this pushing. Without it, we would instead infer `g` to have type `b -> b`,
+ which isn't sufficiently general. Unfortunately, this does mean that there are
+ two different places in the code where an `HsUntypedSplice`'s modFinalizers can
+ be ran, depending on whether the splice appears at the head of an application
+ or not.
-}
{- *********************************************************************
diff --git a/testsuite/tests/th/T23796.hs b/testsuite/tests/th/T23796.hs
new file mode 100644
index 000000000000..fe9d5fd859a9
--- /dev/null
+++ b/testsuite/tests/th/T23796.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T23796 where
+
+good :: (forall a. a -> a) -> b -> b
+good = \g x -> g x
+
+bad :: (forall a. a -> a) -> b -> b
+bad = $([| \g x -> g x |])
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 5cd0c3572bff..2c169e95fcff 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -582,3 +582,4 @@ test('T22559c', normal, compile_fail, [''])
test('T23525', normal, compile, [''])
test('CodeQ_HKD', normal, compile, [''])
test('T23748', normal, compile, [''])
+test('T23796', normal, compile, [''])
--
GitLab