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.

4 files changed, 43 insertions, 13 deletions

diff --git a/compiler/GHC/Tc/Gen/App.hs b/compiler/GHC/Tc/Gen/App.hs
index 0db2d804a8..560b3bac7d 100644
--- a/compiler/GHC/Tc/Gen/App.hs
+++ b/compiler/GHC/Tc/Gen/App.hs
@@ -165,18 +165,19 @@ 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
-
-head ::= f             -- HsVar:    variables
-      |  fld           -- HsRecSel: record field selectors
-      |  (expr :: ty)  -- ExprWithTySig: expr with user type sig
-      |  lit           -- HsOverLit: overloaded literals
-      |  other_expr    -- Other expressions
+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              -- HsRecSel: 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,
 any of the constructors in 'app' or 'head'), it invokes tcApp to
@@ -193,7 +194,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.
 
@@ -205,6 +206,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 286eec6e5c..c2a97a5c79 100644
--- a/compiler/GHC/Tc/Gen/Head.hs
+++ b/compiler/GHC/Tc/Gen/Head.hs
@@ -450,6 +450,8 @@ tcInferAppHead_maybe fun args
       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
       _                         -> 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 1e9ece046a..aa953098ce 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -543,3 +543,4 @@ test('T17820e', normal, compile_fail, [''])
 test('T20590', normal, compile, ['-v0 -ddump-splices -dsuppress-uniques'])
 test('T20773', only_ways(['ghci']), ghci_script, ['T20773.script'])
 test('T20884', normal, compile_fail, [''])
+test('T21038', normal, compile, [''])