Implement `Natural` number type (re #9818)
authorHerbert Valerio Riedel <hvr@gnu.org>
Fri, 21 Nov 2014 23:15:42 +0000 (00:15 +0100)
committerHerbert Valerio Riedel <hvr@gnu.org>
Sat, 22 Nov 2014 00:03:55 +0000 (01:03 +0100)
This implements a `Natural` type for representing unsigned arbitrary
precision integers.

When available, `integer-gmp>=1.0.0`'s `BigNat` type is used as
building-block to construct `Natural` as an algebraic data-type.
Otherwise, `Natural` falls back being a `newtype`-wrapper around
`Integer` (as is done in Edward Kmett's `nats` package).

The `GHC.Natural` module exposes an internal GHC-specific API, while
`Numeric.Natural` provides the official & portable API.

Reviewed By: austin, ekmett

Differential Revision: https://phabricator.haskell.org/D473

libraries/base/GHC/Natural.hs [new file with mode: 0644]
libraries/base/Numeric/Natural.hs [new file with mode: 0644]
libraries/base/Text/Printf.hs
libraries/base/base.cabal
libraries/base/changelog.md
libraries/integer-gmp2/src/GHC/Integer/GMP/Internals.hs
libraries/integer-gmp2/src/GHC/Integer/Type.hs

diff --git a/libraries/base/GHC/Natural.hs b/libraries/base/GHC/Natural.hs
new file mode 100644 (file)
index 0000000..7c362ac
--- /dev/null
@@ -0,0 +1,542 @@
+{-# LANGUAGE AutoDeriveTypeable #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MagicHash #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE UnboxedTuples #-}
+{-# LANGUAGE Unsafe #-}
+
+{-# OPTIONS_HADDOCK not-home #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  GHC.Natural
+-- Copyright   :  (C) 2014 Herbert Valerio Riedel,
+--                (C) 2011 Edward Kmett
+-- License     :  see libraries/base/LICENSE
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  internal
+-- Portability :  non-portable (GHC Extensions)
+--
+-- The arbitrary-precision 'Natural' number type.
+--
+-- __Note__: This is an internal GHC module with an API subject to
+-- change.  It's recommended use the "Numeric.Natural" module to import
+-- the 'Natural' type.
+--
+-- /Since: 4.8.0.0/
+-----------------------------------------------------------------------------
+module GHC.Natural
+    ( -- * The 'Natural' number type
+      --
+      -- | __Warning__: The internal implementation of 'Natural'
+      -- (i.e. which constructors are available) depends on the
+      -- 'Integer' backend used!
+      Natural(..)
+      -- * Conversions
+    , wordToNatural
+    , naturalToWordMaybe
+      -- * Checked subtraction
+    , minusNaturalMaybe
+    ) where
+
+#include "MachDeps.h"
+
+#if defined(MIN_VERSION_integer_gmp)
+# define HAVE_GMP_BIGNAT MIN_VERSION_integer_gmp(1,0,0)
+#else
+# define HAVE_GMP_BIGNAT 0
+#endif
+
+import GHC.Arr
+import GHC.Base
+import GHC.Exception
+#if HAVE_GMP_BIGNAT
+import GHC.Integer.GMP.Internals
+import Data.Word
+import Data.Int
+#endif
+import GHC.Num
+import GHC.Real
+import GHC.Read
+import GHC.Show
+import GHC.Enum
+import GHC.List
+
+import Data.Bits
+
+default ()
+
+#if HAVE_GMP_BIGNAT
+-- TODO: if saturated arithmetic is to used, replace 'throw Underflow' by '0'
+
+-- | Type representing arbitrary-precision non-negative integers.
+--
+-- Operations whose result would be negative
+-- @'throw' ('Underflow' :: 'ArithException')@.
+--
+-- /Since: 4.8.0.0/
+data Natural = NatS#                 GmpLimb# -- ^ in @[0, maxBound::Word]@
+             | NatJ# {-# UNPACK #-} !BigNat   -- ^ in @]maxBound::Word, +inf[@
+                                              --
+                                              -- __Invariant__: 'NatJ#' is used
+                                              -- /iff/ value doesn't fit in
+                                              -- 'NatS#' constructor.
+             deriving (Eq,Ord) -- NB: Order of constructors *must*
+                               -- coincide with 'Ord' relation
+
+{-# RULES
+"fromIntegral/Natural->Natural"  fromIntegral = id :: Natural -> Natural
+"fromIntegral/Natural->Integer"  fromIntegral = toInteger :: Natural->Integer
+"fromIntegral/Natural->Word"     fromIntegral = naturalToWord
+"fromIntegral/Natural->Word8"
+    fromIntegral = (fromIntegral :: Word -> Word8)  . naturalToWord
+"fromIntegral/Natural->Word16"
+    fromIntegral = (fromIntegral :: Word -> Word16) . naturalToWord
+"fromIntegral/Natural->Word32"
+    fromIntegral = (fromIntegral :: Word -> Word32) . naturalToWord
+"fromIntegral/Natural->Int8"
+    fromIntegral = (fromIntegral :: Int -> Int8)    . naturalToInt
+"fromIntegral/Natural->Int16"
+    fromIntegral = (fromIntegral :: Int -> Int16)   . naturalToInt
+"fromIntegral/Natural->Int32"
+    fromIntegral = (fromIntegral :: Int -> Int32)   . naturalToInt
+  #-}
+
+{-# RULES
+"fromIntegral/Word->Natural"     fromIntegral = wordToNatural
+"fromIntegral/Word8->Natural"
+    fromIntegral = wordToNatural . (fromIntegral :: Word8  -> Word)
+"fromIntegral/Word16->Natural"
+    fromIntegral = wordToNatural . (fromIntegral :: Word16 -> Word)
+"fromIntegral/Word32->Natural"
+    fromIntegral = wordToNatural . (fromIntegral :: Word32 -> Word)
+"fromIntegral/Int->Natural"     fromIntegral = intToNatural
+"fromIntegral/Int8->Natural"
+    fromIntegral = intToNatural  . (fromIntegral :: Int8  -> Int)
+"fromIntegral/Int16->Natural"
+    fromIntegral = intToNatural  . (fromIntegral :: Int16 -> Int)
+"fromIntegral/Int32->Natural"
+    fromIntegral = intToNatural  . (fromIntegral :: Int32 -> Int)
+  #-}
+
+#if WORD_SIZE_IN_BITS == 64
+-- these RULES are valid for Word==Word64 & Int==Int64
+{-# RULES
+"fromIntegral/Natural->Word64"
+    fromIntegral = (fromIntegral :: Word -> Word64) . naturalToWord
+"fromIntegral/Natural->Int64"
+    fromIntegral = (fromIntegral :: Int -> Int64) . naturalToInt
+"fromIntegral/Word64->Natural"
+    fromIntegral = wordToNatural . (fromIntegral :: Word64 -> Word)
+"fromIntegral/Int64->Natural"
+    fromIntegral = intToNatural . (fromIntegral :: Int64 -> Int)
+  #-}
+#endif
+
+instance Show Natural where
+    showsPrec p (NatS# w#)  = showsPrec p (W# w#)
+    showsPrec p (NatJ# bn)  = showsPrec p (Jp# bn)
+
+instance Read Natural where
+    readsPrec d = map (\(n, s) -> (fromInteger n, s))
+                  . filter ((>= 0) . (\(x,_)->x)) . readsPrec d
+
+instance Num Natural where
+    fromInteger (S# i#) | I# i# >= 0  = NatS# (int2Word# i#)
+    fromInteger (Jp# bn#)             = NatJ# bn#
+    fromInteger _                     = throw Underflow
+
+    (+) = plusNatural
+    (*) = timesNatural
+    (-) = minusNatural
+
+    abs                  = id
+
+    signum (NatS# 0##)   = NatS# 0##
+    signum _             = NatS# 1##
+
+    negate (NatS# 0##)   = NatS# 0##
+    negate _             = throw Underflow
+
+instance Real Natural where
+    toRational (NatS# w)  = toRational (W# w)
+    toRational (NatJ# bn) = toRational (Jp# bn)
+
+instance Enum Natural where
+    succ n = n `plusNatural`  NatS# 1##
+    pred n = n `minusNatural` NatS# 1##
+
+    toEnum = intToNatural
+
+    fromEnum (NatS# w) | i >= 0 = i
+      where
+        i = fromIntegral (W# w)
+    fromEnum _ = error "fromEnum: out of Int range"
+
+    enumFrom x        = enumDeltaNatural      x (NatS# 1##)
+    enumFromThen x y
+      | x <= y        = enumDeltaNatural      x (y-x)
+      | otherwise     = enumNegDeltaToNatural x (x-y) (NatS# 0##)
+
+    enumFromTo x lim  = enumDeltaToNatural    x (NatS# 1##) lim
+    enumFromThenTo x y lim
+      | x <= y        = enumDeltaToNatural    x (y-x) lim
+      | otherwise     = enumNegDeltaToNatural x (x-y) lim
+
+----------------------------------------------------------------------------
+-- Helpers for 'Enum Natural'; TODO: optimise & make fusion work
+
+enumDeltaNatural :: Natural -> Natural -> [Natural]
+enumDeltaNatural !x d = x : enumDeltaNatural (x+d) d
+
+enumDeltaToNatural :: Natural -> Natural -> Natural -> [Natural]
+enumDeltaToNatural x0 delta lim = go x0
+  where
+    go x | x > lim   = []
+         | otherwise = x : go (x+delta)
+
+enumNegDeltaToNatural :: Natural -> Natural -> Natural -> [Natural]
+enumNegDeltaToNatural x0 ndelta lim = go x0
+  where
+    go x | x < lim     = []
+         | x >= ndelta = x : go (x-ndelta)
+         | otherwise   = [x]
+
+----------------------------------------------------------------------------
+
+instance Integral Natural where
+    toInteger (NatS# w)  = wordToInteger w
+    toInteger (NatJ# bn) = Jp# bn
+
+    divMod = quotRem
+    div    = quot
+    mod    = rem
+
+    quotRem _ (NatS# 0##) = throw DivideByZero
+    quotRem n (NatS# 1##) = (n,NatS# 0##)
+    quotRem n@(NatS# _) (NatJ# _) = (NatS# 0##, n)
+    quotRem (NatS# n) (NatS# d) = case quotRem (W# n) (W# d) of
+        (q,r) -> (wordToNatural q, wordToNatural r)
+    quotRem (NatJ# n) (NatS# d) = case quotRemBigNatWord n d of
+        (# q,r #) -> (bigNatToNatural q, NatS# r)
+    quotRem (NatJ# n) (NatJ# d) = case quotRemBigNat n d of
+        (# q,r #) -> (bigNatToNatural q, bigNatToNatural r)
+
+    quot _       (NatS# 0##) = throw DivideByZero
+    quot n       (NatS# 1##) = n
+    quot (NatS# _) (NatJ# _) = NatS# 0##
+    quot (NatS# n) (NatS# d) = wordToNatural (quot (W# n) (W# d))
+    quot (NatJ# n) (NatS# d) = bigNatToNatural (quotBigNatWord n d)
+    quot (NatJ# n) (NatJ# d) = bigNatToNatural (quotBigNat n d)
+
+    rem _         (NatS# 0##) = throw DivideByZero
+    rem _         (NatS# 1##) = NatS# 0##
+    rem n@(NatS# _) (NatJ# _) = n
+    rem   (NatS# n) (NatS# d) = wordToNatural (rem (W# n) (W# d))
+    rem   (NatJ# n) (NatS# d) = NatS# (remBigNatWord n d)
+    rem   (NatJ# n) (NatJ# d) = bigNatToNatural (remBigNat n d)
+
+instance Ix Natural where
+    range (m,n) = [m..n]
+    inRange (m,n) i = m <= i && i <= n
+    unsafeIndex (m,_) i = fromIntegral (i-m)
+    index b i | inRange b i = unsafeIndex b i
+              | otherwise   = indexError b i "Natural"
+
+
+instance Bits Natural where
+    NatS# n .&. NatS# m = wordToNatural (W# n .&. W# m)
+    NatS# n .&. NatJ# m = wordToNatural (W# n .&. W# (bigNatToWord m))
+    NatJ# n .&. NatS# m = wordToNatural (W# (bigNatToWord n) .&. W# m)
+    NatJ# n .&. NatJ# m = bigNatToNatural (andBigNat n m)
+
+    NatS# n .|. NatS# m = wordToNatural (W# n .|. W# m)
+    NatS# n .|. NatJ# m = NatJ# (andBigNat (wordToBigNat n) m)
+    NatJ# n .|. NatS# m = NatJ# (andBigNat n (wordToBigNat m))
+    NatJ# n .|. NatJ# m = NatJ# (andBigNat n m)
+
+    NatS# n `xor` NatS# m = wordToNatural (W# n `xor` W# m)
+    NatS# n `xor` NatJ# m = NatJ# (xorBigNat (wordToBigNat n) m)
+    NatJ# n `xor` NatS# m = NatJ# (xorBigNat n (wordToBigNat m))
+    NatJ# n `xor` NatJ# m = bigNatToNatural (xorBigNat n m)
+
+    complement _ = error "Bits.complement: Natural complement undefined"
+
+    bitSizeMaybe _ = Nothing
+    bitSize = error "Natural: bitSize"
+    isSigned _ = False
+
+    bit i@(I# i#) | i < finiteBitSize (0::Word) = wordToNatural (bit i)
+                  | otherwise                   = NatJ# (bitBigNat i#)
+
+    testBit (NatS# w) i = testBit (W# w) i
+    testBit (NatJ# bn) (I# i#) = testBitBigNat bn i#
+
+    -- TODO: setBit, clearBit, complementBit (needs more primitives)
+
+    shiftL n           0 = n
+    shiftL (NatS# 0##) _ = NatS# 0##
+    shiftL (NatS# 1##) i = bit i
+    shiftL (NatS# w) (I# i#)
+        = bigNatToNatural $ shiftLBigNat (wordToBigNat w) i#
+    shiftL (NatJ# bn) (I# i#)
+        = bigNatToNatural $ shiftLBigNat bn i#
+
+    shiftR n          0       = n
+    shiftR (NatS# w)  i       = wordToNatural $ shiftR (W# w) i
+    shiftR (NatJ# bn) (I# i#) = bigNatToNatural (shiftRBigNat bn i#)
+
+    rotateL = shiftL
+    rotateR = shiftR
+
+    popCount (NatS# w)  = popCount (W# w)
+    popCount (NatJ# bn) = popCount (Jp# bn)
+
+    zeroBits = NatS# 0##
+
+----------------------------------------------------------------------------
+
+-- | 'Natural' Addition
+plusNatural :: Natural -> Natural -> Natural
+plusNatural (NatS# 0##) y         = y
+plusNatural x         (NatS# 0##) = x
+plusNatural (NatS# x) (NatS# y)
+    = case plusWord2# x y of
+       (# 0##, l #) -> NatS# l
+       (# h,   l #) -> NatJ# (wordToBigNat2 h l)
+plusNatural (NatS# x) (NatJ# y) = NatJ# (plusBigNatWord y x)
+plusNatural (NatJ# x) (NatS# y) = NatJ# (plusBigNatWord x y)
+plusNatural (NatJ# x) (NatJ# y) = NatJ# (plusBigNat     x y)
+
+-- | 'Natural' multiplication
+timesNatural :: Natural -> Natural -> Natural
+timesNatural _         (NatS# 0##) = NatS# 0##
+timesNatural (NatS# 0##) _         = NatS# 0##
+timesNatural x         (NatS# 1##) = x
+timesNatural (NatS# 1##) y         = y
+timesNatural (NatS# x) (NatS# y) = case timesWord2# x y of
+    (# 0##, 0## #) -> NatS# 0##
+    (# 0##, xy  #) -> NatS# xy
+    (# h  , l   #) -> NatJ# $ wordToBigNat2 h l
+timesNatural (NatS# x) (NatJ# y) = NatJ# $ timesBigNatWord y x
+timesNatural (NatJ# x) (NatS# y) = NatJ# $ timesBigNatWord x y
+timesNatural (NatJ# x) (NatJ# y) = NatJ# $ timesBigNat     x y
+
+-- | 'Natural' subtraction. May @'throw' 'Underflow'@.
+minusNatural :: Natural -> Natural -> Natural
+minusNatural x         (NatS# 0##) = x
+minusNatural (NatS# x) (NatS# y) = case subWordC# x y of
+    (# l, 0# #) -> NatS# l
+    _           -> throw Underflow
+minusNatural (NatS# _) (NatJ# _) = throw Underflow
+minusNatural (NatJ# x) (NatS# y)
+    = bigNatToNatural $ minusBigNatWord x y
+minusNatural (NatJ# x) (NatJ# y)
+    = bigNatToNatural $ minusBigNat     x y
+
+-- | 'Natural' subtraction. Returns 'Nothing's for non-positive results.
+--
+-- /Since: 4.8.0.0/
+minusNaturalMaybe :: Natural -> Natural -> Maybe Natural
+minusNaturalMaybe x         (NatS# 0##) = Just x
+minusNaturalMaybe (NatS# x) (NatS# y) = case subWordC# x y of
+    (# l, 0# #) -> Just (NatS# l)
+    _           -> Nothing
+  where
+minusNaturalMaybe (NatS# _) (NatJ# _) = Nothing
+minusNaturalMaybe (NatJ# x) (NatS# y)
+    = Just $ bigNatToNatural $ minusBigNatWord x y
+minusNaturalMaybe (NatJ# x) (NatJ# y)
+  | isTrue# (isNullBigNat# res) = Nothing
+  | otherwise = Just (bigNatToNatural res)
+  where
+    res = minusBigNat x y
+
+-- | Helper for 'minusNatural' and 'minusNaturalMaybe'
+subWordC# :: Word# -> Word# -> (# Word#, Int# #)
+subWordC# x# y# = (# d#, c# #)
+  where
+    d# = x# `minusWord#` y#
+    c# = d# `gtWord#` x#
+
+-- | Convert 'BigNat' to 'Natural'.
+-- Throws 'Underflow' if passed a 'nullBigNat'.
+bigNatToNatural :: BigNat -> Natural
+bigNatToNatural bn
+  | isTrue# (sizeofBigNat# bn ==# 1#) = NatS# (bigNatToWord bn)
+  | isTrue# (isNullBigNat# bn)        = throw Underflow
+  | otherwise                         = NatJ# bn
+
+-- | Convert 'Int' to 'Natural'.
+-- Throws 'Underflow' when passed a negative 'Int'.
+intToNatural :: Int -> Natural
+intToNatural i | i<0 = throw Underflow
+intToNatural (I# i#) = NatS# (int2Word# i#)
+
+naturalToWord :: Natural -> Word
+naturalToWord (NatS# w#) = W# w#
+naturalToWord (NatJ# bn) = W# (bigNatToWord bn)
+
+naturalToInt :: Natural -> Int
+naturalToInt (NatS# w#) = I# (word2Int# w#)
+naturalToInt (NatJ# bn) = I# (bigNatToInt bn)
+
+#else /* !HAVE_GMP_BIGNAT */
+----------------------------------------------------------------------------
+-- Use wrapped 'Integer' as fallback; taken from Edward Kmett's nats package
+
+-- | Type representing arbitrary-precision non-negative integers.
+--
+-- Operations whose result would be negative
+-- @'throw' ('Underflow' :: 'ArithException')@.
+--
+-- /Since: 4.8.0.0/
+newtype Natural = Natural Integer -- ^ __Invariant__: non-negative 'Integer'
+                deriving (Eq,Ord,Ix)
+
+instance Read Natural where
+    readsPrec d = map (\(n, s) -> (Natural n, s))
+                  . filter ((>= 0) . (\(x,_)->x)) . readsPrec d
+
+instance Show Natural where
+    showsPrec d (Natural i) = showsPrec d i
+
+instance Num Natural where
+  Natural n + Natural m = Natural (n + m)
+  {-# INLINE (+) #-}
+  Natural n * Natural m = Natural (n * m)
+  {-# INLINE (*) #-}
+  Natural n - Natural m | result < 0 = throw Underflow
+                        | otherwise  = Natural result
+    where result = n - m
+  {-# INLINE (-) #-}
+  abs (Natural n) = Natural n
+  {-# INLINE abs #-}
+  signum (Natural n) = Natural (signum n)
+  {-# INLINE signum #-}
+  fromInteger n
+    | n >= 0 = Natural n
+    | otherwise = throw Underflow
+  {-# INLINE fromInteger #-}
+
+-- | 'Natural' subtraction. Returns 'Nothing's for non-positive results.
+--
+-- /Since: 4.8.0.0/
+minusNaturalMaybe :: Natural -> Natural -> Maybe Natural
+minusNaturalMaybe x y
+  | x >= y    = Just (x - y)
+  | otherwise = Nothing
+
+instance Bits Natural where
+  Natural n .&. Natural m = Natural (n .&. m)
+  {-# INLINE (.&.) #-}
+  Natural n .|. Natural m = Natural (n .|. m)
+  {-# INLINE (.|.) #-}
+  xor (Natural n) (Natural m) = Natural (xor n m)
+  {-# INLINE xor #-}
+  complement _ = error "Bits.complement: Natural complement undefined"
+  {-# INLINE complement #-}
+  shift (Natural n) = Natural . shift n
+  {-# INLINE shift #-}
+  rotate (Natural n) = Natural . rotate n
+  {-# INLINE rotate #-}
+  bit = Natural . bit
+  {-# INLINE bit #-}
+  setBit (Natural n) = Natural . setBit n
+  {-# INLINE setBit #-}
+  clearBit (Natural n) = Natural . clearBit n
+  {-# INLINE clearBit #-}
+  complementBit (Natural n) = Natural . complementBit n
+  {-# INLINE complementBit #-}
+  testBit (Natural n) = testBit n
+  {-# INLINE testBit #-}
+  bitSizeMaybe _ = Nothing
+  {-# INLINE bitSizeMaybe #-}
+  bitSize = error "Natural: bitSize"
+  {-# INLINE bitSize #-}
+  isSigned _ = False
+  {-# INLINE isSigned #-}
+  shiftL (Natural n) = Natural . shiftL n
+  {-# INLINE shiftL #-}
+  shiftR (Natural n) = Natural . shiftR n
+  {-# INLINE shiftR #-}
+  rotateL (Natural n) = Natural . rotateL n
+  {-# INLINE rotateL #-}
+  rotateR (Natural n) = Natural . rotateR n
+  {-# INLINE rotateR #-}
+  popCount (Natural n) = popCount n
+  {-# INLINE popCount #-}
+  zeroBits = Natural 0
+
+instance Real Natural where
+  toRational (Natural a) = toRational a
+  {-# INLINE toRational #-}
+
+instance Enum Natural where
+  pred (Natural 0) = error "Natural.pred: 0"
+  pred (Natural n) = Natural (pred n)
+  {-# INLINE pred #-}
+  succ (Natural n) = Natural (succ n)
+  {-# INLINE succ #-}
+  fromEnum (Natural n) = fromEnum n
+  {-# INLINE fromEnum #-}
+  toEnum n | n < 0     = error "Natural.toEnum: negative"
+           | otherwise = Natural (toEnum n)
+  {-# INLINE toEnum #-}
+
+  enumFrom     = coerce (enumFrom     :: Integer -> [Integer])
+  enumFromThen x y
+    | x <= y    = coerce (enumFromThen :: Integer -> Integer -> [Integer]) x y
+    | otherwise = enumFromThenTo x y 0
+
+  enumFromTo   = coerce (enumFromTo   :: Integer -> Integer -> [Integer])
+  enumFromThenTo
+    = coerce (enumFromThenTo :: Integer -> Integer -> Integer -> [Integer])
+
+instance Integral Natural where
+  quot (Natural a) (Natural b) = Natural (quot a b)
+  {-# INLINE quot #-}
+  rem (Natural a) (Natural b) = Natural (rem a b)
+  {-# INLINE rem #-}
+  div (Natural a) (Natural b) = Natural (div a b)
+  {-# INLINE div #-}
+  mod (Natural a) (Natural b) = Natural (mod a b)
+  {-# INLINE mod #-}
+  divMod (Natural a) (Natural b) = (Natural q, Natural r)
+    where (q,r) = divMod a b
+  {-# INLINE divMod #-}
+  quotRem (Natural a) (Natural b) = (Natural q, Natural r)
+    where (q,r) = quotRem a b
+  {-# INLINE quotRem #-}
+  toInteger (Natural a) = a
+  {-# INLINE toInteger #-}
+#endif
+
+-- | Construct 'Natural' from 'Word' value.
+--
+-- /Since: 4.8.0.0/
+wordToNatural :: Word -> Natural
+#if HAVE_GMP_BIGNAT
+wordToNatural (W# w#) = NatS# w#
+#else
+wordToNatural w = Natural (fromIntegral w)
+#endif
+
+-- | Try downcasting 'Natural' to 'Word' value.
+-- Returns 'Nothing' if value doesn't fit in 'Word'.
+--
+-- /Since: 4.8.0.0/
+naturalToWordMaybe :: Natural -> Maybe Word
+#if HAVE_GMP_BIGNAT
+naturalToWordMaybe (NatS# w#) = Just (W# w#)
+naturalToWordMaybe (NatJ# _)  = Nothing
+#else
+naturalToWordMaybe (Natural i)
+  | i <= maxw  = Just (fromIntegral i)
+  | otherwise  = Nothing
+  where
+    maxw = toInteger (maxBound :: Word)
+#endif
diff --git a/libraries/base/Numeric/Natural.hs b/libraries/base/Numeric/Natural.hs
new file mode 100644 (file)
index 0000000..3a96501
--- /dev/null
@@ -0,0 +1,24 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE Trustworthy #-}
+
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Numeric.Natural
+-- Copyright   :  (C) 2014 Herbert Valerio Riedel,
+--                (C) 2011 Edward Kmett
+-- License     :  see libraries/base/LICENSE
+--
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- The arbitrary-precision 'Natural' number type.
+--
+-- /Since: 4.8.0.0/
+-----------------------------------------------------------------------------
+
+module Numeric.Natural
+    ( Natural
+    ) where
+
+import GHC.Natural
index 9ad67d0..6c911da 100644 (file)
@@ -96,6 +96,7 @@ import Data.Int
 import Data.List
 import Data.Word
 import Numeric
+import Numeric.Natural
 import System.IO
 
 -------------------
@@ -368,6 +369,10 @@ instance PrintfArg Integer where
     formatArg = formatInteger
     parseFormat = parseIntFormat
 
+instance PrintfArg Natural where
+    formatArg = formatInteger . toInteger
+    parseFormat = parseIntFormat
+
 instance PrintfArg Float where
     formatArg = formatRealFloat
 
index bde2a29..b6b5a59 100644 (file)
@@ -245,6 +245,7 @@ Library
         GHC.Int
         GHC.List
         GHC.MVar
+        GHC.Natural
         GHC.Num
         GHC.PArr
         GHC.Pack
@@ -265,6 +266,7 @@ Library
         GHC.Weak
         GHC.Word
         Numeric
+        Numeric.Natural
         Prelude
         System.CPUTime
         System.Console.GetOpt
index 32009db..881532f 100644 (file)
   * Add `Data.Bits.toIntegralSized`, a size-checked version of
     `fromIntegral`. (#9816)
 
+  * New module `Numeric.Natural` providing new `Natural` type
+    representing non-negative arbitrary-precision integers.  The `GHC.Natural`
+    module exposes additional GHC-specific primitives. (#9818)
+
 ## 4.7.0.1  *Jul 2014*
 
   * Bundled with GHC 7.8.3
index 1f9c4b7..e319bee 100644 (file)
@@ -71,6 +71,7 @@ module GHC.Integer.GMP.Internals
     , byteArrayToBigNat#
     , wordToBigNat
     , wordToBigNat2
+    , bigNatToInt
     , bigNatToWord
     , indexBigNat#
 
index a36d756..b0864f7 100644 (file)
@@ -835,6 +835,7 @@ eqBigNatWord# bn w#
 bigNatToWord :: BigNat -> Word#
 bigNatToWord bn = indexBigNat# bn 0#
 
+-- | Equivalent to @'word2Int#' . 'bigNatToWord'@
 bigNatToInt :: BigNat -> Int#
 bigNatToInt (BN# ba#) = indexIntArray# ba# 0#