diff options
| -rw-r--r-- | compiler/GHC/Tc/Gen/Expr.hs | 27 | ||||
| -rw-r--r-- | compiler/GHC/Tc/Gen/Splice.hs | 8 | ||||
| -rw-r--r-- | testsuite/tests/th/T18121.hs | 7 | ||||
| -rw-r--r-- | testsuite/tests/th/all.T | 1 |
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, ['']) |