---------------------------------------------------------------------------
-- |
-- Module      :  Data.Numbers.CrackNum
-- Copyright   :  (c) Levent Erkok
-- License     :  BSD3
-- Maintainer  :  erkokl@gmail.com
-- Stability   :  experimental
--
-- A library for formatting/analyzing FP and Integer values
-----------------------------------------------------------------------------

{-# LANGUAGE    FlexibleContexts #-}
{-# LANGUAGE    NamedFieldPuns    #-}

{-# OPTIONS_GHC -fno-warn-orphans #-}

module Data.Numbers.CrackNum
   (    -- * Internal representation of a Floating-point numbers
        FP(..), Precision(..), IPrecision(..), Kind(..)
        -- * Creating FP values
      , floatToFP, doubleToFP, stringToFP, integerToFP
        -- * Displaying FP and Int/Word values
      , displayFP, displayWord
        -- * Converting between floats and bit-representations
      , floatToWord, wordToFloat, doubleToWord, wordToDouble
   )
   where

import Data.Bits  (testBit, setBit, Bits)
import Data.Char  (toLower)
import Data.Int   (Int8, Int16, Int32, Int64)
import Data.List  (intercalate)
import Data.Maybe (isJust, fromJust, fromMaybe, catMaybes)

import Numeric
import Data.Numbers.CrackNum.Data
import Data.Numbers.CrackNum.Utils

import qualified Data.Numbers.FloatingHex as FH

import Data.Word         (Word32, Word64)
import Data.Array.ST     (newArray, readArray, MArray, STUArray)
import Data.Array.Unsafe (castSTUArray)
import GHC.ST            (runST, ST)

-- | Crack a Haskell Integer value as the given precision floating value. The Integer should
-- be the value corresponding to the bit-pattern as the float is laid out in memory according
-- to the IEEE rules.
integerToFP :: Precision -> Integer -> FP
integerToFP :: Precision -> Integer -> FP
integerToFP HP = Precision -> Int -> Int -> [Int] -> [Int] -> Integer -> FP
crack Precision
HP   15 15 [14, 13 .. 10]   [9, 8 .. 0]
integerToFP SP = Precision -> Int -> Int -> [Int] -> [Int] -> Integer -> FP
crack Precision
SP  127 31 [30, 29 .. 23] [22, 21 .. 0]
integerToFP DP = Precision -> Int -> Int -> [Int] -> [Int] -> Integer -> FP
crack Precision
DP 1023 63 [62, 61 .. 52] [51, 50 .. 0]

-- | Use Haskell Float to represent SP
spVal :: Bool -> Int -> [Bool] -> Float
spVal :: Bool -> Int -> [Bool] -> Float
spVal dn :: Bool
dn expVal :: Int
expVal fracBits :: [Bool]
fracBits = ((2::Float) Float -> Float -> Float
forall a. Floating a => a -> a -> a
** Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
expVal) Float -> Float -> Float
forall a. Num a => a -> a -> a
* Float -> Float
add1 Float
frac
  where frac :: Float
frac = [Float] -> Float
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Float] -> Float) -> [Float] -> Float
forall a b. (a -> b) -> a -> b
$ (Bool -> Int -> Float) -> [Bool] -> [Int] -> [Float]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\b :: Bool
b i :: Int
i -> if Bool
b then (2::Float)Float -> Float -> Float
forall a. Floating a => a -> a -> a
**(-(Int -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
i::Int))) else 0) [Bool]
fracBits [1..]
        add1 :: Float -> Float
add1 | Bool
dn   = Float -> Float
forall a. a -> a
id
             | Bool
True = (1Float -> Float -> Float
forall a. Num a => a -> a -> a
+)

-- | Use Haskell Double to represent DP
dpVal :: Bool -> Int -> [Bool] -> Double
dpVal :: Bool -> Int -> [Bool] -> Double
dpVal dn :: Bool
dn expVal :: Int
expVal fracBits :: [Bool]
fracBits = ((2::Double) Double -> Double -> Double
forall a. Floating a => a -> a -> a
** Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
expVal) Double -> Double -> Double
forall a. Num a => a -> a -> a
* Double -> Double
add1 Double
frac
  where frac :: Double
frac = [Double] -> Double
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum ([Double] -> Double) -> [Double] -> Double
forall a b. (a -> b) -> a -> b
$ (Bool -> Int -> Double) -> [Bool] -> [Int] -> [Double]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\b :: Bool
b i :: Int
i -> if Bool
b then (2::Double)Double -> Double -> Double
forall a. Floating a => a -> a -> a
**(-(Int -> Double
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
i::Int))) else 0) [Bool]
fracBits [1..]
        add1 :: Double -> Double
add1 | Bool
dn   = Double -> Double
forall a. a -> a
id
             | Bool
True = (1Double -> Double -> Double
forall a. Num a => a -> a -> a
+)

-- | Assemble a FP from the given bits and pieces.
crack :: Precision -> Int -> Int -> [Int] -> [Int] -> Integer -> FP
crack :: Precision -> Int -> Int -> [Int] -> [Int] -> Integer -> FP
crack vPrec :: Precision
vPrec vBias :: Int
vBias signPos :: Int
signPos expPos :: [Int]
expPos fracPos :: [Int]
fracPos val :: Integer
val
   = FP :: Integer
-> Precision
-> Bool
-> Int
-> Int
-> Int
-> [Bool]
-> String
-> Kind
-> FP
FP { intVal :: Integer
intVal    = Integer
val
        , prec :: Precision
prec      = Precision
vPrec
        , sign :: Bool
sign      = Bool
vSign
        , stExpt :: Int
stExpt    = Int
vStoredExp
        , expt :: Int
expt      = Int
vStoredExp Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
curBias
        , bias :: Int
bias      = Int
curBias
        , fracBits :: [Bool]
fracBits  = [Bool]
vFracBits
        , bitLayOut :: String
bitLayOut = [[Bool]] -> String
layOut [[Bool
vSign], [Bool]
vExpBits, [Bool]
vFracBits]
        , kind :: Kind
kind      = Kind
vKind
        }
   where bit :: Int -> Bool
bit i :: Int
i      = Integer
val Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
i
         vSign :: Bool
vSign      = Int -> Bool
bit Int
signPos
         vExpBits :: [Bool]
vExpBits   = (Int -> Bool) -> [Int] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Bool
bit [Int]
expPos
         vStoredExp :: Int
vStoredExp = [Bool] -> Int
forall a. Num a => [Bool] -> a
bv [Bool]
vExpBits
         vFracBits :: [Bool]
vFracBits  = (Int -> Bool) -> [Int] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map Int -> Bool
bit [Int]
fracPos
         isZero :: Bool
isZero     = [Bool] -> Bool
all0 [Bool]
vExpBits Bool -> Bool -> Bool
&& [Bool] -> Bool
all0 [Bool]
vFracBits
         isDenormal :: Bool
isDenormal = [Bool] -> Bool
all0 [Bool]
vExpBits Bool -> Bool -> Bool
&& [Bool] -> Bool
any1 [Bool]
vFracBits
         isInfinity :: Bool
isInfinity = [Bool] -> Bool
all1 [Bool]
vExpBits Bool -> Bool -> Bool
&& [Bool] -> Bool
all0 [Bool]
vFracBits
         isNAN :: Bool
isNAN      = [Bool] -> Bool
all1 [Bool]
vExpBits Bool -> Bool -> Bool
&& [Bool] -> Bool
any1 [Bool]
vFracBits
         vKind :: Kind
vKind | Bool
isZero     = Bool -> Kind
Zero Bool
vSign
               | Bool
isInfinity = Bool -> Kind
Infty Bool
vSign
               | Bool
isNAN      = if [Bool] -> Bool
forall a. [a] -> a
head [Bool]
vFracBits then Kind
QNaN else Kind
SNaN
               | Bool
isDenormal = Kind
Denormal
               | Bool
True       = Kind
Normal
         curBias :: Int
curBias = case Kind
vKind of
                     Denormal -> Int
vBias Int -> Int -> Int
forall a. Num a => a -> a -> a
- 1
                     _        -> Int
vBias

-- | Display a Floating-point number in a nicely formatted way. (This function is also available
-- through the 'Show' instance for 'FP', but is provided here for symmetry with 'displayWord'.)
displayFP :: FP -> String
displayFP :: FP -> String
displayFP FP{Integer
intVal :: Integer
intVal :: FP -> Integer
intVal, Precision
prec :: Precision
prec :: FP -> Precision
prec, Bool
sign :: Bool
sign :: FP -> Bool
sign, Int
stExpt :: Int
stExpt :: FP -> Int
stExpt, Int
bias :: Int
bias :: FP -> Int
bias, Int
expt :: Int
expt :: FP -> Int
expt, [Bool]
fracBits :: [Bool]
fracBits :: FP -> [Bool]
fracBits, String
bitLayOut :: String
bitLayOut :: FP -> String
bitLayOut, Kind
kind :: Kind
kind :: FP -> Kind
kind} = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" [String]
ls
  where ls :: [String]
ls =    [ "                  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inds1
                , "                  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inds2
                , "                  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inds3
                , "          Binary: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
bitLayOut
                , "             Hex: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Bool] -> String
hexDisp [Bool]
allBits
                , "       Precision: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Precision -> String
forall a. Show a => a -> String
show Precision
prec
                , "            Sign: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Bool
sign then "Negative" else "Positive"
                , "        Exponent: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
expt String -> String -> String
forall a. [a] -> [a] -> [a]
++ " (Stored: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
stExpt String -> String -> String
forall a. [a] -> [a] -> [a]
++ ", Bias: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
bias String -> String -> String
forall a. [a] -> [a] -> [a]
++ ")"
                , "       Hex-float: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
hexVal
                , "           Value: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val
                ]
             [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ "            Note: Representation for NaN's is not unique." | Kind -> Bool
isNaNKind Kind
kind]

        (inds1 :: String
inds1, inds2 :: String
inds2, inds3 :: String
inds3) = case Precision
prec of
                                  HP -> (String
hpInds1, String
hpInds2, String
hpInds3)
                                  SP -> (String
spInds1, String
spInds2, String
spInds3)
                                  DP -> (String
dpInds1, String
dpInds2, String
dpInds3)
        allBits :: [Bool]
allBits = case Precision
prec of
                    HP -> [Integer
intVal Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
i | Int
i <- Int -> [Int]
forall a. (Num a, Enum a) => a -> [a]
startsAt 15]
                    SP -> [Integer
intVal Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
i | Int
i <- Int -> [Int]
forall a. (Num a, Enum a) => a -> [a]
startsAt 31]
                    DP -> [Integer
intVal Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
i | Int
i <- Int -> [Int]
forall a. (Num a, Enum a) => a -> [a]
startsAt 63]
            where startsAt :: a -> [a]
startsAt n :: a
n = [a
n, a
na -> a -> a
forall a. Num a => a -> a -> a
-1 .. 0]

        dup :: b -> (b, b)
dup x :: b
x = (b
x, b
x)

        (val :: String
val, hexVal :: String
hexVal) = case Kind
kind of
                          Zero    False   -> ("+0.0", "0x0p+0")
                          Zero    True    -> ("-0.0", "-0x0p+0")
                          Infty   False   -> String -> (String, String)
forall b. b -> (b, b)
dup "+Infinity"
                          Infty   True    -> String -> (String, String)
forall b. b -> (b, b)
dup "-Infinity"
                          SNaN            -> String -> (String, String)
forall b. b -> (b, b)
dup "NaN (Signaling)"
                          QNaN            -> String -> (String, String)
forall b. b -> (b, b)
dup "NaN (Quietized)"
                          Denormal        -> Bool -> String -> (String, String)
nval Bool
True  " (DENORMAL)"
                          Normal          -> Bool -> String -> (String, String)
nval Bool
False " (NORMAL)"

        nval :: Bool -> String -> (String, String)
nval dn :: Bool
dn tag :: String
tag = (String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
tag, String
s String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
vh)
         where s :: String
s = if Bool
sign then "-" else "+"
               vd :: String
vd = case Precision
prec of
                      HP -> Maybe Int -> Float -> String -> String
forall a. RealFloat a => Maybe Int -> a -> String -> String
showGFloat Maybe Int
forall a. Maybe a
Nothing (Bool -> Int -> [Bool] -> Float
spVal Bool
dn Int
expt [Bool]
fracBits) ""
                      SP -> Maybe Int -> Float -> String -> String
forall a. RealFloat a => Maybe Int -> a -> String -> String
showGFloat Maybe Int
forall a. Maybe a
Nothing (Bool -> Int -> [Bool] -> Float
spVal Bool
dn Int
expt [Bool]
fracBits) ""
                      DP -> Maybe Int -> Double -> String -> String
forall a. RealFloat a => Maybe Int -> a -> String -> String
showGFloat Maybe Int
forall a. Maybe a
Nothing (Bool -> Int -> [Bool] -> Double
dpVal Bool
dn Int
expt [Bool]
fracBits) ""
               vh :: String
vh = case Precision
prec of
                      HP -> Float -> String -> String
forall a. RealFloat a => a -> String -> String
FH.showHFloat      (Bool -> Int -> [Bool] -> Float
spVal Bool
dn Int
expt [Bool]
fracBits) ""
                      SP -> Float -> String -> String
forall a. RealFloat a => a -> String -> String
FH.showHFloat      (Bool -> Int -> [Bool] -> Float
spVal Bool
dn Int
expt [Bool]
fracBits) ""
                      DP -> Double -> String -> String
forall a. RealFloat a => a -> String -> String
FH.showHFloat      (Bool -> Int -> [Bool] -> Double
dpVal Bool
dn Int
expt [Bool]
fracBits) ""

-- | Show instance for FP
instance Show FP where
   show :: FP -> String
show = FP -> String
displayFP

-- | Display a Integer (signed/unsigned) number in a nicely formatted way
displayWord :: IPrecision -> Integer -> String
displayWord :: IPrecision -> Integer -> String
displayWord iprec :: IPrecision
iprec intVal :: Integer
intVal = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate "\n" [String]
ls
  where (sg :: Bool
sg, sz :: Int
sz) = IPrecision -> (Bool, Int)
sgSz IPrecision
iprec
        ls :: [String]
ls =   [ "                  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe String -> String
forall a. HasCallStack => Maybe a -> a
fromJust Maybe String
inds1 | Maybe String -> Bool
forall a. Maybe a -> Bool
isJust Maybe String
inds1]
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ "                  " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
inds2
               , "          Binary: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Bool] -> String
binDisp [Bool]
allBits
               , "             Hex: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Bool] -> String
hexDisp [Bool]
allBits
               , "            Type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IPrecision -> String
forall a. Show a => a -> String
show IPrecision
iprec
               ]
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ "            Sign: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ if Bool
signBit then "Negative" else "Positive" | Bool
sg]
            [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [ "           Value: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
val
               ]
        (inds1 :: Maybe String
inds1, inds2 :: String
inds2) = case Int
sz of
                           8  -> (Maybe String
forall a. Maybe a
Nothing,     String
bInds2)
                           16 -> (String -> Maybe String
forall a. a -> Maybe a
Just String
wInds1, String
wInds2)
                           32 -> (String -> Maybe String
forall a. a -> Maybe a
Just String
dInds1, String
dInds2)
                           64 -> (String -> Maybe String
forall a. a -> Maybe a
Just String
qInds1, String
qInds2)
                           _  -> String -> (Maybe String, String)
forall a. HasCallStack => String -> a
error (String -> (Maybe String, String))
-> String -> (Maybe String, String)
forall a b. (a -> b) -> a -> b
$ "displayWord: Unexpected size: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
sz
        allBits :: [Bool]
allBits = [Integer
intVal Integer -> Int -> Bool
forall a. Bits a => a -> Int -> Bool
`testBit` Int
i | Int
i <- [Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-1, Int
szInt -> Int -> Int
forall a. Num a => a -> a -> a
-2 .. 0]]
        signBit :: Bool
signBit = [Bool] -> Bool
forall a. [a] -> a
head [Bool]
allBits
        val :: String
val | Bool -> Bool
not Bool
sg = Integer -> String
forall a. Show a => a -> String
show Integer
intVal
            | Bool
True   = case IPrecision
iprec of
                         I8  -> Int8 -> String
forall a. Show a => a -> String
show (Int8 -> String) -> Int8 -> String
forall a b. (a -> b) -> a -> b
$ Int8 -> Int8
forall a. Bits a => a -> a
adjust (0::Int8)
                         I16 -> Int16 -> String
forall a. Show a => a -> String
show (Int16 -> String) -> Int16 -> String
forall a b. (a -> b) -> a -> b
$ Int16 -> Int16
forall a. Bits a => a -> a
adjust (0::Int16)
                         I32 -> Int32 -> String
forall a. Show a => a -> String
show (Int32 -> String) -> Int32 -> String
forall a b. (a -> b) -> a -> b
$ Int32 -> Int32
forall a. Bits a => a -> a
adjust (0::Int32)
                         I64 -> Int64 -> String
forall a. Show a => a -> String
show (Int64 -> String) -> Int64 -> String
forall a b. (a -> b) -> a -> b
$ Int64 -> Int64
forall a. Bits a => a -> a
adjust (0::Int64)
                         _   -> String -> String
forall a. HasCallStack => String -> a
error (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ "displayWord: Unexpected type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ IPrecision -> String
forall a. Show a => a -> String
show IPrecision
iprec
        adjust :: Bits a => a -> a
        adjust :: a -> a
adjust v :: a
v = (Int -> a -> a) -> a -> [Int] -> a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((a -> Int -> a) -> Int -> a -> a
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> Int -> a
forall a. Bits a => a -> Int -> a
setBit) a
v [Int
i | (i :: Int
i, True) <- [Int] -> [Bool] -> [(Int, Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [0..] ([Bool] -> [Bool]
forall a. [a] -> [a]
reverse [Bool]
allBits)]

-- | Convert the given string to a IEEE number with the required precision
stringToFP :: Precision -> String -> FP
stringToFP :: Precision -> String -> FP
stringToFP precision :: Precision
precision input :: String
input
   = case Precision
precision of
        SP -> FP -> Maybe FP -> FP
forall a. a -> Maybe a -> a
fromMaybe (String -> FP
forall a. HasCallStack => String -> a
error (String -> FP) -> String -> FP
forall a b. (a -> b) -> a -> b
$ "*** stringToFP: Cannot read a valid SP number from: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
input) Maybe FP
mbF
        DP -> FP -> Maybe FP -> FP
forall a. a -> Maybe a -> a
fromMaybe (String -> FP
forall a. HasCallStack => String -> a
error (String -> FP) -> String -> FP
forall a b. (a -> b) -> a -> b
$ "*** stringToFP: Cannot read a valid DP number from: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
input) Maybe FP
mbD
        _  -> String -> FP
forall a. HasCallStack => String -> a
error (String -> FP) -> String -> FP
forall a b. (a -> b) -> a -> b
$ "*** stringToFP: Unsupported precision: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Precision -> String
forall a. Show a => a -> String
show Precision
precision
  where i :: String
i = (Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map Char -> Char
toLower ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== '+') String
input)
        specials :: [(String, (FP, FP))]
        specials :: [(String, (FP, FP))]
specials = [ (String
s, (Float -> FP
floatToFP Float
f, Double -> FP
doubleToFP Double
d))
                   | (s :: String
s, (f :: Float
f, d :: Double
d)) <- [ ("infinity",  ( Float
infinityF,            Double
infinityD))
                                    , ("-infinity", (-Float
infinityF,         -  Double
infinityD))
                                    , ("0",         ( 0,                    0))
                                    , ("-0",        (-0,                 -  0))
                                    , ("max",       ( Float
maxFiniteF,           Double
maxFiniteD))
                                    , ("-max",      (-Float
maxFiniteF,         - Double
maxFiniteD))
                                    , ("min",       ( Float
minNormalF,           Double
minNormalD))
                                    , ("-min",      (-Float
minNormalF,         - Double
minNormalD))
                                    , ("epsilon",   ( Float
epsilonF,             Double
epsilonD))]  ]
                                 [(String, (FP, FP))]
-> [(String, (FP, FP))] -> [(String, (FP, FP))]
forall a. [a] -> [a] -> [a]
++ [ ("ulp",       (Precision -> Integer -> FP
integerToFP Precision
SP 1,          Precision -> Integer -> FP
integerToFP Precision
DP 1))
                                    , ("nan",       (Precision -> Integer -> FP
integerToFP Precision
SP 0x7f800001, Precision -> Integer -> FP
integerToFP Precision
DP 0x7ff0000000000001))
                                    , ("snan",      (Precision -> Integer -> FP
integerToFP Precision
SP 0x7f800001, Precision -> Integer -> FP
integerToFP Precision
DP 0x7ff0000000000001))
                                    , ("qnan",      (Precision -> Integer -> FP
integerToFP Precision
SP 0x7fc00000, Precision -> Integer -> FP
integerToFP Precision
DP 0x7ff8000000000000))
                                    ]

        infinityF, maxFiniteF, minNormalF, epsilonF :: Float
        infinityF :: Float
infinityF  = 1Float -> Float -> Float
forall a. Fractional a => a -> a -> a
/0
        maxFiniteF :: Float
maxFiniteF = 3.40282347e+38
        minNormalF :: Float
minNormalF = 1.17549435e-38
        epsilonF :: Float
epsilonF   = 1.19209290e-07

        infinityD, maxFiniteD, minNormalD, epsilonD :: Double
        infinityD :: Double
infinityD  = 1Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/0
        maxFiniteD :: Double
maxFiniteD = 1.7976931348623157e+308
        minNormalD :: Double
minNormalD = 2.2250738585072014e-308
        epsilonD :: Double
epsilonD   = 2.2204460492503131e-16

        mbF, mbD :: Maybe FP
        (mbF :: Maybe FP
mbF, mbD :: Maybe FP
mbD) = case (String
i String -> [(String, (FP, FP))] -> Maybe (FP, FP)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
`lookup` [(String, (FP, FP))]
specials, String -> Maybe Float
forall a. (Read a, FloatingHexReader a) => String -> Maybe a
rd String
i :: Maybe Float, String -> Maybe Double
forall a. (Read a, FloatingHexReader a) => String -> Maybe a
rd String
i :: Maybe Double) of
                       (Just (f :: FP
f, d :: FP
d), _     , _     ) -> (FP -> Maybe FP
forall a. a -> Maybe a
Just FP
f,             FP -> Maybe FP
forall a. a -> Maybe a
Just FP
d)
                       (Nothing,     Just f :: Float
f, Just d :: Double
d) -> (FP -> Maybe FP
forall a. a -> Maybe a
Just (Float -> FP
floatToFP Float
f), FP -> Maybe FP
forall a. a -> Maybe a
Just (Double -> FP
doubleToFP Double
d))
                       (Nothing,     Just f :: Float
f, _     ) -> (FP -> Maybe FP
forall a. a -> Maybe a
Just (Float -> FP
floatToFP Float
f), Maybe FP
forall a. Maybe a
Nothing)
                       (Nothing,     _,      Just d :: Double
d) -> (Maybe FP
forall a. Maybe a
Nothing,            FP -> Maybe FP
forall a. a -> Maybe a
Just (Double -> FP
doubleToFP Double
d))
                       _                             -> (Maybe FP
forall a. Maybe a
Nothing,            Maybe FP
forall a. Maybe a
Nothing)

        rd :: (Read a, FH.FloatingHexReader a) => String -> Maybe a
        rd :: String -> Maybe a
rd s :: String
s = case [a
v | (v :: a
v, "") <- ReadS a
forall a. Read a => ReadS a
reads String
s] [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [Maybe a] -> [a]
forall a. [Maybe a] -> [a]
catMaybes [String -> Maybe a
forall a. FloatingHexReader a => String -> Maybe a
FH.readHFloat String
s] of
                 [v :: a
v] -> a -> Maybe a
forall a. a -> Maybe a
Just a
v
                 _   -> Maybe a
forall a. Maybe a
Nothing

-- | Turn a Haskell float to the internal detailed FP representation
floatToFP :: Float -> FP
floatToFP :: Float -> FP
floatToFP = Precision -> Integer -> FP
integerToFP Precision
SP (Integer -> FP) -> (Float -> Integer) -> Float -> FP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word32 -> Integer) -> (Float -> Word32) -> Float -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Word32
floatToWord

-- | Turn a Haskell double to the internal detailed FP representation
doubleToFP :: Double -> FP
doubleToFP :: Double -> FP
doubleToFP = Precision -> Integer -> FP
integerToFP Precision
DP (Integer -> FP) -> (Double -> Integer) -> Double -> FP
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word64 -> Integer) -> (Double -> Word64) -> Double -> Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Word64
doubleToWord

-------------------------------------------------------------------------
-- Reinterpreting float/double as word32/64 and back. Here, we use the
-- definitions from the reinterpret-cast package:
--
--     http://hackage.haskell.org/package/reinterpret-cast
--
-- The reason we steal these definitions is to make sure we keep minimal
-- dependencies and no FFI requirements anywhere.
-------------------------------------------------------------------------
-- | Reinterpret-casts a `Float` to a `Word32`.
floatToWord :: Float -> Word32
floatToWord :: Float -> Word32
floatToWord x :: Float
x = (forall s. ST s Word32) -> Word32
forall a. (forall s. ST s a) -> a
runST (Float -> ST s Word32
forall s a b.
(MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) =>
a -> ST s b
cast Float
x)
{-# INLINEABLE floatToWord #-}

-- | Reinterpret-casts a `Word32` to a `Float`.
wordToFloat :: Word32 -> Float
wordToFloat :: Word32 -> Float
wordToFloat x :: Word32
x = (forall s. ST s Float) -> Float
forall a. (forall s. ST s a) -> a
runST (Word32 -> ST s Float
forall s a b.
(MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) =>
a -> ST s b
cast Word32
x)
{-# INLINEABLE wordToFloat #-}

-- | Reinterpret-casts a `Double` to a `Word64`.
doubleToWord :: Double -> Word64
doubleToWord :: Double -> Word64
doubleToWord x :: Double
x = (forall s. ST s Word64) -> Word64
forall a. (forall s. ST s a) -> a
runST (Double -> ST s Word64
forall s a b.
(MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) =>
a -> ST s b
cast Double
x)
{-# INLINEABLE doubleToWord #-}

-- | Reinterpret-casts a `Word64` to a `Double`.
wordToDouble :: Word64 -> Double
wordToDouble :: Word64 -> Double
wordToDouble x :: Word64
x = (forall s. ST s Double) -> Double
forall a. (forall s. ST s a) -> a
runST (Word64 -> ST s Double
forall s a b.
(MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) =>
a -> ST s b
cast Word64
x)
{-# INLINEABLE wordToDouble #-}

{-# INLINE cast #-}
cast :: (MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) => a -> ST s b
cast :: a -> ST s b
cast x :: a
x = (Int, Int) -> a -> ST s (STUArray s Int a)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (0 :: Int, 0) a
x ST s (STUArray s Int a)
-> (STUArray s Int a -> ST s (STUArray s Int b))
-> ST s (STUArray s Int b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STUArray s Int a -> ST s (STUArray s Int b)
forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray ST s (STUArray s Int b) -> (STUArray s Int b -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (STUArray s Int b -> Int -> ST s b)
-> Int -> STUArray s Int b -> ST s b
forall a b c. (a -> b -> c) -> b -> a -> c
flip STUArray s Int b -> Int -> ST s b
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray 0