Bignum: add support for negative shifts (fix #18499)

shiftR/shiftL support negative arguments despite Haskell 2010 report
saying otherwise. We explicitly test for negative values which is bad
(it gets in the way of constant folding, etc.). Anyway, for consistency
we fix Bits instancesof Integer/Natural.

4 files changed, 60 insertions, 4 deletions

diff --git a/libraries/base/Data/Bits.hs b/libraries/base/Data/Bits.hs
index 5379eac571..89702105eb 100644
--- a/libraries/base/Data/Bits.hs
+++ b/libraries/base/Data/Bits.hs
@@ -537,8 +537,14 @@ instance Bits Integer where
    (.|.)      = integerOr
    xor        = integerXor
    complement = integerComplement
-   shiftR x i = integerShiftR x (fromIntegral i)
-   shiftL x i = integerShiftL x (fromIntegral i)
+   unsafeShiftR x i = integerShiftR x (fromIntegral i)
+   unsafeShiftL x i = integerShiftL x (fromIntegral i)
+   shiftR x i@(I# i#)
+      | isTrue# (i# >=# 0#) = unsafeShiftR x i
+      | otherwise           = overflowError
+   shiftL x i@(I# i#)
+      | isTrue# (i# >=# 0#) = unsafeShiftL x i
+      | otherwise           = overflowError
    shift x i | i >= 0    = integerShiftL x (fromIntegral i)
              | otherwise = integerShiftR x (fromIntegral (negate i))
    testBit x i = integerTestBit x (fromIntegral i)
@@ -560,8 +566,14 @@ instance Bits Natural where
    xor           = naturalXor
    complement _  = errorWithoutStackTrace
                     "Bits.complement: Natural complement undefined"
-   shiftR x i    = naturalShiftR x (fromIntegral i)
-   shiftL x i    = naturalShiftL x (fromIntegral i)
+   unsafeShiftR x i = naturalShiftR x (fromIntegral i)
+   unsafeShiftL x i = naturalShiftL x (fromIntegral i)
+   shiftR x i@(I# i#)
+      | isTrue# (i# >=# 0#) = unsafeShiftR x i
+      | otherwise           = overflowError
+   shiftL x i@(I# i#)
+      | isTrue# (i# >=# 0#) = unsafeShiftL x i
+      | otherwise           = overflowError
    shift x i
      | i >= 0    = naturalShiftL x (fromIntegral i)
      | otherwise = naturalShiftR x (fromIntegral (negate i))
diff --git a/testsuite/tests/numeric/should_run/T18499.hs b/testsuite/tests/numeric/should_run/T18499.hs
new file mode 100644
index 0000000000..059057015f
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T18499.hs
@@ -0,0 +1,27 @@
+import Data.Bits
+import Numeric.Natural
+import GHC.Exception.Type
+import Control.Exception
+
+main :: IO ()
+main = do
+   test ((42 `shiftR` (-1)) :: Integer)
+   test ((42 `shiftL` (-1)) :: Integer)
+   test ((42 `shiftR` (-1)) :: Natural)
+   test ((42 `shiftL` (-1)) :: Natural)
+   test ((42 `shiftR` (-1)) :: Word)
+   test ((42 `shiftL` (-1)) :: Word)
+   test ((42 `shiftR` (-1)) :: Int)
+   test ((42 `shiftL` (-1)) :: Int)
+
+   test ((42 `unsafeShiftR` 2) :: Integer)
+   test ((42 `unsafeShiftL` 2) :: Integer)
+   test ((42 `unsafeShiftR` 2) :: Natural)
+   test ((42 `unsafeShiftL` 2) :: Natural)
+   test ((42 `unsafeShiftR` 2) :: Word)
+   test ((42 `unsafeShiftL` 2) :: Word)
+   test ((42 `unsafeShiftR` 2) :: Int)
+   test ((42 `unsafeShiftL` 2) :: Int)
+
+test :: Show a => a -> IO ()
+test a = print a `catch` (\Overflow -> putStrLn "Overflow!")
diff --git a/testsuite/tests/numeric/should_run/T18499.stdout b/testsuite/tests/numeric/should_run/T18499.stdout
new file mode 100644
index 0000000000..7f103dc878
--- /dev/null
+++ b/testsuite/tests/numeric/should_run/T18499.stdout
@@ -0,0 +1,16 @@
+Overflow!
+Overflow!
+Overflow!
+Overflow!
+Overflow!
+Overflow!
+Overflow!
+Overflow!
+10
+168
+10
+168
+10
+168
+10
+168
diff --git a/testsuite/tests/numeric/should_run/all.T b/testsuite/tests/numeric/should_run/all.T
index ce44e15729..faa4d7c992 100644
--- a/testsuite/tests/numeric/should_run/all.T
+++ b/testsuite/tests/numeric/should_run/all.T
@@ -70,3 +70,4 @@ test('T15301', normal, compile_and_run, ['-O2'])
 test('T497', normal, compile_and_run, ['-O'])
 test('T17303', normal, compile_and_run, [''])
 test('T18359', normal, compile_and_run, [''])
+test('T18499', normal, compile_and_run, [''])