fromEnum Natural: Throw error for non-representable values

Starting with commit fe770c21, an error was thrown only for the values
2^63 to 2^64-1 inclusive (on a 64-bit machine), but not for higher
values. Now, errors are thrown for all non-representable values again.

Fixes #20291

5 files changed, 61 insertions, 4 deletions

diff --git a/libraries/base/GHC/Enum.hs b/libraries/base/GHC/Enum.hs
index 02b3d0e784..2765dcd265 100644
--- a/libraries/base/GHC/Enum.hs
+++ b/libraries/base/GHC/Enum.hs
@@ -967,12 +967,10 @@ instance Enum Natural where
       | i >= 0    = naturalFromWord# (int2Word# i#)
       | otherwise = errorWithoutStackTrace "toEnum: unexpected negative Int"
 
-    fromEnum (NS w)
-      | i >= 0    = i
-      | otherwise = errorWithoutStackTrace "fromEnum: out of Int range"
+    fromEnum (NS w) | i >= 0 = i
       where
         i = I# (word2Int# w)
-    fromEnum n = fromEnum (integerFromNatural n)
+    fromEnum _ = errorWithoutStackTrace "fromEnum: out of Int range"
 
     enumFrom x        = enumDeltaNatural      x 1
     enumFromThen x y
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 7c67e937ba..b71a1fd787 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -13,6 +13,9 @@
 
   * Add `Data.ByteArray` module, providing a boxed `ByteArray#`.
 
+  * `fromEnum` for `Natural` now throws an error for any number that cannot be
+    repesented exactly by an `Int` (#20291).
+
 ## 4.16.0.0 *TBA*
 
   * Add a `Typeable` constraint to `fromStaticPtr` in the class `GHC.StaticPtr.IsStatic`.
diff --git a/testsuite/tests/numeric/should_run/T20291.hs b/testsuite/tests/numeric/should_run/T20291.hs
new file mode 100644
index 0000000000..ab7476f69a
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T20291.hs
@@ -0,0 +1,45 @@
+{-# LANGUAGE CPP, TypeApplications #-}
+
+#include "MachDeps.h"
+
+module Main where
+
+import Control.Exception
+import Numeric.Natural
+
+ok :: Natural -> IO ()
+ok n | fromEnum n == i = putStrLn "OK"
+     | otherwise       = putStrLn errmsg
+  where
+    i = fromIntegral n
+    errmsg = ("fromEnum " ++) . shows n . (" == " ++) . shows i $ ": BAD"
+
+bad :: Natural -> IO ()
+bad n = do
+  r <- try @ErrorCall . evaluate $ fromEnum n
+  case r of
+    Left _  ->
+      putStrLn "Exception thrown as expected."
+    Right _ ->
+      putStrLn $
+        ("fromEnum " ++) . shows n $ ": Exception not thrown when expected."
+
+main :: IO ()
+main = do
+  let sizem2 = WORD_SIZE_IN_BITS - 2 :: Int
+      sizem1 = WORD_SIZE_IN_BITS - 1 :: Int
+      size   = WORD_SIZE_IN_BITS     :: Int
+      sizep1 = WORD_SIZE_IN_BITS + 1 :: Int
+  mapM_ ok
+    [ 0
+    , 2 ^ sizem2
+    , 2 ^ sizem1 - 1
+    ]
+  mapM_ bad
+    [ 2 ^ sizem1
+    , 2 ^ size - 1
+    , 2 ^ size
+    , 2 ^ size + 2 ^ sizem1
+    , 2 ^ sizep1 - 42
+    , 2 ^ sizep1
+    ]
diff --git a/testsuite/tests/numeric/should_run/T20291.stdout b/testsuite/tests/numeric/should_run/T20291.stdout
new file mode 100644
index 0000000000..36d05cbe4a
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T20291.stdout
@@ -0,0 +1,9 @@
+OK
+OK
+OK
+Exception thrown as expected.
+Exception thrown as expected.
+Exception thrown as expected.
+Exception thrown as expected.
+Exception thrown as expected.
+Exception thrown as expected.
diff --git a/testsuite/tests/numeric/should_run/all.T b/testsuite/tests/numeric/should_run/all.T
index 1123984bdd..b0580c7e2c 100644
--- a/testsuite/tests/numeric/should_run/all.T
+++ b/testsuite/tests/numeric/should_run/all.T
@@ -77,3 +77,5 @@ test('T18604', normal, compile_and_run, [''])
 test('T19931', normal, compile_and_run, ['-O2'])
 
 test('IntegerToFloat', normal, compile_and_run, [''])
+
+test('T20291', normal, compile_and_run, [''])