Commit 8a8cdbbf authored by Herbert Valerio Riedel's avatar Herbert Valerio Riedel 🕺
Browse files

Implement `Natural` number type (re #9818)

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
parent 137b3313
{-# 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
{-# 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
......@@ -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
......
......@@ -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