Bignum: fix for Integer/Natural Ord instances

* allow `integerCompare` to inline into `integerLe#`, etc.
* use `naturalSubThrow` to implement Natural's `(-)`
* use `naturalNegate` to implement Natural's `negate`
* implement and use `integerToNaturalThrow` to implement Natural's `fromInteger`

Thanks to @christiaanb for reporting these

1 files changed, 40 insertions, 21 deletions

diff --git a/libraries/ghc-bignum/src/GHC/Num/Integer.hs b/libraries/ghc-bignum/src/GHC/Num/Integer.hs
index 870ac745ea..2e0327127d 100644
--- a/libraries/ghc-bignum/src/GHC/Num/Integer.hs
+++ b/libraries/ghc-bignum/src/GHC/Num/Integer.hs
@@ -225,6 +225,17 @@ integerToNatural (IS x) = naturalFromWord# (wordFromAbsInt# x)
 integerToNatural (IP x) = naturalFromBigNat# x
 integerToNatural (IN x) = naturalFromBigNat# x
 
+-- | Convert a Integer into a Natural
+--
+-- Throw on underflow
+integerToNaturalThrow :: Integer -> Natural
+{-# NOINLINE integerToNaturalThrow #-}
+integerToNaturalThrow (IS x)
+  | isTrue# (x <# 0#) = raiseUnderflow
+  | True              = naturalFromWord# (int2Word# x)
+integerToNaturalThrow (IP x) = naturalFromBigNat# x
+integerToNaturalThrow (IN _) = raiseUnderflow
+
 ---------------------------------------------------------------------
 -- Predicates
 ---------------------------------------------------------------------
@@ -292,30 +303,30 @@ integerNe# _       _     = 1#
 -- | Greater predicate.
 integerGt# :: Integer -> Integer -> Bool#
 {-# NOINLINE integerGt# #-}
-integerGt# (IS x) (IS y)                  = x ># y
-integerGt# x y | GT <- integerCompare x y = 1#
-integerGt# _ _                            = 0#
+integerGt# (IS x) (IS y)                   = x ># y
+integerGt# x y | GT <- integerCompare' x y = 1#
+integerGt# _ _                             = 0#
 
 -- | Lower-or-equal predicate.
 integerLe# :: Integer -> Integer -> Bool#
 {-# NOINLINE integerLe# #-}
-integerLe# (IS x) (IS y)                  = x <=# y
-integerLe# x y | GT <- integerCompare x y = 0#
-integerLe# _ _                            = 1#
+integerLe# (IS x) (IS y)                   = x <=# y
+integerLe# x y | GT <- integerCompare' x y = 0#
+integerLe# _ _                             = 1#
 
 -- | Lower predicate.
 integerLt# :: Integer -> Integer -> Bool#
 {-# NOINLINE integerLt# #-}
-integerLt# (IS x) (IS y)                  = x <# y
-integerLt# x y | LT <- integerCompare x y = 1#
-integerLt# _ _                            = 0#
+integerLt# (IS x) (IS y)                   = x <# y
+integerLt# x y | LT <- integerCompare' x y = 1#
+integerLt# _ _                             = 0#
 
 -- | Greater-or-equal predicate.
 integerGe# :: Integer -> Integer -> Bool#
 {-# NOINLINE integerGe# #-}
-integerGe# (IS x) (IS y)                  = x >=# y
-integerGe# x y | LT <- integerCompare x y = 0#
-integerGe# _ _                            = 1#
+integerGe# (IS x) (IS y)                   = x >=# y
+integerGe# x y | LT <- integerCompare' x y = 0#
+integerGe# _ _                             = 1#
 
 instance Eq Integer where
    (==) = integerEq
@@ -324,18 +335,26 @@ instance Eq Integer where
 -- | Compare two Integer
 integerCompare :: Integer -> Integer -> Ordering
 {-# NOINLINE integerCompare #-}
-integerCompare (IS x) (IS y) = compareInt# x y
-integerCompare (IP x) (IP y) = bigNatCompare x y
-integerCompare (IN x) (IN y) = bigNatCompare y x
-integerCompare (IS _) (IP _) = LT
-integerCompare (IS _) (IN _) = GT
-integerCompare (IP _) (IS _) = GT
-integerCompare (IN _) (IS _) = LT
-integerCompare (IP _) (IN _) = GT
-integerCompare (IN _) (IP _) = LT
+integerCompare = integerCompare'
+
+integerCompare' :: Integer -> Integer -> Ordering
+{-# INLINE integerCompare' #-}
+integerCompare' (IS x) (IS y) = compareInt# x y
+integerCompare' (IP x) (IP y) = bigNatCompare x y
+integerCompare' (IN x) (IN y) = bigNatCompare y x
+integerCompare' (IS _) (IP _) = LT
+integerCompare' (IS _) (IN _) = GT
+integerCompare' (IP _) (IS _) = GT
+integerCompare' (IN _) (IS _) = LT
+integerCompare' (IP _) (IN _) = GT
+integerCompare' (IN _) (IP _) = LT
 
 instance Ord Integer where
    compare = integerCompare
+   (<)     = integerLt
+   (<=)    = integerLe
+   (>)     = integerGt
+   (>=)    = integerGe
 
 ---------------------------------------------------------------------
 -- Operations