desugar: Look through ticks when warning about possible literal overflow

Enabling `-fhpc` or `-finfo-table-map` would case a tick to end up
between the appliation of `neg` to its argument. This defeated the
special logic which looks for `NegApp ... (HsOverLit` to warn about
possible overflow if a user writes a negative literal (without out
NegativeLiterals) in their code.

Fixes #21701

4 files changed, 46 insertions, 3 deletions

diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 655a9cc37a..06405be8d7 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -1,5 +1,6 @@
 
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE ViewPatterns #-}
 
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns   #-}
 {-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
@@ -66,6 +67,7 @@ import GHC.Utils.Panic
 import GHC.Utils.Panic.Plain
 import GHC.Core.PatSyn
 import Control.Monad
+import GHC.HsToCore.Ticks (stripTicksTopHsExpr)
 
 {-
 ************************************************************************
@@ -280,14 +282,18 @@ dsExpr e@(XExpr ext_expr_tc)
             mkBinaryTickBox ixT ixF e2
           }
 
+-- Strip ticks due to #21701, need to be invariant about warnings we produce whether
+-- this is enabled or not.
 dsExpr (NegApp _ (L loc
-                    (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))
-                neg_expr)
+                    (stripTicksTopHsExpr -> (ts, (HsOverLit _ lit@(OverLit { ol_val = HsIntegral i})))))
+              neg_expr)
   = do { expr' <- putSrcSpanDsA loc $ do
           { warnAboutOverflowedOverLit
+                -- See Note [Checking "negative literals"]
               (lit { ol_val = HsIntegral (negateIntegralLit i) })
           ; dsOverLit lit }
-       ; dsSyntaxExpr neg_expr [expr'] }
+       ;
+       ; dsSyntaxExpr neg_expr [mkTicks ts expr'] }
 
 dsExpr (NegApp _ expr neg_expr)
   = do { expr' <- dsLExpr expr
@@ -307,6 +313,27 @@ dsExpr e@(HsApp _ fun arg)
 dsExpr e@(HsAppType {}) = dsHsWrapped e
 
 {-
+Note [Checking "negative literals"]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+As observed in #13257 it's desirable to warn about overflowing negative literals
+in some situations where the user thinks they are writing a negative literal (ie -1)
+but without `-XNegativeLiterals` enabled.
+
+This catches cases such as (-1 :: Word8) which overflow, because (negate 1 == 255) but
+which we desugar to `negate (fromIntegral 1)`.
+
+Notice it's crucial we still desugar to the correct (negate (fromIntegral ...)) despite
+performing the negation in order to check whether the application of negate will overflow.
+For a user written Integer instance we can't predict the interation of negate and fromIntegral.
+
+Also note that this works for detecting the right result for `-128 :: Int8`.. which is
+in-range for Int8 but the correct result is achieved via two overflows.
+
+negate (fromIntegral 128 :: Int8)
+= negate (-128 :: Int8)
+= -128 :: Int8
+
 Note [Desugaring vars]
 ~~~~~~~~~~~~~~~~~~~~~~
 In one situation we can get a *coercion* variable in a HsVar, namely
diff --git a/compiler/GHC/HsToCore/Ticks.hs b/compiler/GHC/HsToCore/Ticks.hs
index e2925de058..892f74c966 100644
--- a/compiler/GHC/HsToCore/Ticks.hs
+++ b/compiler/GHC/HsToCore/Ticks.hs
@@ -15,6 +15,7 @@ module GHC.HsToCore.Ticks
   , TickishType (..)
   , addTicksToBinds
   , isGoodSrcSpan'
+  , stripTicksTopHsExpr
   ) where
 
 import GHC.Prelude as Prelude
@@ -206,6 +207,14 @@ shouldTickPatBind density top_lev
       TickForCoverage       -> False
       TickCallSites         -> False
 
+-- Strip ticks HsExpr
+
+-- | Strip CoreTicks from an HsExpr
+stripTicksTopHsExpr :: HsExpr GhcTc -> ([CoreTickish], HsExpr GhcTc)
+stripTicksTopHsExpr (XExpr (HsTick t e)) = let (ts, body) = stripTicksTopHsExpr (unLoc e)
+                                            in (t:ts, body)
+stripTicksTopHsExpr e = ([], e)
+
 -- -----------------------------------------------------------------------------
 -- Adding ticks to bindings
 
diff --git a/testsuite/tests/deSugar/should_fail/T21701.hs b/testsuite/tests/deSugar/should_fail/T21701.hs
new file mode 100644
index 0000000000..e3529158ea
--- /dev/null
+++ b/testsuite/tests/deSugar/should_fail/T21701.hs
@@ -0,0 +1,6 @@
+{-# LANGUAGE NoNegativeLiterals #-}
+module Foo where
+import Data.Int
+x :: Int8
+x = (-128)
+
diff --git a/testsuite/tests/deSugar/should_fail/all.T b/testsuite/tests/deSugar/should_fail/all.T
index f403c74435..735947c2e2 100644
--- a/testsuite/tests/deSugar/should_fail/all.T
+++ b/testsuite/tests/deSugar/should_fail/all.T
@@ -4,3 +4,4 @@
 #	expected process return value, if not zero
 
 test('DsStrictFail', exit_code(1), compile_and_run, [''])
+test('T21701', normal, compile, ['-Wall -finfo-table-map'])