[Git][ghc/ghc][master] Don't return a panic in tcNestedSplice

[Marge Bot]

 Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC


Commits:
8bdc03d6 by Simon Peyton Jones at 2020-05-04T01:56:59-04:00
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 changed files:

- compiler/GHC/Tc/Gen/Expr.hs
- compiler/GHC/Tc/Gen/Splice.hs
- + testsuite/tests/th/T18121.hs
- testsuite/tests/th/all.T


Changes:

=====================================
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


=====================================
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)


=====================================
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 ||]


=====================================
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, [''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8bdc03d61cb7a2f96887c86bd0b253f7c108fcde

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/8bdc03d61cb7a2f96887c86bd0b253f7c108fcde
You're receiving this email because of your account on gitlab.haskell.org.


-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20200504/31e5eb17/attachment-0001.html>