Do not reassociate lexical negation (#19838)

3 files changed, 26 insertions, 8 deletions

diff --git a/compiler/GHC/Rename/Expr.hs b/compiler/GHC/Rename/Expr.hs
index a85103d8ed..d6805c2b05 100644
--- a/compiler/GHC/Rename/Expr.hs
+++ b/compiler/GHC/Rename/Expr.hs
@@ -294,7 +294,10 @@ rnExpr (OpApp _ e1 op e2)
               _ -> return (Fixity NoSourceText minPrecedence InfixL)
                    -- c.f. lookupFixity for unbound
 
-        ; final_e <- mkOpAppRn e1' op' fixity e2'
+        ; lexical_negation <- xoptM LangExt.LexicalNegation
+        ; let negation_handling | lexical_negation = KeepNegationIntact
+                                | otherwise = ReassociateNegation
+        ; final_e <- mkOpAppRn negation_handling e1' op' fixity e2'
         ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
 
 rnExpr (NegApp _ e _)
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index ea4ac365b1..d26a886d11 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -24,6 +24,7 @@ module GHC.Rename.HsType (
         rnScaledLHsType,
 
         -- Precence related stuff
+        NegationHandling(..),
         mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
         checkPrecMatch, checkSectionPrec,
 
@@ -1342,20 +1343,21 @@ mk_hs_op_ty op1 fix1 ty1 op2 fix2 ty21 ty22 loc2
 
 
 ---------------------------
-mkOpAppRn :: LHsExpr GhcRn             -- Left operand; already rearranged
+mkOpAppRn :: NegationHandling
+          -> LHsExpr GhcRn             -- Left operand; already rearranged
           -> LHsExpr GhcRn -> Fixity   -- Operator and fixity
           -> LHsExpr GhcRn             -- Right operand (not an OpApp, but might
                                        -- be a NegApp)
           -> RnM (HsExpr GhcRn)
 
 -- (e11 `op1` e12) `op2` e2
-mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2
+mkOpAppRn negation_handling e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2
   | nofix_error
   = do precParseErr (get_op op1,fix1) (get_op op2,fix2)
        return (OpApp fix2 e1 op2 e2)
 
   | associate_right = do
-    new_e <- mkOpAppRn e12 op2 fix2 e2
+    new_e <- mkOpAppRn negation_handling e12 op2 fix2 e2
     return (OpApp fix1 e11 op1 (L loc' new_e))
   where
     loc'= combineLocsA e12 e2
@@ -1363,13 +1365,13 @@ mkOpAppRn e1@(L _ (OpApp fix1 e11 op1 e12)) op2 fix2 e2
 
 ---------------------------
 --      (- neg_arg) `op` e2
-mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2
+mkOpAppRn ReassociateNegation e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2
   | nofix_error
   = do precParseErr (NegateOp,negateFixity) (get_op op2,fix2)
        return (OpApp fix2 e1 op2 e2)
 
   | associate_right
-  = do new_e <- mkOpAppRn neg_arg op2 fix2 e2
+  = do new_e <- mkOpAppRn ReassociateNegation neg_arg op2 fix2 e2
        return (NegApp noExtField (L loc' new_e) neg_name)
   where
     loc' = combineLocsA neg_arg e2
@@ -1377,7 +1379,7 @@ mkOpAppRn e1@(L _ (NegApp _ neg_arg neg_name)) op2 fix2 e2
 
 ---------------------------
 --      e1 `op` - neg_arg
-mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right
+mkOpAppRn ReassociateNegation e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right
   | not associate_right                        -- We *want* right association
   = do precParseErr (get_op op1, fix1) (NegateOp, negateFixity)
        return (OpApp fix1 e1 op1 e2)
@@ -1386,11 +1388,13 @@ mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp {})) -- NegApp can occur on the right
 
 ---------------------------
 --      Default case
-mkOpAppRn e1 op fix e2                  -- Default case, no rearrangment
+mkOpAppRn _ e1 op fix e2                  -- Default case, no rearrangment
   = assertPpr (right_op_ok fix (unLoc e2))
               (ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2) $
     return (OpApp fix e1 op e2)
 
+data NegationHandling = ReassociateNegation | KeepNegationIntact
+
 ----------------------------
 
 -- | Name of an operator in an operator application or section
diff --git a/testsuite/tests/parser/should_compile/LexicalNegation.hs b/testsuite/tests/parser/should_compile/LexicalNegation.hs
index e3e3491aed..0c12da23be 100644
--- a/testsuite/tests/parser/should_compile/LexicalNegation.hs
+++ b/testsuite/tests/parser/should_compile/LexicalNegation.hs
@@ -2,6 +2,8 @@
 
 module LexicalNegation where
 
+import Data.Ratio
+
 x :: Int
 x = 42
 
@@ -13,3 +15,12 @@ subx = (- x)
 
 assertion1 :: Bool
 assertion1 = (- x) -x  ==  -(2*x)
+
+bug19838 :: Rational
+bug19838 = a % -b  where  a = 4; b = 6
+
+infixr 6 +!   -- NB: (non-lexical) negation is infixl 6
+(+!) = (+)
+
+rfix :: Int
+rfix = -x +! 2