From eff51e2aca978ebd0ca08345fb1790d70f6bb7c8 Mon Sep 17 00:00:00 2001
From: Simon Peyton Jones <simonpj@microsoft.com>
Date: Fri, 30 Jul 2021 09:38:54 +0100
Subject: Catch type-checker exceptions when splicing

In GHC.Tc.Gen.Splice.tcTopSpliceExpr we were forgetting to
catch exceptions. As a result we missed the kind error
in the unsolved constraints.

This patch has an easy fix, which cures #20179
---
 compiler/GHC/Tc/Gen/Splice.hs    | 14 ++++++++++----
 testsuite/tests/th/T20179.hs     |  7 +++++++
 testsuite/tests/th/T20179.stderr | 10 ++++++++++
 testsuite/tests/th/all.T         |  1 +
 4 files changed, 28 insertions(+), 4 deletions(-)
 create mode 100644 testsuite/tests/th/T20179.hs
 create mode 100644 testsuite/tests/th/T20179.stderr

diff --git a/compiler/GHC/Tc/Gen/Splice.hs b/compiler/GHC/Tc/Gen/Splice.hs
index fcd1474afa..13cd3e71c9 100644
--- a/compiler/GHC/Tc/Gen/Splice.hs
+++ b/compiler/GHC/Tc/Gen/Splice.hs
@@ -754,11 +754,17 @@ tcTopSpliceExpr isTypedSplice tc_action
                    -- is expected (#7276)
     setStage (Splice isTypedSplice) $
     do {    -- Typecheck the expression
-         (expr', wanted) <- captureConstraints tc_action
-       ; const_binds     <- simplifyTop wanted
+         (mb_expr', wanted) <- tryCaptureConstraints tc_action
+             -- If tc_action fails (perhaps because of insoluble constraints)
+             -- we want to capture and report those constraints, else we may
+             -- just get a silent failure (#20179). Hence the 'try' part.
 
-          -- Zonk it and tie the knot of dictionary bindings
-       ; return $ mkHsDictLet (EvBinds const_binds) expr' }
+       ; const_binds <- simplifyTop wanted
+
+       ; case mb_expr' of
+            Nothing    -> failM   -- In this case simplifyTop should have
+                                  -- reported some errors
+            Just expr' -> return $ mkHsDictLet (EvBinds const_binds) expr' }
 
 {-
 ************************************************************************
diff --git a/testsuite/tests/th/T20179.hs b/testsuite/tests/th/T20179.hs
new file mode 100644
index 0000000000..a01f573979
--- /dev/null
+++ b/testsuite/tests/th/T20179.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Bug where
+
+$(let slurmp :: [Maybe]
+      slurmp = []
+
+   in pure [])
diff --git a/testsuite/tests/th/T20179.stderr b/testsuite/tests/th/T20179.stderr
new file mode 100644
index 0000000000..28eb54d698
--- /dev/null
+++ b/testsuite/tests/th/T20179.stderr
@@ -0,0 +1,10 @@
+
+T20179.hs:4:18: error:
+    • Expecting one more argument to ‘Maybe’
+      Expected a type, but ‘Maybe’ has kind ‘* -> *’
+    • In the type signature: slurmp :: [Maybe]
+      In the expression:
+        let
+          slurmp :: [Maybe]
+          slurmp = []
+        in pure []
diff --git a/testsuite/tests/th/all.T b/testsuite/tests/th/all.T
index a19ad09ec9..77ed446d95 100644
--- a/testsuite/tests/th/all.T
+++ b/testsuite/tests/th/all.T
@@ -531,3 +531,4 @@ test('T19470', only_ways(['ghci']), ghci_script, ['T19470.script'])
 test('T19737', normal, compile, [''])
 test('T19759', normal, compile, [''])
 test('T20060', normal, compile, [''])
+test('T20179', normal, compile_fail, [''])
-- 
cgit v1.2.1