{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.Binary.IEEE754 (
-- * Parsing
getFloat16be, getFloat16le
, getFloat32be, getFloat32le
, getFloat64be, getFloat64le
-- * Serializing
, putFloat32be, putFloat32le
, putFloat64be, putFloat64le
) where
import Data.Bits ((.&.), (.|.), shiftL, shiftR, Bits)
import Data.Word (Word8)
import Data.List (foldl')
import qualified Data.ByteString as B
import Data.Binary.Get (Get, getByteString)
import Data.Binary.Put (Put, putByteString)
getFloat16be :: Get Float
getFloat16be = getFloat (ByteCount 2) splitBytes
getFloat16le :: Get Float
getFloat16le = getFloat (ByteCount 2) $ splitBytes . reverse
getFloat32be :: Get Float
getFloat32be = getFloat (ByteCount 4) splitBytes
getFloat32le :: Get Float
getFloat32le = getFloat (ByteCount 4) $ splitBytes . reverse
getFloat64be :: Get Double
getFloat64be = getFloat (ByteCount 8) splitBytes
getFloat64le :: Get Double
getFloat64le = getFloat (ByteCount 8) $ splitBytes . reverse
splitBytes :: [Word8] -> RawFloat
splitBytes bs = RawFloat width sign exp' sig expWidth sigWidth where
width = ByteCount (length bs)
nBits = bitsInWord8 bs
sign = if head bs .&. 0x80 == 0x80
then Negative
else Positive
expStart = 1
expWidth = exponentWidth nBits
expEnd = expStart + expWidth
exp' = Exponent . fromIntegral $ bitSlice bs expStart expEnd
sigWidth = nBits - expEnd
sig = Significand $ bitSlice bs expEnd nBits
merge :: (Read a, RealFloat a) => RawFloat -> a
merge f@(RawFloat _ _ e sig eWidth _)
| e == 0 = if sig == 0
then 0.0
else denormalised f
| e == eMax - 1 = if sig == 0
then read "Infinity"
else read "NaN"
| otherwise = normalised f
where eMax = 2 `pow` eWidth
normalised :: RealFloat a => RawFloat -> a
normalised f = encodeFloat fraction exp' where
Significand sig = rawSignificand f
Exponent exp' = unbiased - sigWidth
fraction = sig + (1 `bitShiftL` rawSignificandWidth f)
sigWidth = fromIntegral $ rawSignificandWidth f
unbiased = unbias (rawExponent f) (rawExponentWidth f)
denormalised :: RealFloat a => RawFloat -> a
denormalised f = encodeFloat sig exp' where
Significand sig = rawSignificand f
Exponent exp' = unbiased - sigWidth + 1
sigWidth = fromIntegral $ rawSignificandWidth f
unbiased = unbias (rawExponent f) (rawExponentWidth f)
getFloat :: (Read a, RealFloat a) => ByteCount
-> ([Word8] -> RawFloat) -> Get a
getFloat (ByteCount width) parser = do
raw <- fmap (parser . B.unpack) $ getByteString width
let absFloat = merge raw
return $ case rawSign raw of
Positive -> absFloat
Negative -> -absFloat
putFloat32be :: Float -> Put
putFloat32be = putFloat (ByteCount 4) id
putFloat32le :: Float -> Put
putFloat32le = putFloat (ByteCount 4) reverse
putFloat64be :: Double -> Put
putFloat64be = putFloat (ByteCount 8) id
putFloat64le :: Double -> Put
putFloat64le = putFloat (ByteCount 8) reverse
splitFloat :: RealFloat a => ByteCount -> a -> RawFloat
splitFloat width x = raw where
raw = RawFloat width sign clampedExp clampedSig expWidth sigWidth
sign = if isNegativeNaN x || isNegativeZero x || x < 0
then Negative
else Positive
clampedExp = clamp expWidth exp'
clampedSig = clamp sigWidth sig
(exp', sig) = case (dFraction, dExponent, biasedExp) of
(0, 0, _) -> (0, 0)
(_, _, 0) -> (0, Significand $ truncatedSig + 1)
_ -> (biasedExp, Significand truncatedSig)
expWidth = exponentWidth $ bitCount width
sigWidth = bitCount width - expWidth - 1 -- 1 for sign bit
(dFraction, dExponent) = decodeFloat x
rawExp = Exponent $ dExponent + fromIntegral sigWidth
biasedExp = bias rawExp expWidth
truncatedSig = abs dFraction - (1 `bitShiftL` sigWidth)
rawToBytes :: RawFloat -> [Word8]
rawToBytes raw = integerToBytes mashed width where
RawFloat width sign exp' sig expWidth sigWidth = raw
sign' :: Word8
sign' = case sign of
Positive -> 0
Negative -> 1
mashed = mashBits sig sigWidth .
mashBits exp' expWidth .
mashBits sign' 1 $ 0
clamp :: (Num a, Bits a) => BitCount -> a -> a
clamp = (.&.) . mask where
mask 1 = 1
mask n | n > 1 = (mask (n - 1) `shiftL` 1) + 1
mask _ = undefined
mashBits :: (Bits a, Integral a) => a -> BitCount -> Integer -> Integer
mashBits _ 0 x = x
mashBits y n x = (x `bitShiftL` n) .|. fromIntegral y
integerToBytes :: Integer -> ByteCount -> [Word8]
integerToBytes _ 0 = []
integerToBytes x n = bytes where
bytes = integerToBytes (x `shiftR` 8) (n - 1) ++ [step]
step = fromIntegral x .&. 0xFF
putFloat :: (RealFloat a) => ByteCount -> ([Word8] -> [Word8]) -> a -> Put
putFloat width f x = putByteString $ B.pack bytes where
bytes = f . rawToBytes . splitFloat width $ x
data RawFloat = RawFloat
{ rawWidth :: ByteCount
, rawSign :: Sign
, rawExponent :: Exponent
, rawSignificand :: Significand
, rawExponentWidth :: BitCount
, rawSignificandWidth :: BitCount
}
deriving (Show)
exponentWidth :: BitCount -> BitCount
exponentWidth k
| k == 16 = 5
| k == 32 = 8
| k `mod` 32 == 0 = ceiling (4 * logBase 2 (fromIntegral k)) - 13
| otherwise = error "Invalid length of floating-point value"
bias :: Exponent -> BitCount -> Exponent
bias e eWidth = e - (1 - (2 `pow` (eWidth - 1)))
unbias :: Exponent -> BitCount -> Exponent
unbias e eWidth = e + 1 - (2 `pow` (eWidth - 1))
data Sign = Positive | Negative
deriving (Show)
newtype Exponent = Exponent Int
deriving (Show, Eq, Num, Ord, Real, Enum, Integral, Bits)
newtype Significand = Significand Integer
deriving (Show, Eq, Num, Ord, Real, Enum, Integral, Bits)
newtype BitCount = BitCount Int
deriving (Show, Eq, Num, Ord, Real, Enum, Integral)
newtype ByteCount = ByteCount Int
deriving (Show, Eq, Num, Ord, Real, Enum, Integral)
bitCount :: ByteCount -> BitCount
bitCount (ByteCount x) = BitCount (x * 8)
bitsInWord8 :: [Word8] -> BitCount
bitsInWord8 = bitCount . ByteCount . length
bitShiftL :: (Bits a) => a -> BitCount -> a
bitShiftL x (BitCount n) = shiftL x n
bitShiftR :: (Bits a) => a -> BitCount -> a
bitShiftR x (BitCount n) = shiftR x n
bitSlice :: [Word8] -> BitCount -> BitCount -> Integer
bitSlice bs = sliceInt (foldl' step 0 bs) bitCount' where
step acc w = shiftL acc 8 + fromIntegral w
bitCount' = bitsInWord8 bs
sliceInt :: Integer -> BitCount -> BitCount -> BitCount -> Integer
sliceInt x xBitCount s e = fromIntegral sliced where
sliced = (x .&. startMask) `bitShiftR` (xBitCount - e)
startMask = n1Bits (xBitCount - s)
n1Bits n = (2 `pow` n) - 1
pow :: (Integral a, Integral b, Integral c) => a -> b -> c
pow b e = floor $ fromIntegral b ** fromIntegral e
isNegativeNaN :: RealFloat a => a -> Bool
isNegativeNaN x = isNaN x && (floor x > 0)