Prohibit RULES changing constructors

Previously, `RULES` like

```
{-# RULES
"JustNothing" forall x . Just x = Nothing
 #-}
```

were allowed. Simon Peyton Jones say this seems to have been a
mistake, that such rules have never been supported intentionally,
and that he doesn't know if they can break in horrible ways.
Furthermore, Ben Gamari and Reid Barton are considering trying to
detect the presence of "static data" that the simplifier doesn't
need to traverse at all. Such rules do not play well with that.
So for now, we ban them altogether. In most cases, it's possible
to work around the ban using hand-written wrapper functions.

Reviewers: austin, simonpj, bgamari

Reviewed By: simonpj, bgamari

Subscribers: thomie

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

9 files changed, 50 insertions, 37 deletions

diff --git a/compiler/deSugar/DsBinds.hs b/compiler/deSugar/DsBinds.hs
index 0b115cb902..0d96692a5d 100644
--- a/compiler/deSugar/DsBinds.hs
+++ b/compiler/deSugar/DsBinds.hs
@@ -837,13 +837,15 @@ decomposeRuleLhs :: [Var] -> CoreExpr -> Either SDoc ([Var], Id, [CoreExpr])
 -- The 'bndrs' are the quantified binders of the rules, but decomposeRuleLhs
 -- may add some extra dictionary binders (see Note [Free dictionaries])
 --
--- Returns Nothing if the LHS isn't of the expected shape
+-- Returns an error message if the LHS isn't of the expected shape
 -- Note [Decomposing the left-hand side of a RULE]
 decomposeRuleLhs orig_bndrs orig_lhs
   | not (null unbound)    -- Check for things unbound on LHS
                           -- See Note [Unused spec binders]
   = Left (vcat (map dead_msg unbound))
-
+  | Var funId <- fun2
+  , Just con <- isDataConId_maybe funId
+  = Left (constructor_msg con) -- See Note [No RULES on datacons]
   | Just (fn_id, args) <- decompose fun2 args2
   , let extra_bndrs = mk_extra_bndrs fn_id args
   = -- pprTrace "decmposeRuleLhs" (vcat [ text "orig_bndrs:" <+> ppr orig_bndrs
@@ -899,6 +901,11 @@ decomposeRuleLhs orig_bndrs orig_lhs
     | Just pred <- evVarPred_maybe bndr = text "constraint" <+> quotes (ppr pred)
     | otherwise                         = text "variable" <+> quotes (ppr bndr)
 
+   constructor_msg con = vcat
+     [ text "A constructor," <+> ppr con <>
+         text ", appears as outermost match in RULE lhs."
+     , text "This rule will be ignored." ]
+
    drop_dicts :: CoreExpr -> CoreExpr
    drop_dicts e
        = wrap_lets needed bnds body
@@ -1087,6 +1094,22 @@ the constraint is unused.  We could bind 'd' to (error "unused")
 but it seems better to reject the program because it's almost certainly
 a mistake.  That's what the isDeadBinder call detects.
 
+Note [No RULES on datacons]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Previously, `RULES` like
+
+    "JustNothing" forall x . Just x = Nothing
+
+were allowed. Simon Peyton Jones says this seems to have been a
+mistake, that such rules have never been supported intentionally,
+and that he doesn't know if they can break in horrible ways.
+Furthermore, Ben Gamari and Reid Barton are considering trying to
+detect the presence of "static data" that the simplifier doesn't
+need to traverse at all. Such rules do not play well with that.
+So for now, we ban them altogether as requested by #13290. See also #7398.
+
+
 ************************************************************************
 *                                                                      *
                 Desugaring evidence
diff --git a/docs/users_guide/8.2.1-notes.rst b/docs/users_guide/8.2.1-notes.rst
index 9a222e6003..b3dd2de93e 100644
--- a/docs/users_guide/8.2.1-notes.rst
+++ b/docs/users_guide/8.2.1-notes.rst
@@ -157,6 +157,16 @@ Compiler
 - The :ghc-flag:`-XExtendedDefaultRules` extension now defaults multi-parameter
   typeclasses. See :ghc-ticket:`12923`.
 
+- GHC now ignores ``RULES`` for data constructors (:ghc-ticket:`13290`).
+  Previously, it accepted::
+
+    "NotAllowed" forall x. Just x = e
+
+  That rule will no longer take effect, and a warning will be issued. ``RULES``
+  may still mention data constructors, but not in the outermost position::
+
+    "StillWorks" forall x. f (Just x) = e
+
 GHCi
 ~~~~
 
diff --git a/docs/users_guide/glasgow_exts.rst b/docs/users_guide/glasgow_exts.rst
index 6ba693547b..205e12a549 100644
--- a/docs/users_guide/glasgow_exts.rst
+++ b/docs/users_guide/glasgow_exts.rst
@@ -13268,9 +13268,11 @@ From a syntactic point of view:
 
        "wrong1"   forall e1 e2.  case True of { True -> e1; False -> e2 } = e1
        "wrong2"   forall f.      f True = True
+       "wrong3"   forall x.      Just x = Nothing
 
    In ``"wrong1"``, the LHS is not an application; in ``"wrong2"``, the
-   LHS has a pattern variable in the head.
+   LHS has a pattern variable in the head. In ``"wrong3"``, the LHS consists
+   of a *constructor*, rather than a *variable*, applied to an argument.
 
 -  A rule does not need to be in the same module as (any of) the
    variables it mentions, though of course they need to be in scope.
diff --git a/testsuite/tests/deSugar/should_compile/T13290.hs b/testsuite/tests/deSugar/should_compile/T13290.hs
new file mode 100644
index 0000000000..9c722258bd
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T13290.hs
@@ -0,0 +1,7 @@
+module T13290 where
+
+data Foo = Bar Int Char | Baz Char
+
+{-# RULES
+"BarBaz" Bar 0 'a' = Baz 'b'
+ #-}
diff --git a/testsuite/tests/deSugar/should_compile/T13290.stderr b/testsuite/tests/deSugar/should_compile/T13290.stderr
new file mode 100644
index 0000000000..dd5bceeb37
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T13290.stderr
@@ -0,0 +1,4 @@
+
+T13290.hs:6:1: warning:
+    A constructor, Bar, appears as outermost match in RULE lhs.
+    This rule will be ignored.
diff --git a/testsuite/tests/deSugar/should_compile/all.T b/testsuite/tests/deSugar/should_compile/all.T
index 24b95a0112..7694fb9de7 100644
--- a/testsuite/tests/deSugar/should_compile/all.T
+++ b/testsuite/tests/deSugar/should_compile/all.T
@@ -96,3 +96,4 @@ test('T12944', normal, compile, [''])
 test('T12950', normal, compile, [''])
 test('T13043', normal, compile, [''])
 test('T13215', normal, compile, [''])
+test('T13290', normal, compile, [''])
diff --git a/testsuite/tests/simplCore/should_run/T12689.hs b/testsuite/tests/simplCore/should_run/T12689.hs
deleted file mode 100644
index 84a5419a40..0000000000
--- a/testsuite/tests/simplCore/should_run/T12689.hs
+++ /dev/null
@@ -1,26 +0,0 @@
-data T1 = MkT1Bad                     | MkT1Good                     deriving Show
-data T2 = MkT2Bad Int                 | MkT2Good Int                 deriving Show
-data T3 = MkT3Bad {-# UNPACK #-} !Int | MkT3Good {-# UNPACK #-} !Int deriving Show
-data T4 = MkT4Bad Int                 | MkT4Good Int                 deriving Show
-data T5 = MkT5Bad {-# UNPACK #-} !Int | MkT5Good {-# UNPACK #-} !Int deriving Show
-
-{-# RULES
-
-"T1"           MkT1Bad   = MkT1Good
-"T2" forall x. MkT2Bad x = MkT2Good x
-"T3" forall x. MkT3Bad x = MkT3Good x
-"T4"           MkT4Bad   = MkT4Good
-"T5"           MkT5Bad   = MkT5Good
-  #-}
-
-app = id
-{-# NOINLINE app #-}
-
-main = do
-  print MkT1Bad
-  print (MkT2Bad 42)
-  print (MkT3Bad 42)
-  print (MkT4Bad 42)
-  print (app MkT4Bad 42)
-  print (MkT5Bad 42)
-  print (app MkT5Bad 42)
diff --git a/testsuite/tests/simplCore/should_run/T12689.stdout b/testsuite/tests/simplCore/should_run/T12689.stdout
deleted file mode 100644
index 7e9baf3ba9..0000000000
--- a/testsuite/tests/simplCore/should_run/T12689.stdout
+++ /dev/null
@@ -1,7 +0,0 @@
-MkT1Good
-MkT2Good 42
-MkT3Good 42
-MkT4Good 42
-MkT4Good 42
-MkT5Good 42
-MkT5Good 42
diff --git a/testsuite/tests/simplCore/should_run/all.T b/testsuite/tests/simplCore/should_run/all.T
index 702d83cd27..9317b8ba9f 100644
--- a/testsuite/tests/simplCore/should_run/all.T
+++ b/testsuite/tests/simplCore/should_run/all.T
@@ -68,7 +68,6 @@ test('T10830', extra_run_opts('+RTS -K100k -RTS'), compile_and_run, [''])
 test('T11172', normal, compile_and_run, [''])
 test('T11731', normal, compile_and_run, ['-fspec-constr'])
 test('T7611', normal, compile_and_run, [''])
-test('T12689', normal, compile_and_run, [''])
 test('T12689broken', expect_broken(12689), compile_and_run, [''])
 test('T12689a', normal, compile_and_run, [''])