{-# Language BangPatterns #-}
{-# Language BlockArguments #-}
{-# Language Trustworthy #-}
-- | Computation with high-precision floats.
module LibBF
  (
    -- * Constants
    BigFloat
  , bfPosZero, bfNegZero
  , bfPosInf, bfNegInf
  , bfNaN

    -- * Conversions
  , bfFromWord
  , bfFromInt
  , bfFromDouble
  , bfFromInteger
  , bfFromString
  , bfToDouble
  , bfToString
  , bfToRep
  , BFRep(..)
  , BFNum(..)
  , bfFromBits
  , bfToBits

    -- * Predicates
  , bfIsFinite
  , bfIsInf
  , bfIsZero
  , bfIsNaN
  , bfIsNormal
  , bfIsSubnormal
  , bfCompare
  , bfSign
  , bfExponent
  , bfIsPos
  , bfIsNeg
  , Sign(..)

    -- * Arithmetic
  , bfNeg, bfAbs
  , bfAdd, bfSub, bfMul, bfDiv, bfRem
  , bfFMA, bfMulWord, bfMulInt, bfMul2Exp
  , bfSqrt
  , bfPow

    -- * Rounding
  , bfRoundFloat, bfRoundInt

    -- * Mutability
  , bfUnsafeThaw
  , bfUnsafeFreeze

    -- * Limits


    -- * Configuration
  , module LibBF.Opts
  ) where


import Data.Bits
import Data.Hashable
import Data.Word
import Data.Int
import System.IO.Unsafe

import LibBF.Mutable as M
import LibBF.Opts
import Control.DeepSeq

-- | Arbitrary precision floating point numbers.
newtype BigFloat = BigFloat BF

instance NFData BigFloat where
  rnf :: BigFloat -> ()
rnf BigFloat
x = BigFloat
x BigFloat -> () -> ()
`seq` ()


instance Show BigFloat where
  show :: BigFloat -> String
show = Int -> ShowFmt -> BigFloat -> String
bfToString Int
16 (Maybe Word -> ShowFmt
showFreeMin Maybe Word
forall a. Maybe a
Nothing ShowFmt -> ShowFmt -> ShowFmt
forall a. Semigroup a => a -> a -> a
<> ShowFmt
addPrefix)

--------------------------------------------------------------------------------
{-# NOINLINE ctxt #-}
{-# OPTIONS_GHC -fno-cse #-}
ctxt :: BFContext
ctxt :: BFContext
ctxt = IO BFContext -> BFContext
forall a. IO a -> a
unsafePerformIO IO BFContext
newContext

newBigFloat :: (BF -> IO ()) -> BigFloat
newBigFloat :: (BF -> IO ()) -> BigFloat
newBigFloat BF -> IO ()
f = IO BigFloat -> BigFloat
forall a. IO a -> a
unsafe (IO BigFloat -> BigFloat) -> IO BigFloat -> BigFloat
forall a b. (a -> b) -> a -> b
$
  do BF
bf <- BFContext -> IO BF
new BFContext
ctxt
     BF -> IO ()
f BF
bf
     BigFloat -> IO BigFloat
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BF -> BigFloat
BigFloat BF
bf)

newBigFloat' :: (BF -> IO a) -> (BigFloat,a)
newBigFloat' :: (BF -> IO a) -> (BigFloat, a)
newBigFloat' BF -> IO a
f = IO (BigFloat, a) -> (BigFloat, a)
forall a. IO a -> a
unsafe (IO (BigFloat, a) -> (BigFloat, a))
-> IO (BigFloat, a) -> (BigFloat, a)
forall a b. (a -> b) -> a -> b
$
  do BF
bf <- BFContext -> IO BF
new BFContext
ctxt
     a
a <- BF -> IO a
f BF
bf
     (BigFloat, a) -> IO (BigFloat, a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (BF -> BigFloat
BigFloat BF
bf, a
a)

unsafe :: IO a -> a
unsafe :: IO a -> a
unsafe = IO a -> a
forall a. IO a -> a
unsafePerformIO

--------------------------------------------------------------------------------
-- Constants

-- | Positive zero.
bfPosZero :: BigFloat
bfPosZero :: BigFloat
bfPosZero = (BF -> IO ()) -> BigFloat
newBigFloat (Sign -> BF -> IO ()
setZero Sign
Pos)

-- | Negative zero.
bfNegZero :: BigFloat
bfNegZero :: BigFloat
bfNegZero = (BF -> IO ()) -> BigFloat
newBigFloat (Sign -> BF -> IO ()
setZero Sign
Neg)

-- | Positive infinity.
bfPosInf :: BigFloat
bfPosInf :: BigFloat
bfPosInf = (BF -> IO ()) -> BigFloat
newBigFloat (Sign -> BF -> IO ()
setInf Sign
Pos)

-- | Negative infinity.
bfNegInf :: BigFloat
bfNegInf :: BigFloat
bfNegInf = (BF -> IO ()) -> BigFloat
newBigFloat (Sign -> BF -> IO ()
setInf Sign
Neg)

-- | Not-a-number.
bfNaN :: BigFloat
bfNaN :: BigFloat
bfNaN = (BF -> IO ()) -> BigFloat
newBigFloat BF -> IO ()
setNaN

-- | A floating point number corresponding to the given word.
bfFromWord :: Word64 -> BigFloat
bfFromWord :: Word64 -> BigFloat
bfFromWord = (BF -> IO ()) -> BigFloat
newBigFloat ((BF -> IO ()) -> BigFloat)
-> (Word64 -> BF -> IO ()) -> Word64 -> BigFloat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> BF -> IO ()
setWord

-- | A floating point number corresponding to the given int.
bfFromInt :: Int64 -> BigFloat
bfFromInt :: Int64 -> BigFloat
bfFromInt = (BF -> IO ()) -> BigFloat
newBigFloat ((BF -> IO ()) -> BigFloat)
-> (Int64 -> BF -> IO ()) -> Int64 -> BigFloat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> BF -> IO ()
setInt

-- | A floating point number corresponding to the given double.
bfFromDouble :: Double -> BigFloat
bfFromDouble :: Double -> BigFloat
bfFromDouble = (BF -> IO ()) -> BigFloat
newBigFloat ((BF -> IO ()) -> BigFloat)
-> (Double -> BF -> IO ()) -> Double -> BigFloat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> BF -> IO ()
setDouble

-- | A floating point number corresponding to the given integer.
bfFromInteger :: Integer -> BigFloat
bfFromInteger :: Integer -> BigFloat
bfFromInteger = (BF -> IO ()) -> BigFloat
newBigFloat ((BF -> IO ()) -> BigFloat)
-> (Integer -> BF -> IO ()) -> Integer -> BigFloat
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Integer -> BF -> IO ()
setInteger

-- | IEEE 754 equality
instance Eq BigFloat where
  BigFloat BF
x == :: BigFloat -> BigFloat -> Bool
== BigFloat BF
y = IO Bool -> Bool
forall a. IO a -> a
unsafe (BF -> BF -> IO Bool
cmpEq BF
x BF
y)

-- | IEEE 754 comparisons
instance Ord BigFloat where
  BigFloat BF
x < :: BigFloat -> BigFloat -> Bool
< BigFloat BF
y  = IO Bool -> Bool
forall a. IO a -> a
unsafe (BF -> BF -> IO Bool
cmpLT BF
x BF
y)
  BigFloat BF
x <= :: BigFloat -> BigFloat -> Bool
<= BigFloat BF
y = IO Bool -> Bool
forall a. IO a -> a
unsafe (BF -> BF -> IO Bool
cmpLEQ BF
x BF
y)


instance Hashable BigFloat where
  hashWithSalt :: Int -> BigFloat -> Int
hashWithSalt Int
s BigFloat
x = Int -> BFRep -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
s (BigFloat -> BFRep
bfToRep BigFloat
x)


{-| Compare the two numbers.  The special values are ordered like this:

      * -0 < 0
      * NaN == NaN
      * NaN is larger than all other numbers

Note that this differs from `(<=)`
-}
bfCompare :: BigFloat -> BigFloat -> Ordering
bfCompare :: BigFloat -> BigFloat -> Ordering
bfCompare (BigFloat BF
x) (BigFloat BF
y) = IO Ordering -> Ordering
forall a. IO a -> a
unsafe (BF -> BF -> IO Ordering
cmp BF
x BF
y)


-- | Is this a finite (i.e., non-infinite, non NaN) number.
bfIsFinite :: BigFloat -> Bool
bfIsFinite :: BigFloat -> Bool
bfIsFinite (BigFloat BF
x) = IO Bool -> Bool
forall a. IO a -> a
unsafe (BF -> IO Bool
isFinite BF
x)

-- | Is this value NaN.
bfIsNaN :: BigFloat -> Bool
bfIsNaN :: BigFloat -> Bool
bfIsNaN (BigFloat BF
x) = IO Bool -> Bool
forall a. IO a -> a
unsafe (BF -> IO Bool
M.isNaN BF
x)

-- | Is this value infinite
bfIsInf :: BigFloat -> Bool
bfIsInf :: BigFloat -> Bool
bfIsInf (BigFloat BF
x) = IO Bool -> Bool
forall a. IO a -> a
unsafe (BF -> IO Bool
isInf BF
x)

-- | This is a "normal" number, which means it is not
--   a NaN, not a zero, not infinite, and not subnormal.
bfIsNormal :: BFOpts -> BigFloat -> Bool
bfIsNormal :: BFOpts -> BigFloat -> Bool
bfIsNormal BFOpts
opts BigFloat
bf =
  case BigFloat -> BFRep
bfToRep BigFloat
bf of
    rep :: BFRep
rep@(BFRep Sign
_sgn (Num Integer
_ Int64
_)) -> Bool -> Bool
not (BFOpts -> BFRep -> Bool
repIsSubnormal BFOpts
opts BFRep
rep)
    BFRep
_ -> Bool
False

-- | This number is "subnormal", which means it is among the smallest
--   representable numbers for the given precision and exponent bits.
--   These numbers differ from "normal" numbers in that they do not use
--   an implicit leading 1 bit in the binary representation.
bfIsSubnormal :: BFOpts -> BigFloat -> Bool
bfIsSubnormal :: BFOpts -> BigFloat -> Bool
bfIsSubnormal BFOpts
opts BigFloat
bf = BFOpts -> BFRep -> Bool
repIsSubnormal BFOpts
opts (BigFloat -> BFRep
bfToRep BigFloat
bf)

-- | Get the sign of a number.  Returns 'Nothing' if the number is `NaN`.
bfSign :: BigFloat -> Maybe Sign
bfSign :: BigFloat -> Maybe Sign
bfSign (BigFloat BF
x) = IO (Maybe Sign) -> Maybe Sign
forall a. IO a -> a
unsafe (BF -> IO (Maybe Sign)
getSign BF
x)

-- | Compute the absolute value of a number.
bfAbs :: BigFloat -> BigFloat
bfAbs :: BigFloat -> BigFloat
bfAbs BigFloat
bf =
  case BigFloat -> Maybe Sign
bfSign BigFloat
bf of
    Just Sign
Neg -> BigFloat -> BigFloat
bfNeg BigFloat
bf
    Maybe Sign
_        -> BigFloat
bf

-- | Is this value positive
bfIsPos :: BigFloat -> Bool
bfIsPos :: BigFloat -> Bool
bfIsPos BigFloat
bf =
  case BigFloat -> Maybe Sign
bfSign BigFloat
bf of
    Just Sign
Pos -> Bool
True
    Maybe Sign
_ -> Bool
False

-- | Is this value negative
bfIsNeg :: BigFloat -> Bool
bfIsNeg :: BigFloat -> Bool
bfIsNeg BigFloat
bf =
  case BigFloat -> Maybe Sign
bfSign BigFloat
bf of
    Just Sign
Neg -> Bool
True
    Maybe Sign
_ -> Bool
False

-- | Get the exponent for the given number.
-- Infinity, zero and NaN do not have an exponent.
bfExponent :: BigFloat -> Maybe Int64
bfExponent :: BigFloat -> Maybe Int64
bfExponent (BigFloat BF
x) = IO (Maybe Int64) -> Maybe Int64
forall a. IO a -> a
unsafe (BF -> IO (Maybe Int64)
getExp BF
x)

-- | Is this value a zero.
bfIsZero :: BigFloat -> Bool
bfIsZero :: BigFloat -> Bool
bfIsZero (BigFloat BF
x) = IO Bool -> Bool
forall a. IO a -> a
unsafe (BF -> IO Bool
isZero BF
x)

-- | Negate a floating point number.
bfNeg :: BigFloat -> BigFloat
bfNeg :: BigFloat -> BigFloat
bfNeg (BigFloat BF
x) = (BF -> IO ()) -> BigFloat
newBigFloat (\BF
bf -> BF -> BF -> IO ()
setBF BF
x BF
bf IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BF -> IO ()
fneg BF
bf)

-- | Add two numbers useing the given options.
bfAdd :: BFOpts -> BigFloat -> BigFloat -> (BigFloat,Status)
bfAdd :: BFOpts -> BigFloat -> BigFloat -> (BigFloat, Status)
bfAdd BFOpts
opt (BigFloat BF
x) (BigFloat BF
y) = (BF -> IO Status) -> (BigFloat, Status)
forall a. (BF -> IO a) -> (BigFloat, a)
newBigFloat' (BFOpts -> BF -> BF -> BF -> IO Status
fadd BFOpts
opt BF
x BF
y)

-- | Subtract two numbers useing the given options.
bfSub :: BFOpts -> BigFloat -> BigFloat -> (BigFloat,Status)
bfSub :: BFOpts -> BigFloat -> BigFloat -> (BigFloat, Status)
bfSub BFOpts
opt (BigFloat BF
x) (BigFloat BF
y) = (BF -> IO Status) -> (BigFloat, Status)
forall a. (BF -> IO a) -> (BigFloat, a)
newBigFloat' (BFOpts -> BF -> BF -> BF -> IO Status
fsub BFOpts
opt BF
x BF
y)

-- | Multiply two numbers using the given options.
bfMul :: BFOpts -> BigFloat -> BigFloat -> (BigFloat,Status)
bfMul :: BFOpts -> BigFloat -> BigFloat -> (BigFloat, Status)
bfMul BFOpts
opt (BigFloat BF
x) (BigFloat BF
y) = (BF -> IO Status) -> (BigFloat, Status)
forall a. (BF -> IO a) -> (BigFloat, a)
newBigFloat' (BFOpts -> BF -> BF -> BF -> IO Status
fmul BFOpts
opt BF
x BF
y)

-- | Multiply a number and a word, using the given options.
bfMulWord :: BFOpts -> BigFloat -> Word64 -> (BigFloat,Status)
bfMulWord :: BFOpts -> BigFloat -> Word64 -> (BigFloat, Status)
bfMulWord BFOpts
opt (BigFloat BF
x) Word64
y = (BF -> IO Status) -> (BigFloat, Status)
forall a. (BF -> IO a) -> (BigFloat, a)
newBigFloat' (BFOpts -> BF -> Word64 -> BF -> IO Status
fmulWord BFOpts
opt BF
x Word64
y)

-- | Multiply a number and an int, using the given options.
bfMulInt :: BFOpts -> BigFloat -> Int64 -> (BigFloat,Status)
bfMulInt :: BFOpts -> BigFloat -> Int64 -> (BigFloat, Status)
bfMulInt BFOpts
opt (BigFloat BF
x) Int64
y = (BF -> IO Status) -> (BigFloat, Status)
forall a. (BF -> IO a) -> (BigFloat, a)
newBigFloat' (BFOpts -> BF -> Int64 -> BF -> IO Status
fmulInt BFOpts
opt BF
x Int64
y)

-- | Multiply a number by @2^e@.
bfMul2Exp :: BFOpts -> BigFloat -> Int -> (BigFloat,Status)
bfMul2Exp :: BFOpts -> BigFloat -> Int -> (BigFloat, Status)
bfMul2Exp BFOpts
opt (BigFloat BF
x) Int
e = (BF -> IO Status) -> (BigFloat, Status)
forall a. (BF -> IO a) -> (BigFloat, a)
newBigFloat' (\BF
p ->
  do BF -> BF -> IO ()
setBF BF
x BF
p
     BFOpts -> Int -> BF -> IO Status
fmul2Exp BFOpts
opt Int
e BF
p)

-- | Divide two numbers useing the given options.
bfDiv :: BFOpts -> BigFloat -> BigFloat -> (BigFloat,Status)
bfDiv :: BFOpts -> BigFloat -> BigFloat -> (BigFloat, Status)
bfDiv BFOpts
opt (BigFloat BF
x) (BigFloat BF
y) = (BF -> IO Status) -> (BigFloat, Status)
forall a. (BF -> IO a) -> (BigFloat, a)
newBigFloat' (BFOpts -> BF -> BF -> BF -> IO Status
fdiv BFOpts
opt BF
x BF
y)

-- | Compute the remainder @x - y * n@ where @n@ is the integer
--   nearest to @x/y@ (with ties broken to even values of @n@).
bfRem :: BFOpts -> BigFloat -> BigFloat -> (BigFloat, Status)
bfRem :: BFOpts -> BigFloat -> BigFloat -> (BigFloat, Status)
bfRem BFOpts
opt (BigFloat BF
x) (BigFloat BF
y) = (BF -> IO Status) -> (BigFloat, Status)
forall a. (BF -> IO a) -> (BigFloat, a)
newBigFloat' (BFOpts -> BF -> BF -> BF -> IO Status
frem BFOpts
opt BF
x BF
y)

-- | Compute the fused-multiply-add @(x*y)+z@
bfFMA :: BFOpts -> BigFloat -> BigFloat -> BigFloat -> (BigFloat, Status)
bfFMA :: BFOpts -> BigFloat -> BigFloat -> BigFloat -> (BigFloat, Status)
bfFMA BFOpts
opt (BigFloat BF
x) (BigFloat BF
y) (BigFloat BF
z) = (BF -> IO Status) -> (BigFloat, Status)
forall a. (BF -> IO a) -> (BigFloat, a)
newBigFloat' (BFOpts -> BF -> BF -> BF -> BF -> IO Status
ffma BFOpts
opt BF
x BF
y BF
z)

-- | Square root of two numbers useing the given options.
bfSqrt :: BFOpts -> BigFloat -> (BigFloat,Status)
bfSqrt :: BFOpts -> BigFloat -> (BigFloat, Status)
bfSqrt BFOpts
opt (BigFloat BF
x) = (BF -> IO Status) -> (BigFloat, Status)
forall a. (BF -> IO a) -> (BigFloat, a)
newBigFloat' (BFOpts -> BF -> BF -> IO Status
fsqrt BFOpts
opt BF
x)

-- | Round to a float matching the input parameters.
bfRoundFloat :: BFOpts -> BigFloat -> (BigFloat,Status)
bfRoundFloat :: BFOpts -> BigFloat -> (BigFloat, Status)
bfRoundFloat BFOpts
opt (BigFloat BF
x) = (BF -> IO Status) -> (BigFloat, Status)
forall a. (BF -> IO a) -> (BigFloat, a)
newBigFloat' (\BF
bf ->
  do BF -> BF -> IO ()
setBF BF
x BF
bf
     BFOpts -> BF -> IO Status
fround BFOpts
opt BF
bf
  )

-- | Round to an integer using the given rounding mode.
bfRoundInt :: RoundMode -> BigFloat -> (BigFloat,Status)
bfRoundInt :: RoundMode -> BigFloat -> (BigFloat, Status)
bfRoundInt RoundMode
r (BigFloat BF
x) = (BF -> IO Status) -> (BigFloat, Status)
forall a. (BF -> IO a) -> (BigFloat, a)
newBigFloat' (\BF
bf ->
  do BF -> BF -> IO ()
setBF BF
x BF
bf
     RoundMode -> BF -> IO Status
frint RoundMode
r BF
bf
  )

-- | Exponentiate a word to a positive integer power.
bfPow :: BFOpts -> BigFloat -> BigFloat -> (BigFloat, Status)
bfPow :: BFOpts -> BigFloat -> BigFloat -> (BigFloat, Status)
bfPow BFOpts
opts (BigFloat BF
x) (BigFloat BF
y) = (BF -> IO Status) -> (BigFloat, Status)
forall a. (BF -> IO a) -> (BigFloat, a)
newBigFloat' (BFOpts -> BF -> BF -> BF -> IO Status
fpow BFOpts
opts BF
x BF
y)

-- | Constant to a 'Double'
bfToDouble :: RoundMode -> BigFloat -> (Double, Status)
bfToDouble :: RoundMode -> BigFloat -> (Double, Status)
bfToDouble RoundMode
r (BigFloat BF
x) = IO (Double, Status) -> (Double, Status)
forall a. IO a -> a
unsafe (RoundMode -> BF -> IO (Double, Status)
toDouble RoundMode
r BF
x)

-- | Render as a 'String', using the given settings.
bfToString :: Int {- ^ Base -} -> ShowFmt -> BigFloat -> String
bfToString :: Int -> ShowFmt -> BigFloat -> String
bfToString Int
radix ShowFmt
opts (BigFloat BF
x) =
  IO String -> String
forall a. IO a -> a
unsafe (Int -> ShowFmt -> BF -> IO String
toString Int
radix ShowFmt
opts BF
x)

-- | Parse a number from the given string.
-- Returns @NaN` if the string does not correspond to a number we recognize.
bfFromString :: Int {- ^ Base -} -> BFOpts -> String -> (BigFloat,Status)
bfFromString :: Int -> BFOpts -> String -> (BigFloat, Status)
bfFromString Int
radix BFOpts
opts String
str =
  (BF -> IO Status) -> (BigFloat, Status)
forall a. (BF -> IO a) -> (BigFloat, a)
newBigFloat' \BF
bf ->
  do (Status
status,Int
_,Bool
usedAll) <- Int -> BFOpts -> String -> BF -> IO (Status, Int, Bool)
setString Int
radix BFOpts
opts String
str BF
bf
     if Bool
usedAll
        then Status -> IO Status
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
status
        else do BF -> IO ()
setNaN BF
bf
                Status -> IO Status
forall (f :: * -> *) a. Applicative f => a -> f a
pure Status
Ok

-- | The float as an exponentiated 'Integer'.
bfToRep :: BigFloat -> BFRep
bfToRep :: BigFloat -> BFRep
bfToRep (BigFloat BF
x) = IO BFRep -> BFRep
forall a. IO a -> a
unsafe (BF -> IO BFRep
toRep BF
x)

-- | Make a number mutable.
-- WARNING: This does not copy the number,
-- so it could break referential transperancy.
bfUnsafeThaw :: BigFloat -> BF
bfUnsafeThaw :: BigFloat -> BF
bfUnsafeThaw (BigFloat BF
x) = BF
x

-- | Make a number immutable.
-- WARNING: This does not copy the number,
-- so it could break referential transperancy.
bfUnsafeFreeze :: BF -> BigFloat
bfUnsafeFreeze :: BF -> BigFloat
bfUnsafeFreeze = BF -> BigFloat
BigFloat

--------------------------------------------------------------------------------

-- | Make a float using "raw" bits representing the bitvector
--   representation of a floating-point value with the
--   exponent and precision bits given by the options.
bfFromBits ::
  BFOpts ->
  Integer {- ^ Raw bits -} ->
  BigFloat

bfFromBits :: BFOpts -> Integer -> BigFloat
bfFromBits BFOpts
opts Integer
bits
  | Int
expoBiased Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Integer
mant Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
0 =            -- zero
    if Bool
isNeg then BigFloat
bfNegZero else BigFloat
bfPosZero

  | Int
expoBiased Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
eMask Bool -> Bool -> Bool
&& Integer
mant Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
==  Integer
0 =       -- infinity
    if Bool
isNeg then BigFloat
bfNegInf else BigFloat
bfPosInf

  | Int
expoBiased Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
eMask = BigFloat
bfNaN               -- NaN

  | Int
expoBiased Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 =                         -- Subnormal
    case BFOpts -> BigFloat -> Int -> (BigFloat, Status)
bfMul2Exp BFOpts
opts' (Integer -> BigFloat
bfFromInteger Integer
mant) (Int
expoVal Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) of
      (BigFloat
num,Status
Ok) -> if Bool
isNeg then BigFloat -> BigFloat
bfNeg BigFloat
num else BigFloat
num
      (BigFloat
_,Status
s)    -> String -> BigFloat
forall a. HasCallStack => String -> a
error (String -> BigFloat) -> String -> BigFloat
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"bfFromBits", String
"subnormal case", String
"Unexpected status:", Status -> String
forall a. Show a => a -> String
show Status
s, Integer -> String
forall a. Show a => a -> String
show Integer
bits, Integer -> String
forall a. Show a => a -> String
show Integer
mant, Int -> String
forall a. Show a => a -> String
show Int
expoVal, Int -> String
forall a. Show a => a -> String
show Int
e, Word -> String
forall a. Show a => a -> String
show Word
p ]

  | Bool
otherwise =                               -- Normal
    case BFOpts -> BigFloat -> Int -> (BigFloat, Status)
bfMul2Exp BFOpts
opts' (Integer -> BigFloat
bfFromInteger Integer
mantVal) Int
expoVal of
      (BigFloat
num,Status
Ok) -> if Bool
isNeg then BigFloat -> BigFloat
bfNeg BigFloat
num else BigFloat
num
      (BigFloat
_,Status
s)    -> String -> BigFloat
forall a. HasCallStack => String -> a
error (String -> BigFloat) -> String -> BigFloat
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"bfFromBits", String
"normal case", String
"Unexpected status:", Status -> String
forall a. Show a => a -> String
show Status
s, Integer -> String
forall a. Show a => a -> String
show Integer
bits, Integer -> String
forall a. Show a => a -> String
show Integer
mantVal, Int -> String
forall a. Show a => a -> String
show Int
expoVal, Int -> String
forall a. Show a => a -> String
show Int
e, Word -> String
forall a. Show a => a -> String
show Word
p ]

  where
  e :: Int
e = BFOpts -> Int
getExpBits BFOpts
opts
  p :: Word
p = BFOpts -> Word
getPrecBits BFOpts
opts

  opts' :: BFOpts
opts' = BFOpts
opts BFOpts -> BFOpts -> BFOpts
forall a. Semigroup a => a -> a -> a
<> BFOpts
allowSubnormal

  p' :: Int
p'         = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1                          :: Int
  eMask :: Int
eMask      = (Int
1 Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
e) Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1                          :: Int
  pMask :: Integer
pMask      = (Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
p') Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1                         :: Integer

  isNeg :: Bool
isNeg      = Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
testBit Integer
bits (Int
e Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
p')

  mant :: Integer
mant       = Integer
pMask Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
bits                              :: Integer
  mantVal :: Integer
mantVal    = Integer
mant Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`setBit` Int
p'                            :: Integer
  -- accounts for the implicit 1 bit

  expoBiased :: Int
expoBiased = Int
eMask Int -> Int -> Int
forall a. Bits a => a -> a -> a
.&. Integer -> Int
forall a. Num a => Integer -> a
fromInteger (Integer
bits Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
p')    :: Int
  bias :: Int
bias       = Int
eMask Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftR` Int
1                            :: Int
  expoVal :: Int
expoVal    = Int
expoBiased Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
bias Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
p'         :: Int


-- | Turn a float into raw bits.
-- @NaN@ is represented as a positive "quiet" @NaN@
-- (most significant bit in the significand is set, the rest of it is 0).
bfToBits :: BFOpts -> BigFloat -> Integer
bfToBits :: BFOpts -> BigFloat -> Integer
bfToBits BFOpts
opts BigFloat
bf = Integer
res
  where
  res :: Integer
res =     (Integer
isNeg      Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` (Int
eInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
p'))
        Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. (Integer
expBiased  Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
p')
        Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.|. (Integer
mant       Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
0)

  e :: Int
e = BFOpts -> Int
getExpBits BFOpts
opts
  p :: Word
p = BFOpts -> Word
getPrecBits BFOpts
opts

  p' :: Int
p' = Word -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
p Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 :: Int

  eMask :: Integer
eMask = (Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
e) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1   :: Integer
  pMask :: Integer
pMask = (Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
p') Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1   :: Integer

  (Integer
isNeg, Integer
expBiased, Integer
mant) =
    case BigFloat -> BFRep
bfToRep BigFloat
bf of
      BFRep
BFNaN       -> (Integer
0,  Integer
eMask, Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` (Int
p' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1))
      BFRep Sign
s BFNum
num -> (Integer
sign, Integer
be, Integer
ma)
        where
        sign :: Integer
sign = case Sign
s of
                Sign
Neg -> Integer
1
                Sign
Pos -> Integer
0

        (Integer
be,Integer
ma) =
          case BFNum
num of
            BFNum
Zero     -> (Integer
0,Integer
0)
            Num Integer
i Int64
ev
              | Integer
ex Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0 ->
                  (Integer
0, Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` (Int
p'Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
mInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
ex)) -- subnormal case
              | Bool
otherwise ->
                  (Integer
ex, (Integer
i Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` (Int
p' Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m)) Integer -> Integer -> Integer
forall a. Bits a => a -> a -> a
.&. Integer
pMask) -- normal case
              where
              m :: Int
m    = Int -> Integer -> Int
forall t t. (Num t, Num t, Bits t) => t -> t -> t
msb Int
0 Integer
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
              bias :: Integer
bias = Integer
eMask Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
1
              ex :: Integer
ex   = Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger Int64
ev Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
bias Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
m

            BFNum
Inf -> (Integer
eMask,Integer
0)

  msb :: t -> t -> t
msb !t
n t
j = if t
j t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0 then t
n else t -> t -> t
msb (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1) (t
j t -> Int -> t
forall a. Bits a => a -> Int -> a
`shiftR` Int
1)

-- | test if a given big float representation is subnormal
repIsSubnormal :: BFOpts -> BFRep -> Bool
repIsSubnormal :: BFOpts -> BFRep -> Bool
repIsSubnormal BFOpts
opts (BFRep Sign
_s (Num Integer
i Int64
ev)) = Integer
ex Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
0
  where
  e :: Int
e = BFOpts -> Int
getExpBits BFOpts
opts
  eMask :: Integer
eMask = (Integer
1 Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftL` Int
e) Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1   :: Integer
  bias :: Integer
bias = Integer
eMask Integer -> Int -> Integer
forall a. Bits a => a -> Int -> a
`shiftR` Int
1

  m :: Int
m    = Int -> Integer -> Int
forall t t. (Num t, Num t, Bits t) => t -> t -> t
msb (Int
0 :: Int) Integer
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
  ex :: Integer
ex   = Int64 -> Integer
forall a. Integral a => a -> Integer
toInteger Int64
ev Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
bias Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
m

  msb :: t -> t -> t
msb !t
n t
j = if t
j t -> t -> Bool
forall a. Eq a => a -> a -> Bool
== t
0 then t
n else t -> t -> t
msb (t
nt -> t -> t
forall a. Num a => a -> a -> a
+t
1) (t
j t -> Int -> t
forall a. Bits a => a -> Int -> a
`shiftR` Int
1)

repIsSubnormal BFOpts
_opts BFRep
_rep = Bool
False