[commit: ghc] master: HsPat: Assume that no spliced patterns are irrefutable (36e8bcb)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/36e8bcba08446dbc4e7532ef9db5517c13977bf9/ghc

>---------------------------------------------------------------

commit 36e8bcba08446dbc4e7532ef9db5517c13977bf9
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Thu Jul 20 19:24:00 2017 -0400

    HsPat: Assume that no spliced patterns are irrefutable
    
    This is a conservative assumption which will limit some uses of spliced
    patterns, but it fixes #13984.
    
    Test Plan: Validate
    
    Reviewers: RyanGlScott, AaronFriel, austin
    
    Reviewed By: RyanGlScott
    
    Subscribers: rwbarton, thomie
    
    GHC Trac Issues: #13984
    
    Differential Revision: https://phabricator.haskell.org/D3766


>---------------------------------------------------------------

36e8bcba08446dbc4e7532ef9db5517c13977bf9
 compiler/hsSyn/HsPat.hs                            | 16 +++++++---------
 testsuite/tests/typecheck/should_compile/T13984.hs |  9 +++++++++
 testsuite/tests/typecheck/should_compile/all.T     |  1 +
 3 files changed, 17 insertions(+), 9 deletions(-)

diff --git a/compiler/hsSyn/HsPat.hs b/compiler/hsSyn/HsPat.hs
index 93ad9ec..f7d1876 100644
--- a/compiler/hsSyn/HsPat.hs
+++ b/compiler/hsSyn/HsPat.hs
@@ -620,7 +620,7 @@ isIrrefutableHsPat pat
     go1 (SigPatOut pat _)   = go pat
     go1 (TuplePat pats _ _) = all go pats
     go1 (SumPat pat _ _  _) = go pat
-    go1 (ListPat {}) = False
+    go1 (ListPat {})        = False
     go1 (PArrPat {})        = False     -- ?
 
     go1 (ConPatIn {})       = False     -- Conservative
@@ -632,15 +632,13 @@ isIrrefutableHsPat pat
     go1 (ConPatOut{ pat_con = L _ (PatSynCon _pat) })
         = False -- Conservative
 
-    go1 (LitPat {})    = False
-    go1 (NPat {})      = False
-    go1 (NPlusKPat {}) = False
+    go1 (LitPat {})         = False
+    go1 (NPat {})           = False
+    go1 (NPlusKPat {})      = False
 
-    -- Both should be gotten rid of by renamer before
-    -- isIrrefutablePat is called
-    go1 (SplicePat {})     = urk pat
-
-    urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat)
+    -- We conservatively assume that no TH splices are irrefutable
+    -- since we cannot know until the splice is evaluated.
+    go1 (SplicePat {})      = False
 
 hsPatNeedsParens :: Pat a -> Bool
 hsPatNeedsParens (NPlusKPat {})      = True
diff --git a/testsuite/tests/typecheck/should_compile/T13984.hs b/testsuite/tests/typecheck/should_compile/T13984.hs
new file mode 100644
index 0000000..a17e48c
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T13984.hs
@@ -0,0 +1,9 @@
+{-# LANGUAGE TemplateHaskell #-}
+module Panic where
+
+import Language.Haskell.TH
+
+expr :: IO Exp
+expr = runQ $ do
+  name <- newName "foo"
+  [| do $(varP name) <- pure (); pure () |]
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index ee37b9a..2ce4e91 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -570,3 +570,4 @@ test('T13879', normal, compile, [''])
 test('T13881', normal, compile, [''])
 test('T13915a', normal, multimod_compile, ['T13915a', '-v0'])
 test('T13915b', normal, compile, [''])
+test('T13984', normal, compile, [''])