Disallow bang/lazy patterns in the RHSes of implicitly bidirectional patsyns

Summary:
GHC was allowing implicitly bidirectional pattern synonyms with bang
patterns and irrefutable patterns in the RHS, like so:

```lang=haskell
pattern StrictJust a = Just !a
```

This has multiple problems:

1. `Just !a` isn't a valid expression, so it feels strange to allow it in an
   implicitly bidirectional pattern synonym.
2. `StrictJust` doesn't provide the strictness properties one would expect
   from a strict constructor. (One could imagine a design where the
   `StrictJust` builder infers a bang pattern for its pattern variable, but
   accomplishing this inference in a way that accounts for all possible
   patterns on the RHS, including other pattern synonyms, is somewhat
   awkward, so we do not pursue this design.)

We nip these issues in the bud by simply disallowing bang/irrefutable patterns
on the RHS.

Test Plan: make test TEST="T14112 unidir"

Reviewers: simonpj, austin, bgamari

Reviewed By: simonpj

Subscribers: rwbarton, thomie

GHC Trac Issues: #14112

Differential Revision: https://phabricator.haskell.org/D3896

7 files changed, 72 insertions, 8 deletions

diff --git a/compiler/typecheck/TcPatSyn.hs b/compiler/typecheck/TcPatSyn.hs
index 67e031aeaa..fe9ad18a92 100644
--- a/compiler/typecheck/TcPatSyn.hs
+++ b/compiler/typecheck/TcPatSyn.hs
@@ -574,7 +574,7 @@ tcPatSynBuilderBind (PSB { psb_id = L loc name, psb_def = lpat
     mb_match_group
        = case dir of
            ExplicitBidirectional explicit_mg -> Right explicit_mg
-           ImplicitBidirectional             -> fmap mk_mg (tcPatToExpr args lpat)
+           ImplicitBidirectional -> fmap mk_mg (tcPatToExpr name args lpat)
            Unidirectional -> panic "tcPatSynBuilderBind"
 
     mk_mg :: LHsExpr GhcRn -> MatchGroup GhcRn (LHsExpr GhcRn)
@@ -621,7 +621,8 @@ add_void need_dummy_arg ty
   | need_dummy_arg = mkFunTy voidPrimTy ty
   | otherwise      = ty
 
-tcPatToExpr :: [Located Name] -> LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)
+tcPatToExpr :: Name -> [Located Name] -> LPat GhcRn
+            -> Either MsgDoc (LHsExpr GhcRn)
 -- Given a /pattern/, return an /expression/ that builds a value
 -- that matches the pattern.  E.g. if the pattern is (Just [x]),
 -- the expression is (Just [x]).  They look the same, but the
@@ -630,7 +631,7 @@ tcPatToExpr :: [Located Name] -> LPat GhcRn -> Either MsgDoc (LHsExpr GhcRn)
 --
 -- Returns (Left r) if the pattern is not invertible, for reason r.
 -- See Note [Builder for a bidirectional pattern synonym]
-tcPatToExpr args pat = go pat
+tcPatToExpr name args pat = go pat
   where
     lhsVars = mkNameSet (map unLoc args)
 
@@ -667,8 +668,6 @@ tcPatToExpr args pat = go pat
         | otherwise
         = Left (quotes (ppr var) <+> text "is not bound by the LHS of the pattern synonym")
     go1 (ParPat pat)                = fmap HsPar $ go pat
-    go1 (LazyPat pat)               = go1 (unLoc pat)
-    go1 (BangPat pat)               = go1 (unLoc pat)
     go1 (PArrPat pats ptt)          = do { exprs <- mapM go pats
                                          ; return $ ExplicitPArr ptt exprs }
     go1 (ListPat pats ptt reb)      = do { exprs <- mapM go pats
@@ -689,7 +688,28 @@ tcPatToExpr args pat = go pat
     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")
+
+    -- The following patterns are not invertible.
+    go1 p@(BangPat {})                     = notInvertible p -- #14112
+    go1 p@(LazyPat {})                     = notInvertible p
+    go1 p@(WildPat {})                     = notInvertible p
+    go1 p@(AsPat {})                       = notInvertible p
+    go1 p@(ViewPat {})                     = notInvertible p
+    go1 p@(NPlusKPat {})                   = notInvertible p
+    go1 p@(SplicePat (HsTypedSplice {}))   = notInvertible p
+    go1 p@(SplicePat (HsUntypedSplice {})) = notInvertible p
+    go1 p@(SplicePat (HsQuasiQuote {}))    = notInvertible p
+
+    notInvertible p = Left $
+          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
+                      <+> ppr pat <+> text "where")
+                   2 (pp_name <+> pp_args <+> equals <+> text "..."))
+      where
+        pp_name = ppr name
+        pp_args = hsep (map ppr args)
 
 {- Note [Builder for a bidirectional pattern synonym]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
diff --git a/docs/users_guide/8.4.1-notes.rst b/docs/users_guide/8.4.1-notes.rst
index 8a6d4048b4..8f61ef86fe 100644
--- a/docs/users_guide/8.4.1-notes.rst
+++ b/docs/users_guide/8.4.1-notes.rst
@@ -27,6 +27,20 @@ Language
   wish to; this is quite like how regular datatypes with a kind signature can omit
   some type variables.
 
+- Implicitly bidirectional pattern synonyms no longer allow bang patterns
+  (``!``) or irrefutable patterns (``~``) on the right-hand side. Previously,
+  this was allowed, although the bang patterns and irrefutable patterns would
+  be silently ignored when used in an expression context. This is now a proper
+  error, and explicitly bidirectional pattern synonyms should be used in their
+  stead. That is, instead of using this (which is an error): ::
+
+      data StrictJust a = Just !a
+
+  Use this: ::
+
+      data StrictJust a <- Just !a where
+        StrictJust !a = Just a
+
 Compiler
 ~~~~~~~~
 
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index 59d5934616..bd11360acc 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -5096,6 +5096,21 @@ We can then use ``HeadC`` in both expression and pattern contexts. In a pattern
 context it will match the head of any list with length at least one. In an
 expression context it will construct a singleton list.
 
+Explicitly bidirectional pattern synonyms offer greater flexibility than
+implicitly bidirectional ones in terms of the syntax that is permitted. For
+instance, the following is not a legal implicitly bidirectional pattern
+synonym: ::
+
+      pattern StrictJust a = Just !a
+
+This is illegal because the use of :ghc-flag:`-XBangPatterns` on the right-hand
+sides prevents it from being a well formed expression. However, constructing a
+strict pattern synonym is quite possible with an explicitly bidirectional
+pattern synonym: ::
+
+      pattern StrictJust a <- Just !a where
+        StrictJust !a = Just a
+
 The table below summarises where each kind of pattern synonym can be used.
 
 +---------------+----------------+---------------+---------------------------+
@@ -7158,7 +7173,7 @@ Unlike with ordinary data definitions, the result kind of a data family
 does not need to be ``*``: it can alternatively be a kind variable
 (with :ghc-flag:`-XPolyKinds`). Data instances' kinds must end in
 ``*``, however.
-    
+
 .. _data-instance-declarations:
 
 Data instance declarations
diff --git a/testsuite/tests/patsyn/should_fail/T14112.hs b/testsuite/tests/patsyn/should_fail/T14112.hs
new file mode 100644
index 0000000000..3e28644480
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/T14112.hs
@@ -0,0 +1,5 @@
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE PatternSynonyms #-}
+module T14112 where
+
+pattern MyJust1 a = Just !a
diff --git a/testsuite/tests/patsyn/should_fail/T14112.stderr b/testsuite/tests/patsyn/should_fail/T14112.stderr
new file mode 100644
index 0000000000..bd0b9543af
--- /dev/null
+++ b/testsuite/tests/patsyn/should_fail/T14112.stderr
@@ -0,0 +1,7 @@
+
+T14112.hs:5:21: error:
+    Invalid right-hand side of bidirectional pattern synonym ‘MyJust1’:
+      Pattern ‘!a’ is not invertible
+      Suggestion: instead use an explicitly bidirectional pattern synonym, e.g.
+        pattern MyJust1 a <- Just !a where MyJust1 a = ...
+    RHS pattern: Just !a
diff --git a/testsuite/tests/patsyn/should_fail/all.T b/testsuite/tests/patsyn/should_fail/all.T
index 92989cf060..8a098d9d1f 100644
--- a/testsuite/tests/patsyn/should_fail/all.T
+++ b/testsuite/tests/patsyn/should_fail/all.T
@@ -36,4 +36,5 @@ test('T12819', normal, compile_fail, [''])
 test('UnliftedPSBind', normal, compile_fail, [''])
 test('T13349', normal, compile_fail, [''])
 test('T13470', normal, compile_fail, [''])
+test('T14112', normal, compile_fail, [''])
 test('T14114', normal, compile_fail, [''])
diff --git a/testsuite/tests/patsyn/should_fail/unidir.stderr b/testsuite/tests/patsyn/should_fail/unidir.stderr
index 39193dffd1..ba3799d201 100644
--- a/testsuite/tests/patsyn/should_fail/unidir.stderr
+++ b/testsuite/tests/patsyn/should_fail/unidir.stderr
@@ -1,5 +1,7 @@
 
 unidir.hs:4:18: error:
     Invalid right-hand side of bidirectional pattern synonym ‘Head’:
-      pattern ‘_’ is not invertible
+      Pattern ‘_’ is not invertible
+      Suggestion: instead use an explicitly bidirectional pattern synonym, e.g.
+        pattern Head x <- x : _ where Head x = ...
     RHS pattern: x : _