Don't return a panic in tcNestedSplice

In GHC.Tc.Gen.Splice.tcNestedSplice we were returning a
typechecked expression of "panic". That is usually OK, because
the result is discarded.  But it happens that tcApp now looks at
the typechecked expression, trivially, to ask if it is tagToEnum.
So being bottom is bad.

Moreover a debug-trace might print it out.

So better to return a civilised expression, even though it is
usually discarded.

4 files changed, 27 insertions, 16 deletions

diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs
index 94341c62c2..fbc6c5ba58 100644
--- a/compiler/GHC/Tc/Gen/Expr.hs
+++ b/compiler/GHC/Tc/Gen/Expr.hs
@@ -981,12 +981,9 @@ tcExpr (HsSpliceE _ (HsSpliced _ mod_finalizers (HsSplicedExpr expr)))
        res_ty
   = do addModFinalizersWithLclEnv mod_finalizers
        tcExpr expr res_ty
-tcExpr (HsSpliceE _ splice)          res_ty
-  = tcSpliceExpr splice res_ty
-tcExpr e@(HsBracket _ brack)         res_ty
-  = tcTypedBracket e brack res_ty
-tcExpr e@(HsRnBracketOut _ brack ps) res_ty
-  = tcUntypedBracket e brack ps res_ty
+tcExpr (HsSpliceE _ splice)          res_ty = tcSpliceExpr splice res_ty
+tcExpr e@(HsBracket _ brack)         res_ty = tcTypedBracket e brack res_ty
+tcExpr e@(HsRnBracketOut _ brack ps) res_ty = tcUntypedBracket e brack ps res_ty
 
 {-
 ************************************************************************
@@ -1219,7 +1216,11 @@ tcApp expr res_ty
   = do { (fun, args, app_res_ty) <- tcInferApp expr
        ; if isTagToEnum fun
          then tcTagToEnum expr fun args app_res_ty res_ty
-         else -- The wildly common case
+              -- Done here because we have res_ty,
+              -- whereas tcInferApp does not
+         else
+
+    -- The wildly common case
     do { let expr' = applyHsArgs fun args
        ; addFunResCtxt True fun app_res_ty res_ty $
          tcWrapResult expr expr' app_res_ty res_ty } }
@@ -1232,10 +1233,10 @@ tcInferApp :: HsExpr GhcRn
 -- Also used by Module.tcRnExpr to implement GHCi :type
 tcInferApp expr
   | -- Gruesome special case for ambiguous record selectors
-    HsRecFld _ fld_lbl   <- fun
-  , Ambiguous _ lbl              <- fld_lbl  -- Still ambiguous
+    HsRecFld _ fld_lbl        <- fun
+  , Ambiguous _ lbl           <- fld_lbl  -- Still ambiguous
   , HsEValArg _ (L _ arg) : _ <- filterOut isArgPar args -- A value arg is first
-  , Just sig_ty <- obviousSig arg  -- A type sig on the arg disambiguates
+  , Just sig_ty               <- obviousSig arg  -- A type sig on the arg disambiguates
   = do { sig_tc_ty <- tcHsSigWcType ExprSigCtxt sig_ty
        ; sel_name  <- disambiguateSelector lbl sig_tc_ty
        ; (tc_fun, fun_ty) <- tcInferRecSelId (Unambiguous sel_name lbl)
@@ -1259,11 +1260,7 @@ tcInferApp_finish
     -> TcM (HsExpr GhcTc, [LHsExprArgOut], TcSigmaType)
 
 tcInferApp_finish rn_fun tc_fun fun_sigma rn_args
-  = do { traceTc "tcInferApp_finish" $
-         vcat [ ppr rn_fun <+> dcolon <+> ppr fun_sigma, ppr rn_args ]
-
-       ; (tc_args, actual_res_ty) <- tcArgs rn_fun fun_sigma rn_args
-
+  = do { (tc_args, actual_res_ty) <- tcArgs rn_fun fun_sigma rn_args
        ; return (tc_fun, tc_args, actual_res_ty) }
 
 mk_op_msg :: LHsExpr GhcRn -> SDoc
diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index f959b85278..99806ff820 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -625,7 +625,13 @@ tcNestedSplice pop_stage (TcPending ps_var lie_var q@(QuoteWrapper _ m_var)) spl
        ; writeMutVar ps_var (PendingTcSplice splice_name expr'' : ps)
 
        -- The returned expression is ignored; it's in the pending splices
-       ; return (panic "tcSpliceExpr") }
+       -- But we still return a plausible expression
+       --   (a) in case we print it in debug messages, and
+       --   (b) because we test whether it is tagToEnum in Tc.Gen.Expr.tcApp
+       ; return (HsSpliceE noExtField $
+                 HsSpliced noExtField (ThModFinalizers []) $
+                 HsSplicedExpr (unLoc expr'')) }
+
 
 tcNestedSplice _ _ splice_name _ _
   = pprPanic "tcNestedSplice: rename stage found" (ppr splice_name)
diff --git a/testsuite/tests/th/T18121.hs b/testsuite/tests/th/T18121.hs
new file mode 100644
index 0000000000..f9efdf378b
--- /dev/null
+++ b/testsuite/tests/th/T18121.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Bug where
+
+import Language.Haskell.TH
+
+sapply :: Q (TExp (a -> b)) -> Q (TExp a) -> Q (TExp b)
+sapply cf cx = [|| $$cf $$cx ||]
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index 8e747cbefa..af0774d0a9 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -506,3 +506,4 @@ test('T18097', normal, compile, [''])
 test('TH_PprStar', normal, compile, ['-v0 -dsuppress-uniques'])
 test('TH_StringLift', normal, compile, [''])
 test('TH_BytesShowEqOrd', normal, compile_and_run, [''])
+test('T18121', normal, compile, [''])