Look through untyped TH splices in tcInferAppHead_maybe

Previously, surrounding a head expression with a TH splice would defeat
`tcInferAppHead_maybe`, preventing some expressions from typechecking that
used to typecheck in previous GHC versions (see #21038 for examples). This is
simple enough to fix: just look through `HsSpliceE`s in `tcInferAppHead_maybe`.
I've added some additional prose to `Note [Application chains and heads]` in
`GHC.Tc.Gen.App` to accompany this change.

Fixes #21038.

(cherry picked from commit fd9981e347144ce69f4747bd635789f25b673f93)

4 files changed, 37 insertions, 7 deletions

diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs
index 4f4f53f1cf..a63a058660 100644
--- a/compiler/GHC/Tc/Gen/App.hs
+++ b/compiler/GHC/Tc/Gen/App.hs
@@ -157,17 +157,18 @@ Quick Look treats application chains specially.  What is an
 "application chain"?  See Fig 2, of the QL paper: "A quick look at
 impredicativity" (ICFP'20). Here's the syntax:
 
-app :: head
-     | app expr            -- HsApp: ordinary application
-     | app @type           -- HsTypeApp: VTA
-     | expr `head` expr    -- OpApp: infix applications
-     | ( app )             -- HsPar: parens
-     | {-# PRAGMA #-} app  -- HsPragE: pragmas
+app ::= head
+     |  app expr            -- HsApp: ordinary application
+     |  app @type           -- HsTypeApp: VTA
+     |  expr `head` expr    -- OpApp: infix applications
+     |  ( app )             -- HsPar: parens
+     |  {-# PRAGMA #-} app  -- HsPragE: pragmas
 
 head ::= f             -- HsVar:    variables
       |  fld           -- HsRecFld: record field selectors
       |  (expr :: ty)  -- ExprWithTySig: expr with user type sig
       |  lit           -- HsOverLit: overloaded literals
+      |  $([| head |])    -- HsSpliceE+HsSpliced+HsSplicedExpr: untyped TH expression splices
       |  other_expr    -- Other expressions
 
 When tcExpr sees something that starts an application chain (namely,
@@ -185,7 +186,7 @@ There is no special treatment for HsUnboundVar, HsOverLit etc, because
 we can't get a polytype from them.
 
 Left and right sections (e.g. (x +) and (+ x)) are not yet supported.
-Probably left sections (x +) would be esay to add, since x is the
+Probably left sections (x +) would be easy to add, since x is the
 first arg of (+); but right sections are not so easy.  For symmetry
 reasons I've left both unchanged, in GHC.Tc.Gen.Expr.
 
@@ -197,6 +198,16 @@ Clearly this should work!  But it will /only/ work because if we
 instantiate that (forall b. b) impredicatively!  And that only happens
 in tcApp.
 
+We also wish to typecheck application chains with untyped Template Haskell
+splices in the head, such as this example from #21038:
+    data Foo = MkFoo (forall a. a -> a)
+    f = $([| MkFoo |]) $ \x -> x
+This should typecheck just as if the TH splice was never in the way—that is,
+just as if the user had written `MkFoo $ \x -> x`. We could conceivably have
+a case for typed TH expression splices too, but it wouldn't be useful in
+practice, since the types of typed TH expressions aren't allowed to have
+polymorphic types, such as the type of MkFoo.
+
 Note [tcApp: typechecking applications]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 tcApp implements the APP-Downarrow/Uparrow rule of
diff --git a/compiler/GHC/Tc/Gen/Head.hs b/compiler/GHC/Tc/Gen/Head.hs
index 2a442b3fd9..2310de3ee5 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -418,6 +418,8 @@ tcInferAppHead_maybe fun args mb_res_ty
       ExprWithTySig _ e hs_ty   -> add_head_ctxt fun args $
                                    Just <$> tcExprWithSig e hs_ty
       HsOverLit _ lit           -> Just <$> tcInferOverLit lit
+      HsSpliceE _ (HsSpliced _ _ (HsSplicedExpr e))
+                                -> tcInferAppHead_maybe e args mb_res_ty
       _                         -> return Nothing
 
 add_head_ctxt :: HsExpr GhcRn -> [HsExprArg 'TcpRn] -> TcM a -> TcM a
diff --git a/testsuite/tests/th/T21038.hs b/testsuite/tests/th/T21038.hs
new file mode 100644
index 0000000000..6c080bc86c
--- /dev/null
+++ b/testsuite/tests/th/T21038.hs
@@ -0,0 +1,16 @@
+{-# LANGUAGE TemplateHaskell #-}
+module T21038 where
+
+data Foo = MkFoo (forall a. a -> a)
+
+worksOnAllGHCs1 :: Foo
+worksOnAllGHCs1 = MkFoo (\x -> x)
+
+worksOnAllGHCs2 :: Foo
+worksOnAllGHCs2 = MkFoo $ \x -> x
+
+worksOnAllGHCs3 :: Foo
+worksOnAllGHCs3 = $([| MkFoo |]) (\x -> x)
+
+doesn'tWorkOnGHC9'2'1 :: Foo
+doesn'tWorkOnGHC9'2'1 = $([| MkFoo |]) $ \x -> x
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index e58b5052e8..fb727342cc 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -527,3 +527,4 @@ test('T19759', normal, compile, [''])
 test('T20179', normal, compile_fail, [''])
 test('T20060', normal, compile, [''])
 test('T19470', only_ways(['ghci']), ghci_script, ['T19470.script'])
+test('T21038', normal, compile, [''])