Detect underflow in fromIntegral/Int->Natural rule

Fix #20066

(cherry picked from commit a820f9002d8f75385aaaa141ac3c6f001e8a9874)

4 files changed, 29 insertions, 3 deletions

diff --git a/libraries/base/GHC/Real.hs b/libraries/base/GHC/Real.hs
index 4329bb7355..29194b98c5 100644
--- a/libraries/base/GHC/Real.hs
+++ b/libraries/base/GHC/Real.hs
@@ -586,7 +586,7 @@ fromIntegral = fromInteger . toInteger
   #-}
 
 -- Don't forget the type signatures in the following rules! Without a type
--- signature we end up with the rule:
+-- signature we ended up with the rule:
 --
 --  "fromIntegral/Int->Natural" forall a (d::Integral a).
 --        fromIntegral @a @Natural = naturalFromWord . fromIntegral @a d
@@ -595,12 +595,24 @@ fromIntegral = fromInteger . toInteger
 --
 -- This rule wraps any Integral input into Word's range. As a consequence,
 -- (2^64 :: Integer) was incorrectly wrapped to (0 :: Natural), see #19345.
+--
+-- A follow-up issue with this rule was that no underflow exception was raised
+-- for negative Int values (see #20066). We now use a naturalFromInt helper
+-- function to restore this behavior.
 
 {-# RULES
-"fromIntegral/Word->Natural"    fromIntegral = naturalFromWord                :: Word -> Natural
-"fromIntegral/Int->Natural"     fromIntegral = naturalFromWord . fromIntegral :: Int -> Natural
+"fromIntegral/Word->Natural"    fromIntegral = naturalFromWord :: Word -> Natural
+"fromIntegral/Int->Natural"     fromIntegral = naturalFromInt  :: Int -> Natural
   #-}
 
+-- | Convert an Int into a Natural, throwing an underflow exception for negative
+-- values.
+naturalFromInt :: Int -> Natural
+{-# INLINE naturalFromInt #-}
+naturalFromInt x
+  | x < 0     = underflowError
+  | otherwise = naturalFromWord (fromIntegral x)
+
 -- | general coercion to fractional types
 realToFrac :: (Real a, Fractional b) => a -> b
 {-# NOINLINE [1] realToFrac #-}
diff --git a/testsuite/tests/lib/integer/T20066.hs b/testsuite/tests/lib/integer/T20066.hs
new file mode 100644
index 0000000000..9cb67a6520
--- /dev/null
+++ b/testsuite/tests/lib/integer/T20066.hs
@@ -0,0 +1,12 @@
+{-# OPTIONS_GHC -O #-}
+module Main where
+
+import Numeric.Natural
+
+i :: Int
+i = -10
+
+main :: IO ()
+main = let n :: Natural
+           n = fromIntegral i
+        in print n
diff --git a/testsuite/tests/lib/integer/T20066.stderr b/testsuite/tests/lib/integer/T20066.stderr
new file mode 100644
index 0000000000..589cc2a4a8
--- /dev/null
+++ b/testsuite/tests/lib/integer/T20066.stderr
@@ -0,0 +1 @@
+T20066: arithmetic underflow
diff --git a/testsuite/tests/lib/integer/all.T b/testsuite/tests/lib/integer/all.T
index 50baca63a0..9d7c089640 100644
--- a/testsuite/tests/lib/integer/all.T
+++ b/testsuite/tests/lib/integer/all.T
@@ -29,3 +29,4 @@ test('integerImportExport', [omit_ways(['ghci'])], compile_and_run, [''])
 #test('integerGmpInternals', [], compile_and_run, [''])
 
 test('T19345', [], compile_and_run, [''])
+test('T20066', [exit_code(1)], compile_and_run, [''])