[commit: ghc] master: Allow spliced patterns in pattern synonyms (01db135)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/01db13586a6eab9f66101b01d1b0584f334d5d25/ghc

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

commit 01db13586a6eab9f66101b01d1b0584f334d5d25
Author: Ben Gamari <bgamari.foss at gmail.com>
Date:   Thu May 11 15:46:37 2017 -0400

    Allow spliced patterns in pattern synonyms
    
    This ended up being quite simple.
    
    Reviewers: austin, goldfire, mpickering
    
    Subscribers: rwbarton, shlevy, thomie
    
    GHC Trac Issues: #13688
    
    Differential Revision: https://phabricator.haskell.org/D3571


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

01db13586a6eab9f66101b01d1b0584f334d5d25
 compiler/typecheck/TcPatSyn.hs                   | 15 ++++++++-------
 testsuite/tests/patsyn/should_run/T13688.hs      | 21 +++++++++++++++++++++
 testsuite/tests/patsyn/should_run/T13688.stdout  |  4 ++++
 testsuite/tests/patsyn/should_run/T13688Quasi.hs | 12 ++++++++++++
 testsuite/tests/patsyn/should_run/all.T          |  1 +
 5 files changed, 46 insertions(+), 7 deletions(-)

diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index 97bafa5..4b4b042 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -667,6 +667,9 @@ tcPatToExpr args pat = go pat
     go1 (ConPatOut{})               = panic "ConPatOut in output of renamer"
     go1 (SigPatOut{})               = panic "SigPatOut in output of renamer"
     go1 (CoPat{})                   = panic "CoPat in output of renamer"
+    go1 (SplicePat (HsSpliced _ (HsSplicedPat pat)))
+                                    = go1 pat
+    go1 (SplicePat (HsSpliced{}))   = panic "Invalid splice variety"
     go1 p = Left (text "pattern" <+> quotes (ppr p) <+> text "is not invertible")
 
 {- Note [Builder for a bidirectional pattern synonym]
@@ -771,7 +774,11 @@ tcCheckPatSynPat = go
     go1   NPat{}              = return ()
     go1   (SigPatIn pat _)    = go pat
     go1   (ViewPat _ pat _)   = go pat
-    go1 p at SplicePat{}         = thInPatSynErr p
+    go1   (SplicePat splice)
+      | HsSpliced mod_finalizers (HsSplicedPat pat) <- splice
+                              = do addModFinalizersWithLclEnv mod_finalizers
+                                   go1 pat
+      | otherwise             = panic "non-pattern from spliced thing"
     go1 p at NPlusKPat{}         = nPlusKPatInPatSynErr p
     go1   ConPatOut{}         = panic "ConPatOut in output of renamer"
     go1   SigPatOut{}         = panic "SigPatOut in output of renamer"
@@ -783,12 +790,6 @@ asPatInPatSynErr pat
     hang (text "Pattern synonym definition cannot contain as-patterns (@):")
        2 (ppr pat)
 
-thInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a
-thInPatSynErr pat
-  = failWithTc $
-    hang (text "Pattern synonym definition cannot contain Template Haskell:")
-       2 (ppr pat)
-
 nPlusKPatInPatSynErr :: (OutputableBndrId name) => Pat name -> TcM a
 nPlusKPatInPatSynErr pat
   = failWithTc $
diff --git a/testsuite/tests/patsyn/should_run/T13688.hs b/testsuite/tests/patsyn/should_run/T13688.hs
new file mode 100644
index 0000000..39b19fc
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/T13688.hs
@@ -0,0 +1,21 @@
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE QuasiQuotes #-}
+
+import T13688Quasi
+
+pattern A = [aQuoter|hello world|]
+
+pattern B <- [aQuoter|hello world|]
+  where B = [aQuoter|hello world|]
+
+main :: IO ()
+main = do
+    print A
+    case "hello world" of
+      A -> putStrLn "good"
+      _ -> putStrLn "bad"
+
+    print B
+    case "hello world" of
+      B -> putStrLn "good"
+      _ -> putStrLn "bad"
diff --git a/testsuite/tests/patsyn/should_run/T13688.stdout b/testsuite/tests/patsyn/should_run/T13688.stdout
new file mode 100644
index 0000000..07bd598
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/T13688.stdout
@@ -0,0 +1,4 @@
+"hello world"
+good
+"hello world"
+good
diff --git a/testsuite/tests/patsyn/should_run/T13688Quasi.hs b/testsuite/tests/patsyn/should_run/T13688Quasi.hs
new file mode 100644
index 0000000..4302794
--- /dev/null
+++ b/testsuite/tests/patsyn/should_run/T13688Quasi.hs
@@ -0,0 +1,12 @@
+module T13688Quasi where
+
+import Language.Haskell.TH.Quote
+import Language.Haskell.TH.Syntax
+
+aQuoter :: QuasiQuoter
+aQuoter =
+    QuasiQuoter { quotePat  = return . LitP . StringL
+                , quoteExp  = return . LitE . StringL
+                , quoteType = undefined
+                , quoteDec  = undefined
+                }
diff --git a/testsuite/tests/patsyn/should_run/all.T b/testsuite/tests/patsyn/should_run/all.T
index d98a1ff..1498c1f 100644
--- a/testsuite/tests/patsyn/should_run/all.T
+++ b/testsuite/tests/patsyn/should_run/all.T
@@ -14,3 +14,4 @@ test('records-run', normal, compile_and_run, [''])
 test('ghci', just_ghci, ghci_script, ['ghci.script'])
 test('T11985', just_ghci, ghci_script, ['T11985.script'])
 test('T11224', normal, compile_and_run, [''])
+test('T13688', normal, multimod_compile_and_run, ['T13688', '-v0'])