{-# LINE 1 "src/LibBF/Opts.hsc" #-}
{-# Language PatternSynonyms, CApiFFI, ViewPatterns #-}
-- | Configuration and results for FP computation.
module LibBF.Opts
  (  -- * Options
    BFOpts(..)
  , allowSubnormal

    -- ** Presets
  , float16
  , float32
  , float64
  , float128
  , float256

    -- ** Precision
  , precBits
  , getPrecBits
  , precBitsMin
  , precBitsMax
  , infPrec

    -- ** Exponent Size
  , expBits
  , getExpBits
  , expBitsMin
  , expBitsMax

    -- ** Rounding mode
  , rnd
  , RoundMode(..)
  , pattern NearEven
  , pattern ToZero
  , pattern ToNegInf
  , pattern ToPosInf
  , pattern NearAway
  , pattern Away
  , pattern Faithful


  -- ** Pretty printing options
  , ShowFmt(..)
  , showRnd
  , showFixed
  , showFrac
  , showFree
  , showFreeMin
  , addPrefix
  , forceExp
  , radixMax

  -- * Status
  , Status(..)
  , pattern Ok
  , pattern InvalidOp
  , pattern DivideByZero
  , pattern Overflow
  , pattern Underflow
  , pattern Inexact
  , pattern MemError

  -- * Internal
  , LimbT
  , SLimbT
  , FlagsT
  )
  where

import Data.Word
import Data.Int
import Foreign.C.Types
import Data.Bits
import Data.List


-- | Internal: type for limbs
type LimbT  = Word64
{-# LINE 77 "src/LibBF/Opts.hsc" #-}

-- | Internal: type for signed limbs
type SLimbT = Int64
{-# LINE 80 "src/LibBF/Opts.hsc" #-}

-- | Internal: type for flags
type FlagsT = Word32
{-# LINE 83 "src/LibBF/Opts.hsc" #-}

-- | Specifies various computation settings, combined with 'Semigroup'.
data BFOpts = BFOpts !LimbT !FlagsT

instance Semigroup BFOpts where
  BFOpts LimbT
l FlagsT
f <> :: BFOpts -> BFOpts -> BFOpts
<> BFOpts LimbT
l1 FlagsT
f1 = LimbT -> FlagsT -> BFOpts
BFOpts (LimbT -> LimbT -> LimbT
forall a. Ord a => a -> a -> a
max LimbT
l LimbT
l1) (FlagsT
f FlagsT -> FlagsT -> FlagsT
forall a. Bits a => a -> a -> a
.|. FlagsT
f1)


-- | Use infinite precision.  This should be used with caution,
-- as it could exhause memory, and at the moment the library
-- does not handle this gracefully at all (core dumps).
infPrec :: BFOpts
infPrec :: BFOpts
infPrec = LimbT -> FlagsT -> BFOpts
BFOpts LimbT
4611686018427387903 FlagsT
0
{-# LINE 96 "src/LibBF/Opts.hsc" #-}

-- | Use this many bits to represent the mantissa in the computation.
-- The input should be in the interval defined by 'precMin' and 'precMax'
precBits :: Word -> BFOpts
precBits :: Word -> BFOpts
precBits Word
n = LimbT -> FlagsT -> BFOpts
BFOpts (Word -> LimbT
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n) FlagsT
0

-- | Retrieve how many bits to represent the mantissa in the computation.
getPrecBits :: BFOpts -> Word
getPrecBits :: BFOpts -> Word
getPrecBits (BFOpts LimbT
n FlagsT
_) = LimbT -> Word
forall a b. (Integral a, Num b) => a -> b
fromIntegral LimbT
n

-- | Use the given rounding mode.
-- If none is specified, then the default is 'NearEven'.
rnd :: RoundMode -> BFOpts
rnd :: RoundMode -> BFOpts
rnd (RoundMode FlagsT
r) = LimbT -> FlagsT -> BFOpts
BFOpts LimbT
0 FlagsT
r

-- | The smallest supported precision (in bits).
foreign import capi "libbf.h value BF_PREC_MIN"
  precBitsMin :: Int

-- | The largest supported precision (in bits).
-- Memory could run out before we run out of precision.
foreign import capi "libbf.h value BF_PREC_MAX"
  precBitsMax :: Int

{- | Allow denormalized answers. -}
allowSubnormal :: BFOpts
allowSubnormal :: BFOpts
allowSubnormal = LimbT -> FlagsT -> BFOpts
BFOpts LimbT
0 FlagsT
8
{-# LINE 123 "src/LibBF/Opts.hsc" #-}


foreign import capi "libbf.h bf_set_exp_bits"
  bf_set_exp_bits :: CInt -> FlagsT

foreign import capi "libbf.h bf_get_exp_bits"
  bf_get_exp_bits :: FlagsT -> CInt

-- | Set how many bits to use to represent the exponent.
-- Should fit in the range defined by 'expBitsMin' and 'expBitsMax'.
expBits :: Int -> BFOpts
expBits :: Int -> BFOpts
expBits Int
n = LimbT -> FlagsT -> BFOpts
BFOpts LimbT
0 (CInt -> FlagsT
bf_set_exp_bits (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
n))

-- | Get the number of exponent bits from a @BFOpts@ value.
getExpBits :: BFOpts -> Int
getExpBits :: BFOpts -> Int
getExpBits (BFOpts LimbT
_ FlagsT
f) = CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (FlagsT -> CInt
bf_get_exp_bits FlagsT
f)

{-| The smallest supported number of bits in the exponent. -}
foreign import capi "libbf.h value BF_EXP_BITS_MIN"
  expBitsMin :: Int

{-| The largest number of exponent bits supported. -}
foreign import capi "libbf.h value BF_EXP_BITS_MAX"
  expBitsMax :: Int



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

-- | Precision 11, exponent 5
float16:: RoundMode -> BFOpts
float16 :: RoundMode -> BFOpts
float16 RoundMode
r = RoundMode -> BFOpts
rnd RoundMode
r BFOpts -> BFOpts -> BFOpts
forall a. Semigroup a => a -> a -> a
<> Word -> BFOpts
precBits Word
11 BFOpts -> BFOpts -> BFOpts
forall a. Semigroup a => a -> a -> a
<> Int -> BFOpts
expBits Int
5

-- | Precision 24, exponent 8
float32 :: RoundMode -> BFOpts
float32 :: RoundMode -> BFOpts
float32 RoundMode
r = RoundMode -> BFOpts
rnd RoundMode
r BFOpts -> BFOpts -> BFOpts
forall a. Semigroup a => a -> a -> a
<> Word -> BFOpts
precBits Word
24 BFOpts -> BFOpts -> BFOpts
forall a. Semigroup a => a -> a -> a
<> Int -> BFOpts
expBits Int
8

-- | Precision 53, exponent 11
float64 :: RoundMode -> BFOpts
float64 :: RoundMode -> BFOpts
float64 RoundMode
r = RoundMode -> BFOpts
rnd RoundMode
r BFOpts -> BFOpts -> BFOpts
forall a. Semigroup a => a -> a -> a
<> Word -> BFOpts
precBits Word
53 BFOpts -> BFOpts -> BFOpts
forall a. Semigroup a => a -> a -> a
<> Int -> BFOpts
expBits Int
11

-- | Precision 113, exponent 15
float128 :: RoundMode -> BFOpts
float128 :: RoundMode -> BFOpts
float128 RoundMode
r = RoundMode -> BFOpts
rnd RoundMode
r BFOpts -> BFOpts -> BFOpts
forall a. Semigroup a => a -> a -> a
<> Word -> BFOpts
precBits Word
113 BFOpts -> BFOpts -> BFOpts
forall a. Semigroup a => a -> a -> a
<> Int -> BFOpts
expBits Int
15

-- | Precision 237, exponent 19
float256 :: RoundMode -> BFOpts
float256 :: RoundMode -> BFOpts
float256 RoundMode
r = RoundMode -> BFOpts
rnd RoundMode
r BFOpts -> BFOpts -> BFOpts
forall a. Semigroup a => a -> a -> a
<> Word -> BFOpts
precBits Word
237 BFOpts -> BFOpts -> BFOpts
forall a. Semigroup a => a -> a -> a
<> Int -> BFOpts
expBits Int
19


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

-- | Settings for rendering numbers as 'String'.
data ShowFmt = ShowFmt !LimbT !FlagsT

-- | Use this rounding mode.
showRnd :: RoundMode -> ShowFmt
showRnd :: RoundMode -> ShowFmt
showRnd (RoundMode FlagsT
r) = LimbT -> FlagsT -> ShowFmt
ShowFmt LimbT
1 FlagsT
r

instance Semigroup ShowFmt where
  ShowFmt LimbT
a FlagsT
x <> :: ShowFmt -> ShowFmt -> ShowFmt
<> ShowFmt LimbT
b FlagsT
y = LimbT -> FlagsT -> ShowFmt
ShowFmt (LimbT -> LimbT -> LimbT
forall a. Ord a => a -> a -> a
max LimbT
a LimbT
b) (FlagsT
x FlagsT -> FlagsT -> FlagsT
forall a. Bits a => a -> a -> a
.|. FlagsT
y)

{-| Show this many significant digits total . -}
showFixed :: Word -> ShowFmt
showFixed :: Word -> ShowFmt
showFixed Word
n = LimbT -> FlagsT -> ShowFmt
ShowFmt (Word -> LimbT
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n) FlagsT
0
{-# LINE 188 "src/LibBF/Opts.hsc" #-}

{-| Show this many digits after the decimal point. -}
showFrac :: Word -> ShowFmt
showFrac :: Word -> ShowFmt
showFrac Word
n = LimbT -> FlagsT -> ShowFmt
ShowFmt (Word -> LimbT
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n) FlagsT
65536
{-# LINE 192 "src/LibBF/Opts.hsc" #-}

{-| Use as many digits as necessary to match the required precision
   rounding to nearest and the subnormal+exponent configuration of 'FlagsT'.
   The result is meaningful only if the input is already rounded to
   the wanted precision.

   Infinite precision, indicated by giving 'Nothing' for the precision
   is supported when the radix is a power of two. -}
showFree :: Maybe Word -> ShowFmt
showFree :: Maybe Word -> ShowFmt
showFree Maybe Word
mb = LimbT -> FlagsT -> ShowFmt
ShowFmt LimbT
prec FlagsT
131072
{-# LINE 202 "src/LibBF/Opts.hsc" #-}
  where prec :: LimbT
prec = case Maybe Word
mb of
                 Maybe Word
Nothing -> LimbT
4611686018427387903
{-# LINE 204 "src/LibBF/Opts.hsc" #-}
                 Just Word
n  -> Word -> LimbT
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n


{-| same as 'showFree' but uses the minimum number of digits
(takes more computation time). -}
showFreeMin :: Maybe Word -> ShowFmt
showFreeMin :: Maybe Word -> ShowFmt
showFreeMin Maybe Word
mb = LimbT -> FlagsT -> ShowFmt
ShowFmt LimbT
prec FlagsT
196608
{-# LINE 211 "src/LibBF/Opts.hsc" #-}
  where prec :: LimbT
prec = case Maybe Word
mb of
                 Maybe Word
Nothing -> LimbT
4611686018427387903
{-# LINE 213 "src/LibBF/Opts.hsc" #-}
                 Just Word
n  -> Word -> LimbT
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word
n



{- | add 0x prefix for base 16, 0o prefix for base 8 or 0b prefix for
   base 2 if non zero value -}
addPrefix :: ShowFmt
addPrefix :: ShowFmt
addPrefix = LimbT -> FlagsT -> ShowFmt
ShowFmt LimbT
0 FlagsT
2097152
{-# LINE 221 "src/LibBF/Opts.hsc" #-}

-- | Show in exponential form.
forceExp :: ShowFmt
forceExp :: ShowFmt
forceExp = LimbT -> FlagsT -> ShowFmt
ShowFmt LimbT
0 FlagsT
1048576
{-# LINE 225 "src/LibBF/Opts.hsc" #-}


-- | Maximum radix when rendering to a for @bf_atof@ and @bf_froa@.
foreign import capi "libbf.h value BF_RADIX_MAX"
  radixMax :: Int





--------------------------------------------------------------------------------
-- | Specifies how to round when the result can't be precise.
newtype RoundMode = RoundMode FlagsT
                      deriving Int -> RoundMode -> ShowS
[RoundMode] -> ShowS
RoundMode -> String
(Int -> RoundMode -> ShowS)
-> (RoundMode -> String)
-> ([RoundMode] -> ShowS)
-> Show RoundMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RoundMode] -> ShowS
$cshowList :: [RoundMode] -> ShowS
show :: RoundMode -> String
$cshow :: RoundMode -> String
showsPrec :: Int -> RoundMode -> ShowS
$cshowsPrec :: Int -> RoundMode -> ShowS
Show

{-| Round to nearest, ties go to even. -}
pattern NearEven :: RoundMode
pattern $bNearEven :: RoundMode
$mNearEven :: forall r. RoundMode -> (Void# -> r) -> (Void# -> r) -> r
NearEven = RoundMode 0
{-# LINE 243 "src/LibBF/Opts.hsc" #-}

{-| Round toward zero. -}
pattern ToZero :: RoundMode
pattern $bToZero :: RoundMode
$mToZero :: forall r. RoundMode -> (Void# -> r) -> (Void# -> r) -> r
ToZero = RoundMode 1
{-# LINE 247 "src/LibBF/Opts.hsc" #-}

{-| Round down (toward -inf). -}
pattern ToNegInf :: RoundMode
pattern $bToNegInf :: RoundMode
$mToNegInf :: forall r. RoundMode -> (Void# -> r) -> (Void# -> r) -> r
ToNegInf = RoundMode 2
{-# LINE 251 "src/LibBF/Opts.hsc" #-}

{-| Round up (toward +inf). -}
pattern ToPosInf :: RoundMode
pattern $bToPosInf :: RoundMode
$mToPosInf :: forall r. RoundMode -> (Void# -> r) -> (Void# -> r) -> r
ToPosInf = RoundMode 3
{-# LINE 255 "src/LibBF/Opts.hsc" #-}

{-| Round to nearest, ties go away from zero. -}
pattern NearAway :: RoundMode
pattern $bNearAway :: RoundMode
$mNearAway :: forall r. RoundMode -> (Void# -> r) -> (Void# -> r) -> r
NearAway = RoundMode 4
{-# LINE 259 "src/LibBF/Opts.hsc" #-}

{-| Round away from zero -}
pattern Away :: RoundMode
pattern $bAway :: RoundMode
$mAway :: forall r. RoundMode -> (Void# -> r) -> (Void# -> r) -> r
Away = RoundMode 5
{-# LINE 263 "src/LibBF/Opts.hsc" #-}

{-| Faithful rounding (nondeterministic, either 'ToPosInf' or 'ToNegInf').
    The 'Inexact' flag is always set. -}
pattern Faithful :: RoundMode
pattern $bFaithful :: RoundMode
$mFaithful :: forall r. RoundMode -> (Void# -> r) -> (Void# -> r) -> r
Faithful = RoundMode 6
{-# LINE 268 "src/LibBF/Opts.hsc" #-}


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

-- | A set of flags indicating things that might go wrong.
newtype Status = Status CInt deriving (Status -> Status -> Bool
(Status -> Status -> Bool)
-> (Status -> Status -> Bool) -> Eq Status
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Status -> Status -> Bool
$c/= :: Status -> Status -> Bool
== :: Status -> Status -> Bool
$c== :: Status -> Status -> Bool
Eq,Eq Status
Eq Status
-> (Status -> Status -> Ordering)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Bool)
-> (Status -> Status -> Status)
-> (Status -> Status -> Status)
-> Ord Status
Status -> Status -> Bool
Status -> Status -> Ordering
Status -> Status -> Status
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Status -> Status -> Status
$cmin :: Status -> Status -> Status
max :: Status -> Status -> Status
$cmax :: Status -> Status -> Status
>= :: Status -> Status -> Bool
$c>= :: Status -> Status -> Bool
> :: Status -> Status -> Bool
$c> :: Status -> Status -> Bool
<= :: Status -> Status -> Bool
$c<= :: Status -> Status -> Bool
< :: Status -> Status -> Bool
$c< :: Status -> Status -> Bool
compare :: Status -> Status -> Ordering
$ccompare :: Status -> Status -> Ordering
$cp1Ord :: Eq Status
Ord)

instance Semigroup Status where
  Status CInt
a <> :: Status -> Status -> Status
<> Status CInt
b = CInt -> Status
Status (CInt
a CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.|. CInt
b)

instance Monoid Status where
  mempty :: Status
mempty = Status
Ok
  mappend :: Status -> Status -> Status
mappend = Status -> Status -> Status
forall a. Semigroup a => a -> a -> a
(<>)

checkStatus :: CInt -> Status -> Bool
checkStatus :: CInt -> Status -> Bool
checkStatus CInt
n (Status CInt
x) = (CInt
x CInt -> CInt -> CInt
forall a. Bits a => a -> a -> a
.&. CInt
n) CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
> CInt
0

-- | Succeeds if everything is OK.
pattern Ok :: Status
pattern $bOk :: Status
$mOk :: forall r. Status -> (Void# -> r) -> (Void# -> r) -> r
Ok = Status 0

-- | We tried to perform an invalid operation.
pattern InvalidOp :: Status
pattern $bInvalidOp :: Status
$mInvalidOp :: forall r. Status -> (Void# -> r) -> (Void# -> r) -> r
InvalidOp <- (checkStatus 1 -> True)
{-# LINE 292 "src/LibBF/Opts.hsc" #-}
  where InvalidOp = CInt -> Status
Status CInt
1
{-# LINE 293 "src/LibBF/Opts.hsc" #-}

-- | We divided by zero.
pattern DivideByZero :: Status
pattern $bDivideByZero :: Status
$mDivideByZero :: forall r. Status -> (Void# -> r) -> (Void# -> r) -> r
DivideByZero <- (checkStatus 2 -> True)
{-# LINE 297 "src/LibBF/Opts.hsc" #-}
  where DivideByZero = CInt -> Status
Status CInt
2
{-# LINE 298 "src/LibBF/Opts.hsc" #-}

-- | The result can't be represented because it is too large.
pattern Overflow :: Status
pattern $bOverflow :: Status
$mOverflow :: forall r. Status -> (Void# -> r) -> (Void# -> r) -> r
Overflow <- (checkStatus 4 -> True)
{-# LINE 302 "src/LibBF/Opts.hsc" #-}
  where Overflow = CInt -> Status
Status CInt
4
{-# LINE 303 "src/LibBF/Opts.hsc" #-}

-- | The result can't be represented because it is too small.
pattern Underflow :: Status
pattern $bUnderflow :: Status
$mUnderflow :: forall r. Status -> (Void# -> r) -> (Void# -> r) -> r
Underflow <- (checkStatus 8 -> True)
{-# LINE 307 "src/LibBF/Opts.hsc" #-}
  where Underflow = CInt -> Status
Status CInt
8
{-# LINE 308 "src/LibBF/Opts.hsc" #-}

-- | The result is not exact.
pattern Inexact :: Status
pattern $bInexact :: Status
$mInexact :: forall r. Status -> (Void# -> r) -> (Void# -> r) -> r
Inexact <- (checkStatus 16 -> True)
{-# LINE 312 "src/LibBF/Opts.hsc" #-}
  where Inexact = CInt -> Status
Status CInt
16
{-# LINE 313 "src/LibBF/Opts.hsc" #-}

-- | Memory error.  @NaN@ is returned.
pattern MemError :: Status
pattern $bMemError :: Status
$mMemError :: forall r. Status -> (Void# -> r) -> (Void# -> r) -> r
MemError <- (checkStatus 32 -> True)
{-# LINE 317 "src/LibBF/Opts.hsc" #-}
  where MemError = CInt -> Status
Status CInt
32
{-# LINE 318 "src/LibBF/Opts.hsc" #-}

instance Show Status where
  show :: Status -> String
show x :: Status
x@(Status CInt
i) = case Status
x of
                        Status
Ok -> String
"Ok"
                        Status
_  -> case [String]
checkInv of
                                [] -> String
"(Status " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show CInt
i String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
")"
                                [String]
xs -> String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
xs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"
    where
    checkInv :: [String]
checkInv = case Status
x of
                 Status
InvalidOp -> String
"InvalidOp" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
checkZ
                 Status
_         -> [String]
checkZ

    checkZ :: [String]
checkZ = case Status
x of
               Status
DivideByZero -> String
"DivideByZero" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
checkO
               Status
_            -> [String]
checkO

    checkO :: [String]
checkO = case Status
x of
               Status
Overflow -> String
"Overflow" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
checkU
               Status
_        -> [String]
checkU

    checkU :: [String]
checkU = case Status
x of
               Status
Underflow -> String
"Underflow" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
checkI
               Status
_ -> [String]
checkI

    checkI :: [String]
checkI = case Status
x of
               Status
Inexact -> String
"Inexact" String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
checkM
               Status
_       -> [String]
checkM

    checkM :: [String]
checkM = case Status
x of
               Status
MemError -> [String
"MemError"]
               Status
_        -> []