{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Numeric.Floating.IEEE.Internal.Rounding.Integral where
import           Control.Exception (assert)
import           Data.Bits
import           Data.Functor.Product
import           Data.Int
import           Data.Proxy
import           Data.Word
import           GHC.Exts
import           Math.NumberTheory.Logarithms (integerLog2', integerLogBase',
                                               wordLog2')
import           MyPrelude
import           Numeric.Floating.IEEE.Internal.Base
import           Numeric.Floating.IEEE.Internal.IntegerInternals
import           Numeric.Floating.IEEE.Internal.Rounding.Common

default ()

-- |
-- IEEE 754 @convertFromInt@ operation, with each rounding attributes.
fromIntegerTiesToEven, fromIntegerTiesToAway, fromIntegerTowardPositive, fromIntegerTowardNegative, fromIntegerTowardZero :: RealFloat a => Integer -> a
fromIntegerTiesToEven :: Integer -> a
fromIntegerTiesToEven = RoundTiesToEven a -> a
forall a. RoundTiesToEven a -> a
roundTiesToEven (RoundTiesToEven a -> a)
-> (Integer -> RoundTiesToEven a) -> Integer -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> RoundTiesToEven a
forall a (f :: * -> *).
(RealFloat a, RoundingStrategy f) =>
Integer -> f a
fromIntegerR
fromIntegerTiesToAway :: Integer -> a
fromIntegerTiesToAway = RoundTiesToAway a -> a
forall a. RoundTiesToAway a -> a
roundTiesToAway (RoundTiesToAway a -> a)
-> (Integer -> RoundTiesToAway a) -> Integer -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> RoundTiesToAway a
forall a (f :: * -> *).
(RealFloat a, RoundingStrategy f) =>
Integer -> f a
fromIntegerR
fromIntegerTowardPositive :: Integer -> a
fromIntegerTowardPositive = RoundTowardPositive a -> a
forall a. RoundTowardPositive a -> a
roundTowardPositive (RoundTowardPositive a -> a)
-> (Integer -> RoundTowardPositive a) -> Integer -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> RoundTowardPositive a
forall a (f :: * -> *).
(RealFloat a, RoundingStrategy f) =>
Integer -> f a
fromIntegerR
fromIntegerTowardNegative :: Integer -> a
fromIntegerTowardNegative = RoundTowardNegative a -> a
forall a. RoundTowardNegative a -> a
roundTowardNegative (RoundTowardNegative a -> a)
-> (Integer -> RoundTowardNegative a) -> Integer -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> RoundTowardNegative a
forall a (f :: * -> *).
(RealFloat a, RoundingStrategy f) =>
Integer -> f a
fromIntegerR
fromIntegerTowardZero :: Integer -> a
fromIntegerTowardZero = RoundTowardZero a -> a
forall a. RoundTowardZero a -> a
roundTowardZero (RoundTowardZero a -> a)
-> (Integer -> RoundTowardZero a) -> Integer -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> RoundTowardZero a
forall a (f :: * -> *).
(RealFloat a, RoundingStrategy f) =>
Integer -> f a
fromIntegerR
{-# INLINE fromIntegerTiesToEven #-}
{-# INLINE fromIntegerTiesToAway #-}
{-# INLINE fromIntegerTowardPositive #-}
{-# INLINE fromIntegerTowardNegative #-}
{-# INLINE fromIntegerTowardZero #-}

-- |
-- IEEE 754 @convertFromInt@ operation, with each rounding attributes.
fromIntegralTiesToEven, fromIntegralTiesToAway, fromIntegralTowardPositive, fromIntegralTowardNegative, fromIntegralTowardZero :: (Integral i, RealFloat a) => i -> a
fromIntegralTiesToEven :: i -> a
fromIntegralTiesToEven = RoundTiesToEven a -> a
forall a. RoundTiesToEven a -> a
roundTiesToEven (RoundTiesToEven a -> a) -> (i -> RoundTiesToEven a) -> i -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> RoundTiesToEven a
forall i a (f :: * -> *).
(Integral i, RealFloat a, RoundingStrategy f) =>
i -> f a
fromIntegralR
fromIntegralTiesToAway :: i -> a
fromIntegralTiesToAway = RoundTiesToAway a -> a
forall a. RoundTiesToAway a -> a
roundTiesToAway (RoundTiesToAway a -> a) -> (i -> RoundTiesToAway a) -> i -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> RoundTiesToAway a
forall i a (f :: * -> *).
(Integral i, RealFloat a, RoundingStrategy f) =>
i -> f a
fromIntegralR
fromIntegralTowardPositive :: i -> a
fromIntegralTowardPositive = RoundTowardPositive a -> a
forall a. RoundTowardPositive a -> a
roundTowardPositive (RoundTowardPositive a -> a)
-> (i -> RoundTowardPositive a) -> i -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> RoundTowardPositive a
forall i a (f :: * -> *).
(Integral i, RealFloat a, RoundingStrategy f) =>
i -> f a
fromIntegralR
fromIntegralTowardNegative :: i -> a
fromIntegralTowardNegative = RoundTowardNegative a -> a
forall a. RoundTowardNegative a -> a
roundTowardNegative (RoundTowardNegative a -> a)
-> (i -> RoundTowardNegative a) -> i -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> RoundTowardNegative a
forall i a (f :: * -> *).
(Integral i, RealFloat a, RoundingStrategy f) =>
i -> f a
fromIntegralR
fromIntegralTowardZero :: i -> a
fromIntegralTowardZero = RoundTowardZero a -> a
forall a. RoundTowardZero a -> a
roundTowardZero (RoundTowardZero a -> a) -> (i -> RoundTowardZero a) -> i -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. i -> RoundTowardZero a
forall i a (f :: * -> *).
(Integral i, RealFloat a, RoundingStrategy f) =>
i -> f a
fromIntegralR
{-# INLINE fromIntegralTiesToEven #-}
{-# INLINE fromIntegralTiesToAway #-}
{-# INLINE fromIntegralTowardPositive #-}
{-# INLINE fromIntegralTowardNegative #-}
{-# INLINE fromIntegralTowardZero #-}

fromIntegerR :: (RealFloat a, RoundingStrategy f) => Integer -> f a
fromIntegerR :: Integer -> f a
fromIntegerR n :: Integer
n = case Integer -> Maybe Int
integerToIntMaybe Integer
n of
                   Just x :: Int
x -> Int -> f a
forall i (f :: * -> *) a.
(Integral i, Bits i, RealFloat a, RoundingStrategy f) =>
i -> f a
fromIntegralRBits Int
x
                   Nothing | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< 0 -> a -> a
forall a. Num a => a -> a
negate (a -> a) -> f a -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Integer -> f a
forall (f :: * -> *) a.
(RealFloat a, RoundingStrategy f) =>
Bool -> Integer -> f a
fromPositiveIntegerR Bool
True (- Integer
n)
                           | Bool
otherwise -> Bool -> Integer -> f a
forall (f :: * -> *) a.
(RealFloat a, RoundingStrategy f) =>
Bool -> Integer -> f a
fromPositiveIntegerR Bool
False Integer
n
{-# INLINE fromIntegerR #-}

fromIntegralR :: (Integral i, RealFloat a, RoundingStrategy f) => i -> f a
fromIntegralR :: i -> f a
fromIntegralR x :: i
x = Integer -> f a
forall a (f :: * -> *).
(RealFloat a, RoundingStrategy f) =>
Integer -> f a
fromIntegerR (i -> Integer
forall a. Integral a => a -> Integer
toInteger i
x)
{-# INLINE [0] fromIntegralR #-}
{-# RULES
"fromIntegralR/Integer->a" fromIntegralR = fromIntegerR
"fromIntegralR/Int->a" fromIntegralR = fromIntegralRBits @Int
"fromIntegralR/Int8->a" fromIntegralR = fromIntegralRBits @Int8
"fromIntegralR/Int16->a" fromIntegralR = fromIntegralRBits @Int16
"fromIntegralR/Int32->a" fromIntegralR = fromIntegralRBits @Int32
"fromIntegralR/Int64->a" fromIntegralR = fromIntegralRBits @Int64
"fromIntegralR/Word->a" fromIntegralR = fromIntegralRBits @Word
"fromIntegralR/Word8->a" fromIntegralR = fromIntegralRBits @Word8
"fromIntegralR/Word16->a" fromIntegralR = fromIntegralRBits @Word16
"fromIntegralR/Word32->a" fromIntegralR = fromIntegralRBits @Word32
"fromIntegralR/Word64->a" fromIntegralR = fromIntegralRBits @Word64
  #-}

fromIntegralRBits :: forall i f a. (Integral i, Bits i, RealFloat a, RoundingStrategy f) => i -> f a
fromIntegralRBits :: i -> f a
fromIntegralRBits x :: i
x
  -- Small enough: fromIntegral should be sufficient
  | Bool
ieee
  , let resultI :: a
resultI = i -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral i
x
  , let (min' :: Maybe i
min', max' :: Maybe i
max') = Proxy a -> (Maybe i, Maybe i)
forall a i.
(Integral i, Bits i, RealFloat a) =>
Proxy a -> (Maybe i, Maybe i)
boundsForExactConversion (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)
  , Bool -> (i -> Bool) -> Maybe i -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (i -> i -> Bool
forall a. Ord a => a -> a -> Bool
<= i
x) Maybe i
min'
  , Bool -> (i -> Bool) -> Maybe i -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True (i
x i -> i -> Bool
forall a. Ord a => a -> a -> Bool
<=) Maybe i
max'
  = a -> f a
forall (f :: * -> *) a. RoundingStrategy f => a -> f a
exact a
resultI

  -- Signed, and not small enough: Test if the value fits in Int
  | Bool
ieee
  , Integer
base Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 2
  , Bool
signed
  , Just y :: Int
y <- i -> Maybe Int
forall a b.
(Integral a, Integral b, Bits a, Bits b) =>
a -> Maybe b
toIntegralSized i
x :: Maybe Int
  = if Int
y Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< 0 then
      a -> a
forall a. Num a => a -> a
negate (a -> a) -> f a -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Word -> f a
forall a (f :: * -> *).
(RealFloat a, RoundingStrategy f) =>
Bool -> Word -> f a
positiveWordToBinaryFloatR Bool
True (Int -> Word
negateIntAsWord Int
y)
    else
      -- We can assume x /= 0
      Bool -> Word -> f a
forall a (f :: * -> *).
(RealFloat a, RoundingStrategy f) =>
Bool -> Word -> f a
positiveWordToBinaryFloatR Bool
False (Int -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
y)

  -- Unsigned, and not small enough: Test if the value fits in Word
  | Bool
ieee
  , Integer
base Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 2
  , Bool -> Bool
not Bool
signed
  , Just y :: Word
y <- i -> Maybe Word
forall a b.
(Integral a, Integral b, Bits a, Bits b) =>
a -> Maybe b
toIntegralSized i
x :: Maybe Word
  = -- We can assume x /= 0
    Bool -> Word -> f a
forall a (f :: * -> *).
(RealFloat a, RoundingStrategy f) =>
Bool -> Word -> f a
positiveWordToBinaryFloatR Bool
False Word
y

  -- General case: Convert via Integer
  | Bool
otherwise = f a
result
  where
    result :: f a
result | i
x i -> i -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = a -> f a
forall (f :: * -> *) a. RoundingStrategy f => a -> f a
exact 0
           | i
x i -> i -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = a -> a
forall a. Num a => a -> a
negate (a -> a) -> f a -> f a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Integer -> f a
forall (f :: * -> *) a.
(RealFloat a, RoundingStrategy f) =>
Bool -> Integer -> f a
fromPositiveIntegerR Bool
True (- i -> Integer
forall a. Integral a => a -> Integer
toInteger i
x)
           | Bool
otherwise = Bool -> Integer -> f a
forall (f :: * -> *) a.
(RealFloat a, RoundingStrategy f) =>
Bool -> Integer -> f a
fromPositiveIntegerR Bool
False (i -> Integer
forall a. Integral a => a -> Integer
toInteger i
x)
    signed :: Bool
signed = i -> Bool
forall a. Bits a => a -> Bool
isSigned i
x
    ieee :: Bool
ieee = a -> Bool
forall a. RealFloat a => a -> Bool
isIEEE (a
forall a. HasCallStack => a
undefined :: a)
    base :: Integer
base = a -> Integer
forall a. RealFloat a => a -> Integer
floatRadix (a
forall a. HasCallStack => a
undefined :: a)
{-# INLINE fromIntegralRBits #-}

-- |
-- >>> boundsForExactConversion (Proxy :: Proxy Double) :: (Maybe Integer, Maybe Integer) -- (Just (-2^53),Just (2^53))
-- (Just (-9007199254740992),Just 9007199254740992)
-- >>> boundsForExactConversion (Proxy :: Proxy Double) :: (Maybe Int32, Maybe Int32) -- the conversion is always exact
-- (Nothing,Nothing)
-- >>> boundsForExactConversion (Proxy :: Proxy Float) :: (Maybe Word, Maybe Word) -- (Nothing,Just (2^24))
-- (Nothing,Just 16777216)
boundsForExactConversion :: forall a i. (Integral i, Bits i, RealFloat a) => Proxy a -> (Maybe i, Maybe i)
boundsForExactConversion :: Proxy a -> (Maybe i, Maybe i)
boundsForExactConversion _ = Bool -> (Maybe i, Maybe i) -> (Maybe i, Maybe i)
forall a. HasCallStack => Bool -> a -> a
assert Bool
ieee (Maybe i
minI, Maybe i
maxI)
  where
    maxInteger :: Integer
maxInteger = Integer
base Integer -> Int -> Integer
^! Int
digits
    minInteger :: Integer
minInteger = - Integer
maxInteger
    minI :: Maybe i
minI = case i -> Maybe Integer
forall i. Bits i => i -> Maybe Integer
minBoundAsInteger (i
forall a. HasCallStack => a
undefined :: i) of
             Just minBound' :: Integer
minBound' | Integer
minInteger Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
minBound' -> Maybe i
forall a. Maybe a
Nothing -- all negative integers can be expressed in the target floating-type: no check for lower-bound is needed
             _ -> i -> Maybe i
forall a. a -> Maybe a
Just (Integer -> i
forall a. Num a => Integer -> a
fromInteger Integer
minInteger)
    maxI :: Maybe i
maxI = case i -> Maybe Integer
forall i. Bits i => i -> Maybe Integer
maxBoundAsInteger (i
forall a. HasCallStack => a
undefined :: i) of
             Just maxBound' :: Integer
maxBound' | Integer
maxBound' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
maxInteger -> Maybe i
forall a. Maybe a
Nothing -- all positive integral values can be expressed in the target floating-type: no check for upper-bound is needed
             _ -> i -> Maybe i
forall a. a -> Maybe a
Just (Integer -> i
forall a. Num a => Integer -> a
fromInteger Integer
maxInteger)
    ieee :: Bool
ieee = a -> Bool
forall a. RealFloat a => a -> Bool
isIEEE (a
forall a. HasCallStack => a
undefined :: a)
    base :: Integer
base = a -> Integer
forall a. RealFloat a => a -> Integer
floatRadix (a
forall a. HasCallStack => a
undefined :: a)
    digits :: Int
digits = a -> Int
forall a. RealFloat a => a -> Int
floatDigits (a
forall a. HasCallStack => a
undefined :: a)
{-# INLINE boundsForExactConversion #-}

minBoundAsInteger :: Bits i => i -> Maybe Integer
minBoundAsInteger :: i -> Maybe Integer
minBoundAsInteger dummyI :: i
dummyI = if i -> Bool
forall a. Bits a => a -> Bool
isSigned i
dummyI then
                             case i -> Maybe Int
forall a. Bits a => a -> Maybe Int
bitSizeMaybe i
dummyI of
                               Just bits :: Int
bits -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (- Int -> Integer
forall a. Bits a => Int -> a
bit (Int
bitsInt -> Int -> Int
forall a. Num a => a -> a -> a
-1))
                               Nothing   -> Maybe Integer
forall a. Maybe a
Nothing
                           else
                             Integer -> Maybe Integer
forall a. a -> Maybe a
Just 0
{-# INLINE [1] minBoundAsInteger #-}
{-# RULES
"minBoundAsInteger/Int" minBoundAsInteger = (\_ -> Just (toInteger (minBound :: Int))) :: Int -> Maybe Integer
"minBoundAsInteger/Int8" minBoundAsInteger = (\_ -> Just (toInteger (minBound :: Int8))) :: Int8 -> Maybe Integer
"minBoundAsInteger/Int16" minBoundAsInteger = (\_ -> Just (toInteger (minBound :: Int16))) :: Int16 -> Maybe Integer
"minBoundAsInteger/Int32" minBoundAsInteger = (\_ -> Just (toInteger (minBound :: Int32))) :: Int32 -> Maybe Integer
"minBoundAsInteger/Int64" minBoundAsInteger = (\_ -> Just (toInteger (minBound :: Int64))) :: Int64 -> Maybe Integer
"minBoundAsInteger/Word" minBoundAsInteger = (\_ -> Just 0) :: Word -> Maybe Integer
"minBoundAsInteger/Word8" minBoundAsInteger = (\_ -> Just 0) :: Word8 -> Maybe Integer
"minBoundAsInteger/Word16" minBoundAsInteger = (\_ -> Just 0) :: Word16 -> Maybe Integer
"minBoundAsInteger/Word32" minBoundAsInteger = (\_ -> Just 0) :: Word32 -> Maybe Integer
"minBoundAsInteger/Word64" minBoundAsInteger = (\_ -> Just 0) :: Word64 -> Maybe Integer
  #-}

maxBoundAsInteger :: Bits i => i -> Maybe Integer
maxBoundAsInteger :: i -> Maybe Integer
maxBoundAsInteger dummyI :: i
dummyI = case i -> Maybe Int
forall a. Bits a => a -> Maybe Int
bitSizeMaybe i
dummyI of
                             Just bits :: Int
bits | i -> Bool
forall a. Bits a => a -> Bool
isSigned i
dummyI -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Int -> Integer
forall a. Bits a => Int -> a
bit (Int
bitsInt -> Int -> Int
forall a. Num a => a -> a -> a
-1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- 1)
                                       | Bool
otherwise -> Integer -> Maybe Integer
forall a. a -> Maybe a
Just (Int -> Integer
forall a. Bits a => Int -> a
bit Int
bits Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- 1)
                             Nothing -> Maybe Integer
forall a. Maybe a
Nothing
{-# INLINE [1] maxBoundAsInteger #-}
{-# RULES
"maxBoundAsInteger/Int" maxBoundAsInteger = (\_ -> Just (toInteger (maxBound :: Int))) :: Int -> Maybe Integer
"maxBoundAsInteger/Int8" maxBoundAsInteger = (\_ -> Just (toInteger (maxBound :: Int8))) :: Int8 -> Maybe Integer
"maxBoundAsInteger/Int16" maxBoundAsInteger = (\_ -> Just (toInteger (maxBound :: Int16))) :: Int16 -> Maybe Integer
"maxBoundAsInteger/Int32" maxBoundAsInteger = (\_ -> Just (toInteger (maxBound :: Int32))) :: Int32 -> Maybe Integer
"maxBoundAsInteger/Int64" maxBoundAsInteger = (\_ -> Just (toInteger (maxBound :: Int64))) :: Int64 -> Maybe Integer
"maxBoundAsInteger/Word" maxBoundAsInteger = (\_ -> Just (toInteger (maxBound :: Word))) :: Word -> Maybe Integer
"maxBoundAsInteger/Word8" maxBoundAsInteger = (\_ -> Just (toInteger (maxBound :: Word8))) :: Word8 -> Maybe Integer
"maxBoundAsInteger/Word16" maxBoundAsInteger = (\_ -> Just (toInteger (maxBound :: Word16))) :: Word16 -> Maybe Integer
"maxBoundAsInteger/Word32" maxBoundAsInteger = (\_ -> Just (toInteger (maxBound :: Word32))) :: Word32 -> Maybe Integer
"maxBoundAsInteger/Word64" maxBoundAsInteger = (\_ -> Just (toInteger (maxBound :: Word64))) :: Word64 -> Maybe Integer
  #-}

-- Avoid cross-module specialization issue with manual worker/wrapper transformation
positiveWordToBinaryFloatR :: (RealFloat a, RoundingStrategy f) => Bool -> Word -> f a
positiveWordToBinaryFloatR :: Bool -> Word -> f a
positiveWordToBinaryFloatR neg :: Bool
neg (W# n# :: Word#
n#) = Bool -> Word# -> f a
forall (f :: * -> *) a.
(RealFloat a, RoundingStrategy f) =>
Bool -> Word# -> f a
positiveWordToBinaryFloatR# Bool
neg Word#
n#
{-# INLINE positiveWordToBinaryFloatR #-}

positiveWordToBinaryFloatR# :: forall f a. (RealFloat a, RoundingStrategy f) => Bool -> Word# -> f a
positiveWordToBinaryFloatR# :: Bool -> Word# -> f a
positiveWordToBinaryFloatR# !Bool
neg n# :: Word#
n# = f a
result
  where
    n :: Word
n = Word# -> Word
W# Word#
n#
    result :: f a
result = let k :: Int
k = Word -> Int
wordLog2' Word
n -- floor (log2 n)
                 -- 2^k <= n < 2^(k+1) <= 2^(finiteBitSize n)
                 -- k <= finiteBitSize n - 1
             in if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
fDigits then
                  a -> f a
forall (f :: * -> *) a. RoundingStrategy f => a -> f a
exact (a -> f a) -> a -> f a
forall a b. (a -> b) -> a -> b
$ Word -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n
                else
                  -- expMax <= k implies expMax <= finiteBitSize n - 1
                  if Int
expMax Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Word -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize Word
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1 Bool -> Bool -> Bool
&& Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
expMax then
                    -- overflow
                    let inf :: a
inf = 1 a -> a -> a
forall a. Fractional a => a -> a -> a
/ 0
                    in Ordering -> Bool -> Int -> a -> a -> f a
forall (f :: * -> *) a.
RoundingStrategy f =>
Ordering -> Bool -> Int -> a -> a -> f a
inexact Ordering
GT Bool
neg 1 a
forall a. RealFloat a => a
maxFinite a
inf
                  else
                    -- k >= fDigits
                    let e :: Int
e = Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fDigits Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1 -- 1 <= e <= finiteBitSize n - fDigits
                        q :: Word
q = Word
n Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`unsafeShiftR` Int
e -- q <= n / 2^e = 2^(log2 n - (floor (log2 n) - fDigits + 1)) < 2^fDigits
                        r :: Word
r = Word
n Word -> Word -> Word
forall a. Bits a => a -> a -> a
.&. ((1 Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
e) Word -> Word -> Word
forall a. Num a => a -> a -> a
- 1)
                        -- (q, r) = n `quotRem` (base^e)
                        -- base^(fDigits - 1) <= q < base^fDigits, 0 <= r < base^(k-fDigits+1)
                        towardzero_or_exact :: a
towardzero_or_exact = Word -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word
q Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
e)
                        -- Although (q `unsafeShiftL` e) fits in Word, ((q + 1) `unsafeShiftL` e) may overflow.
                        -- fDigits + e = k + 1 <= WORD_SIZE_IN_BITS
                        -- Equality holds when wordLog2' n == WORD_SIZE_IN_BITS - 1, i.e. 2^(WORD_SIZE_IN_BITS - 1) <= n.
                        -- In particular,
                        -- * When q + 1 < 2^fDigits, (q + 1) * 2^e < 2^(fDigits + e) = 2^(k + 1) <= 2^WORD_SIZE_IN_BITS, so (q + 1) * 2^e does not overflow.
                        -- * When k + 1 < WORD_SIZE_IN_BITS, (q + 1) * 2^e <= 2^(fDigits + e) = 2^(k+1) < 2^WORD_SIZE_IN_BITS, so (q + 1) * 2^e does not overflow.
                        -- * q + 1 <= 2^fDigits and k + 1 <= WORD_SIZE_IN_BITS always hold.
                        -- * Therefore, ((q + 1) `unsafeShiftL` e) overflows only if q + 1 == 2^fDigits && k + 1 == WORD_SIZE_IN_BITS
                        awayfromzero :: a
awayfromzero = if Word
q Word -> Word -> Word
forall a. Num a => a -> a -> a
+ 1 Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== (1 Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
fDigits) Bool -> Bool -> Bool
&& Int
k Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Word -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize Word
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1 then
                                         -- (q + 1) `shiftL` e = 2^(fDigits + e) = 2^(k+1) = 2^(finiteBitSize n)
                                         Integer -> Int -> a
forall a. RealFloat a => Integer -> Int -> a
encodeFloat 1 (Word -> Int
forall b. FiniteBits b => b -> Int
finiteBitSize Word
n)
                                       else
                                         Word -> a
forall a b. (Integral a, Num b) => a -> b
fromIntegral ((Word
q Word -> Word -> Word
forall a. Num a => a -> a -> a
+ 1) Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
e)
                        parity :: Int
parity = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
q :: Int
                    in Bool -> Ordering -> Bool -> Int -> a -> a -> f a
forall (f :: * -> *) a.
RoundingStrategy f =>
Bool -> Ordering -> Bool -> Int -> a -> a -> f a
doRound
                         (Word
r Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== 0) -- exactness
                         (Word -> Word -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word
r (1 Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`unsafeShiftL` (Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1)))
                         Bool
neg
                         Int
parity
                         a
towardzero_or_exact
                         a
awayfromzero

    !fDigits :: Int
fDigits = a -> Int
forall a. RealFloat a => a -> Int
floatDigits (a
forall a. HasCallStack => a
undefined :: a) -- 53 for Double
    (_expMin :: Int
_expMin, !Int
expMax) = a -> (Int, Int)
forall a. RealFloat a => a -> (Int, Int)
floatRange (a
forall a. HasCallStack => a
undefined :: a) -- (-1021, 1024) for Double
{-# INLINABLE [0] positiveWordToBinaryFloatR# #-}
{-# SPECIALIZE
  positiveWordToBinaryFloatR# :: RoundingStrategy f => Bool -> Word# -> f Float
                               , RoundingStrategy f => Bool -> Word# -> f Double
                               , RealFloat a => Bool -> Word# -> RoundTiesToEven a
                               , RealFloat a => Bool -> Word# -> RoundTiesToAway a
                               , RealFloat a => Bool -> Word# -> RoundTowardPositive a
                               , RealFloat a => Bool -> Word# -> RoundTowardZero a
                               , RealFloat a => Bool -> Word# -> Product RoundTowardNegative RoundTowardPositive a
                               , Bool -> Word# -> RoundTiesToEven Float
                               , Bool -> Word# -> RoundTiesToAway Float
                               , Bool -> Word# -> RoundTowardPositive Float
                               , Bool -> Word# -> RoundTowardZero Float
                               , Bool -> Word# -> RoundTiesToEven Double
                               , Bool -> Word# -> RoundTiesToAway Double
                               , Bool -> Word# -> RoundTowardPositive Double
                               , Bool -> Word# -> RoundTowardZero Double
                               , Bool -> Word# -> Product RoundTowardNegative RoundTowardPositive Float
                               , Bool -> Word# -> Product RoundTowardNegative RoundTowardPositive Double
  #-}
{-# RULES
"positiveWordToBinaryFloatR#/RoundTowardNegative"
  positiveWordToBinaryFloatR# = \neg x -> RoundTowardNegative (roundTowardPositive (positiveWordToBinaryFloatR# (not neg) x))
  #-}

-- n > 0
fromPositiveIntegerR :: forall f a. (RealFloat a, RoundingStrategy f) => Bool -> Integer -> f a
fromPositiveIntegerR :: Bool -> Integer -> f a
fromPositiveIntegerR !Bool
neg !Integer
n = Bool -> f a -> f a
forall a. HasCallStack => Bool -> a -> a
assert (Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> 0) f a
result
  where
    result :: f a
result = let k :: Int
k = if Integer
base Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== 2 then
                       Integer -> Int
integerLog2' Integer
n
                     else
                       Integer -> Integer -> Int
integerLogBase' Integer
base Integer
n -- floor (logBase base n)
                 -- base^k <= n < base^(k+1)
             in if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
fDigits then
                  a -> f a
forall (f :: * -> *) a. RoundingStrategy f => a -> f a
exact (a -> f a) -> a -> f a
forall a b. (a -> b) -> a -> b
$ Integer -> a
forall a. Num a => Integer -> a
fromInteger Integer
n
                else
                  if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
expMax then
                    -- overflow
                    let inf :: a
inf = 1 a -> a -> a
forall a. Fractional a => a -> a -> a
/ 0
                    in Ordering -> Bool -> Int -> a -> a -> f a
forall (f :: * -> *) a.
RoundingStrategy f =>
Ordering -> Bool -> Int -> a -> a -> f a
inexact Ordering
GT Bool
neg 1 a
forall a. RealFloat a => a
maxFinite a
inf
                  else
                    -- k >= fDigits
                    let e :: Int
e = Int
k Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
fDigits Int -> Int -> Int
forall a. Num a => a -> a -> a
+ 1
                        -- k >= e (assuming fDigits >= 1)
                        -- Therefore, base^e <= n
                        (q :: Integer
q, r :: Integer
r) = Integer -> Integer -> Int -> (Integer, Integer)
quotRemByExpt Integer
n Integer
base Int
e -- n `quotRem` (base^e)
                        -- base^(fDigits - 1) <= q < base^fDigits, 0 <= r < base^(k-fDigits+1)
                        towardzero_or_exact :: a
towardzero_or_exact = Integer -> Int -> a
forall a. RealFloat a => Integer -> Int -> a
encodeFloat Integer
q Int
e
                        awayfromzero :: a
awayfromzero = Integer -> Int -> a
forall a. RealFloat a => Integer -> Int -> a
encodeFloat (Integer
q Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ 1) Int
e
                        parity :: Int
parity = Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
q :: Int
                    in Bool -> Ordering -> Bool -> Int -> a -> a -> f a
forall (f :: * -> *) a.
RoundingStrategy f =>
Bool -> Ordering -> Bool -> Int -> a -> a -> f a
doRound
                         (Integer -> Integer -> Int -> Integer -> Bool
isDivisibleByExpt Integer
n Integer
base Int
e Integer
r) -- exactness (r == 0)
                         (Integer -> Integer -> Integer -> Int -> Ordering
compareWithExpt Integer
base Integer
n Integer
r (Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1))
                         -- (compare r (expt base (e - 1)))
                         Bool
neg
                         Int
parity
                         a
towardzero_or_exact
                         a
awayfromzero

    !base :: Integer
base = a -> Integer
forall a. RealFloat a => a -> Integer
floatRadix (a
forall a. HasCallStack => a
undefined :: a) -- 2 or 10
    !fDigits :: Int
fDigits = a -> Int
forall a. RealFloat a => a -> Int
floatDigits (a
forall a. HasCallStack => a
undefined :: a) -- 53 for Double
    (_expMin :: Int
_expMin, !Int
expMax) = a -> (Int, Int)
forall a. RealFloat a => a -> (Int, Int)
floatRange (a
forall a. HasCallStack => a
undefined :: a) -- (-1021, 1024) for Double
{-# INLINABLE [0] fromPositiveIntegerR #-}
{-# SPECIALIZE
  fromPositiveIntegerR :: RealFloat a => Bool -> Integer -> RoundTiesToEven a
                        , RealFloat a => Bool -> Integer -> RoundTiesToAway a
                        , RealFloat a => Bool -> Integer -> RoundTowardPositive a
                        , RealFloat a => Bool -> Integer -> RoundTowardZero a
                        , RealFloat a => Bool -> Integer -> Product RoundTowardNegative RoundTowardPositive a
                        , RoundingStrategy f => Bool -> Integer -> f Double
                        , RoundingStrategy f => Bool -> Integer -> f Float
                        , Bool -> Integer -> RoundTiesToEven Double
                        , Bool -> Integer -> RoundTiesToAway Double
                        , Bool -> Integer -> RoundTowardPositive Double
                        , Bool -> Integer -> RoundTowardZero Double
                        , Bool -> Integer -> RoundTiesToEven Float
                        , Bool -> Integer -> RoundTiesToAway Float
                        , Bool -> Integer -> RoundTowardPositive Float
                        , Bool -> Integer -> RoundTowardZero Float
                        , Bool -> Integer -> Product RoundTowardNegative RoundTowardPositive Double
                        , Bool -> Integer -> Product RoundTowardNegative RoundTowardPositive Float
  #-}
{-# RULES
"fromPositiveIntegerR/RoundTowardNegative"
  fromPositiveIntegerR = \neg x -> RoundTowardNegative (roundTowardPositive (fromPositiveIntegerR (not neg) x))
  #-}