From 4d3acbcf4c78636afd79883ad021ed6f7ea92a75 Mon Sep 17 00:00:00 2001
From: Zejun Wu <watashi@fb.com>
Date: Tue, 2 Apr 2024 19:34:35 -0700
Subject: [PATCH] Make renamer to be more flexible with parens in the LHS of
the rules
We used to reject LHS like `(f a) b` in RULES and requires it to be written as
`f a b`. It will be handy to allow both as the expression may be more
readable with extra parens in some cases when infix operator is involved.
Espceially when TemplateHaskell is used, extra parens may be added out of
user's control and result in "valid" rules being rejected and there
are not always ways to workaround it.
Fixes #24621
---
compiler/GHC/Rename/Module.hs | 11 +++++++++++
.../tests/rename/should_compile/T24621_normal.hs | 12 ++++++++++++
testsuite/tests/rename/should_compile/T24621_th.hs | 12 ++++++++++++
testsuite/tests/rename/should_compile/all.T | 2 ++
4 files changed, 37 insertions(+)
create mode 100644 testsuite/tests/rename/should_compile/T24621_normal.hs
create mode 100644 testsuite/tests/rename/should_compile/T24621_th.hs
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index b55cef4e5162..d83e03e89a60 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -1226,6 +1226,15 @@ with LHSs with a complicated desugaring (and hence unlikely to match);
But there are legitimate non-trivial args ei, like sections and
lambdas. So it seems simpler not to check at all, and that is why
check_e is commented out.
+
+Note [Parens on the LHS of a RULE]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+You may think that no one would write
+
+ {-# RULES "foo" (f True) = blah #-}
+
+with the LHS wrapped in parens. But Template Haskell does (#24621)!
+So we should accommodate them.
-}
checkValidRule :: FastString -> [Name] -> LHsExpr GhcRn -> NameSet -> RnM ()
@@ -1253,6 +1262,8 @@ validRuleLhs foralls lhs
check (HsAppType _ e _) = checkl e
check (HsVar _ lv)
| (unLoc lv) `notElem` foralls = Nothing
+ -- See Note [Parens on the LHS of a RULE]
+ check (HsPar _ e) = checkl e
check other = Just other -- Failure
-- Check an argument
diff --git a/testsuite/tests/rename/should_compile/T24621_normal.hs b/testsuite/tests/rename/should_compile/T24621_normal.hs
new file mode 100644
index 000000000000..bc96c8ccf183
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T24621_normal.hs
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-}
+module T24621_normal where
+
+import Data.Function
+
+foo :: a -> a
+foo x = x
+
+{-# RULES "" forall a b c. a * c + b * c = (a + b) * c :: Int #-}
+{-# RULES "." forall f g. (f . g) foo = f (g foo) #-}
+{-# RULES "foo" forall a b. (foo a) b = a b #-}
+{-# RULES "on" forall a b. (flip compare `on` foo) a b = compare b a #-}
diff --git a/testsuite/tests/rename/should_compile/T24621_th.hs b/testsuite/tests/rename/should_compile/T24621_th.hs
new file mode 100644
index 000000000000..80d212754114
--- /dev/null
+++ b/testsuite/tests/rename/should_compile/T24621_th.hs
@@ -0,0 +1,12 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -Wno-inline-rule-shadowing #-}
+module T24621_th where
+
+import Data.Function
+
+foo :: a -> a
+foo x = x
+
+$( [d| {-# RULES "" forall a b c. a * c + b * c = (a + b) * c :: Int #-} |] )
+$( [d| {-# RULES "." forall a b. (.) a b foo = a (b foo) #-} |] )
+$( [d| {-# RULES "foo" forall a b. foo a b = a b #-} |] )
diff --git a/testsuite/tests/rename/should_compile/all.T b/testsuite/tests/rename/should_compile/all.T
index 745335949bb2..86fedd8aedf4 100644
--- a/testsuite/tests/rename/should_compile/all.T
+++ b/testsuite/tests/rename/should_compile/all.T
@@ -223,4 +223,6 @@ test('T22478a', req_th, compile, [''])
test('RecordWildCardDeprecation', normal, multimod_compile, ['RecordWildCardDeprecation', '-Wno-duplicate-exports'])
test('T14032b', normal, compile_and_run, [''])
test('T14032d', normal, compile, [''])
+test('T24621_normal', normal, compile, [''])
+test('T24621_th', req_th, compile, [''])
test('T24732', normal, compile_and_run, ['-package "base(Prelude, Text.Printf as P\')"'])
--
GitLab