[commit: ghc] master: Temporary fix to Trac #14380 (d1eaead)

[git at git.haskell.org]

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

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

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

commit d1eaeadb08c1412c1572124efaf341bdc0976ccb
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Oct 24 11:12:43 2017 +0100

    Temporary fix to Trac #14380
    
    This fix replaces an utterly bogus error message with a decent one,
    rejecting a pattern synonym with a list pattern and rebindable syntax.
    
    Not hard to fix properly, but I'm going to wait for a willing volunteer
    and/or more user pressure.


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

d1eaeadb08c1412c1572124efaf341bdc0976ccb
 compiler/typecheck/TcPatSyn.hs                   | 21 +++++++++++++++++----
 testsuite/tests/patsyn/should_fail/T14380.hs     |  8 ++++++++
 testsuite/tests/patsyn/should_fail/T14380.stderr |  9 +++++++++
 testsuite/tests/patsyn/should_fail/all.T         |  1 +
 4 files changed, 35 insertions(+), 4 deletions(-)

diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index d234fd5..58d1506 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -672,8 +672,10 @@ tcPatToExpr name args pat = go pat
     go1 (ParPat pat)                = fmap HsPar $ go pat
     go1 (PArrPat pats ptt)          = do { exprs <- mapM go pats
                                          ; return $ ExplicitPArr ptt exprs }
-    go1 (ListPat pats ptt reb)      = do { exprs <- mapM go pats
-                                         ; return $ ExplicitList ptt (fmap snd reb) exprs }
+    go1 p@(ListPat pats ptt reb)
+      | Nothing <- reb              = do { exprs <- mapM go pats
+                                         ; return $ ExplicitList ptt Nothing exprs }
+      | otherwise                   = notInvertibleListPat p
     go1 (TuplePat pats box _)       = do { exprs <- mapM go pats
                                          ; return $ ExplicitTuple
                                               (map (noLoc . Present) exprs) box }
@@ -702,8 +704,10 @@ tcPatToExpr name args pat = go pat
     go1 p@(SplicePat (HsUntypedSplice {})) = notInvertible p
     go1 p@(SplicePat (HsQuasiQuote {}))    = notInvertible p
 
-    notInvertible p = Left $
-          text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"
+    notInvertible p = Left (not_invertible_msg p)
+
+    not_invertible_msg p
+      =   text "Pattern" <+> quotes (ppr p) <+> text "is not invertible"
       $+$ hang (text "Suggestion: instead use an explicitly bidirectional"
                 <+> text "pattern synonym, e.g.")
              2 (hang (text "pattern" <+> pp_name <+> pp_args <+> larrow
@@ -713,6 +717,15 @@ tcPatToExpr name args pat = go pat
         pp_name = ppr name
         pp_args = hsep (map ppr args)
 
+    -- We should really be able to invert list patterns, even when
+    -- rebindable syntax is on, but doing so involves a bit of
+    -- refactoring; see Trac #14380.  Until then we reject with a
+    -- helpful error message.
+    notInvertibleListPat p
+      = Left (vcat [ not_invertible_msg p
+                   , text "Reason: rebindable syntax is on."
+                   , text "This is fixable: add use-case to Trac #14380" ])
+
 {- Note [Builder for a bidirectional pattern synonym]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
 For a bidirectional pattern synonym we need to produce an /expression/
diff --git a/testsuite/tests/patsyn/should_fail/T14380.hs b/testsuite/tests/patsyn/should_fail/T14380.hs
new file mode 100644
index 0000000..aec3985
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/T14380.hs
@@ -0,0 +1,8 @@
+{-# LANGUAGE OverloadedLists #-}
+{-# LANGUAGE PatternSynonyms #-}
+
+module T14380 where
+
+data Foo = Foo [Int]
+pattern Bar :: Foo
+pattern Bar = Foo []
diff --git a/testsuite/tests/patsyn/should_fail/T14380.stderr b/testsuite/tests/patsyn/should_fail/T14380.stderr
new file mode 100644
index 0000000..4228d29
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/T14380.stderr
@@ -0,0 +1,9 @@
+
+T14380.hs:8:15: error:
+    Invalid right-hand side of bidirectional pattern synonym ‘Bar’:
+      Pattern ‘[]’ is not invertible
+      Suggestion: instead use an explicitly bidirectional pattern synonym, e.g.
+        pattern Bar <- Foo [] where Bar = ...
+      Reason: rebindable syntax is on.
+      This is fixable: add use-case to Trac #14380
+    RHS pattern: Foo []
diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T
index 8a098d9..388e67b 100644
--- a/testsuite/tests/patsyn/should_fail/all.T
+++ b/testsuite/tests/patsyn/should_fail/all.T
@@ -38,3 +38,4 @@ test('T13349', normal, compile_fail, [''])
 test('T13470', normal, compile_fail, [''])
 test('T14112', normal, compile_fail, [''])
 test('T14114', normal, compile_fail, [''])
+test('T14380', normal, compile_fail, [''])