{-# 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 :: forall a. RealFloat a => 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 :: forall a. RealFloat a => 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 :: forall a. RealFloat a => 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 :: forall a. RealFloat a => 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 :: forall a. RealFloat a => 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 :: forall i a. (Integral i, RealFloat a) => 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 :: forall i a. (Integral i, RealFloat a) => 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 :: forall i a. (Integral i, RealFloat a) => 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 :: forall i a. (Integral i, RealFloat a) => 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 :: forall i a. (Integral i, RealFloat a) => 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 :: forall a (f :: * -> *).
(RealFloat a, RoundingStrategy f) =>
Integer -> f a
fromIntegerR Integer
n = case Integer -> Maybe Int
integerToIntMaybe Integer
n of
                   Just Int
x -> Int -> f a
forall i (f :: * -> *) a.
(Integral i, Bits i, RealFloat a, RoundingStrategy f) =>
i -> f a
fromIntegralRBits Int
x
                   Maybe Int
Nothing | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
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 :: forall i a (f :: * -> *).
(Integral i, RealFloat a, RoundingStrategy f) =>
i -> f a
fromIntegralR 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 :: forall i (f :: * -> *) a.
(Integral i, Bits i, RealFloat a, RoundingStrategy f) =>
i -> f a
fromIntegralRBits 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 (Maybe i
min', 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 a. 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
== Integer
2
  , Bool
signed
  , Just 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
< Int
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
== Integer
2
  , Bool -> Bool
not Bool
signed
  , Just 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
== i
0 = a -> f a
forall a. a -> f a
forall (f :: * -> *) a. RoundingStrategy f => a -> f a
exact a
0
           | i
x i -> i -> Bool
forall a. Ord a => a -> a -> Bool
< i
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 :: forall a i.
(Integral i, Bits i, RealFloat a) =>
Proxy a -> (Maybe i, Maybe i)
boundsForExactConversion Proxy a
_ = 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 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
             Maybe Integer
_ -> 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 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
             Maybe Integer
_ -> 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 :: forall i. Bits i => i -> Maybe Integer
minBoundAsInteger 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 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
-Int
1))
                               Maybe Int
Nothing   -> Maybe Integer
forall a. Maybe a
Nothing
                           else
                             Integer -> Maybe Integer
forall a. a -> Maybe a
Just Integer
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 :: forall i. Bits i => i -> Maybe Integer
maxBoundAsInteger i
dummyI = case i -> Maybe Int
forall a. Bits a => a -> Maybe Int
bitSizeMaybe i
dummyI of
                             Just 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
-Int
1) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
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
- Integer
1)
                             Maybe Int
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 :: forall a (f :: * -> *).
(RealFloat a, RoundingStrategy f) =>
Bool -> Word -> f a
positiveWordToBinaryFloatR Bool
neg (W# 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# :: forall (f :: * -> *) a.
(RealFloat a, RoundingStrategy f) =>
Bool -> Word# -> f a
positiveWordToBinaryFloatR# !Bool
neg 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 a. 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
- Int
1 Bool -> Bool -> Bool
&& Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
expMax then
                    -- overflow
                    let inf :: a
inf = a
1 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
0
                    in Ordering -> Bool -> Int -> a -> a -> f a
forall a. Ordering -> Bool -> Int -> a -> a -> f a
forall (f :: * -> *) a.
RoundingStrategy f =>
Ordering -> Bool -> Int -> a -> a -> f a
inexact Ordering
GT Bool
neg Int
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
+ Int
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
.&. ((Word
1 Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
e) Word -> Word -> Word
forall a. Num a => a -> a -> a
- Word
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
+ Word
1 Word -> Word -> Bool
forall a. Eq a => a -> a -> Bool
== (Word
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
- Int
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 Integer
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
+ Word
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 a. 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
== Word
0) -- exactness
                         (Word -> Word -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Word
r (Word
1 Word -> Int -> Word
forall a. Bits a => a -> Int -> a
`unsafeShiftL` (Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
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
    (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 :: forall (f :: * -> *) a.
(RealFloat a, RoundingStrategy f) =>
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
> Integer
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
== Integer
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 a. 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 = a
1 a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
0
                    in Ordering -> Bool -> Int -> a -> a -> f a
forall a. Ordering -> Bool -> Int -> a -> a -> f a
forall (f :: * -> *) a.
RoundingStrategy f =>
Ordering -> Bool -> Int -> a -> a -> f a
inexact Ordering
GT Bool
neg Int
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
+ Int
1
                        -- k >= e (assuming fDigits >= 1)
                        -- Therefore, base^e <= n
                        (Integer
q, 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
+ Integer
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 a. 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
- Int
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
    (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))
  #-}