move the custom Binary package back to src/runtime/haskell

This commit is contained in:
Krasimir Angelov
2017-09-04 09:55:17 +02:00
parent bbdbf2bc5d
commit 4fe9f88128
6 changed files with 100 additions and 101 deletions

View File

@@ -17,14 +17,14 @@
\begin{code}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.Binary.IEEE754 (
-- * Parsing
getFloat16be, getFloat16le
, getFloat32be, getFloat32le
, getFloat64be, getFloat64le
-- * Serializing
, putFloat32be, putFloat32le
, putFloat64be, putFloat64le
-- * Parsing
getFloat16be, getFloat16le
, getFloat32be, getFloat32le
, getFloat64be, getFloat64le
-- * Serializing
, putFloat32be, putFloat32le
, putFloat64be, putFloat64le
) where
import Data.Bits ((.&.), (.|.), shiftL, shiftR, Bits)
@@ -80,19 +80,19 @@ original float, and have not been unbiased or otherwise modified.
\begin{code}
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
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
\end{code}
\subsubsection{Encodings and special values}
@@ -123,14 +123,14 @@ are constructed using the {\tt Read} instances for {\tt Double} and
\begin{code}
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
| 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
\end{code}
If a value is normalised, its significand has an implied {\tt 1} bit
@@ -140,13 +140,13 @@ this value before being passed to {\tt encodeField}.
\begin{code}
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)
Significand sig = rawSignificand f
Exponent exp' = unbiased - sigWidth
fraction = sig + (1 `bitShiftL` rawSignificandWidth f)
sigWidth = fromIntegral $ rawSignificandWidth f
unbiased = unbias (rawExponent f) (rawExponentWidth f)
\end{code}
For denormalised values, the implied {\tt 1} bit is the least-significant
@@ -155,11 +155,11 @@ bit of the exponent.
\begin{code}
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)
Significand sig = rawSignificand f
Exponent exp' = unbiased - sigWidth + 1
sigWidth = fromIntegral $ rawSignificandWidth f
unbiased = unbias (rawExponent f) (rawExponentWidth f)
\end{code}
By composing {\tt splitBytes} and {\tt merge}, the absolute value of the
@@ -170,11 +170,11 @@ must be signed appropriately.
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
raw <- fmap (parser . B.unpack) $ getByteString width
let absFloat = merge raw
return $ case rawSign raw of
Positive -> absFloat
Negative -> -absFloat
\end{code}
\section{Serialising}
@@ -211,24 +211,24 @@ stored in the {\tt RawFloat}.
\begin{code}
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)
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)
\end{code}
Then, the {\tt RawFloat} is converted to a list of bytes by mashing all
@@ -238,14 +238,14 @@ in 8-bit blocks.
\begin{code}
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
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
\end{code}
{\tt clamp}, given a maximum bit count and a value, will strip any 1-bits
@@ -254,9 +254,9 @@ in positions above the count.
\begin{code}
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
mask 1 = 1
mask n | n > 1 = (mask (n - 1) `shiftL` 1) + 1
mask _ = undefined
\end{code}
For merging the fields, just shift the starting integer over a bit and
@@ -276,8 +276,8 @@ Each increment is converted to a byte and added to the final list.
integerToBytes :: Integer -> ByteCount -> [Word8]
integerToBytes _ 0 = []
integerToBytes x n = bytes where
bytes = integerToBytes (x `shiftR` 8) (n - 1) ++ [step]
step = fromIntegral x .&. 0xFF
bytes = integerToBytes (x `shiftR` 8) (n - 1) ++ [step]
step = fromIntegral x .&. 0xFF
\end{code}
Finally, the raw parsing is wrapped up in {\tt Put}. The second parameter
@@ -287,7 +287,7 @@ serialisation.
\begin{code}
putFloat :: (RealFloat a) => ByteCount -> ([Word8] -> [Word8]) -> a -> Put
putFloat width f x = putByteString $ B.pack bytes where
bytes = f . rawToBytes . splitFloat width $ x
bytes = f . rawToBytes . splitFloat width $ x
\end{code}
\section{Raw float components}
@@ -299,14 +299,14 @@ shouldn't have it's implied MSB (if applicable).
\begin{code}
data RawFloat = RawFloat
{ rawWidth :: ByteCount
, rawSign :: Sign
, rawExponent :: Exponent
, rawSignificand :: Significand
, rawExponentWidth :: BitCount
, rawSignificandWidth :: BitCount
}
deriving (Show)
{ rawWidth :: ByteCount
, rawSign :: Sign
, rawExponent :: Exponent
, rawSignificand :: Significand
, rawExponentWidth :: BitCount
, rawSignificandWidth :: BitCount
}
deriving (Show)
\end{code}
\section{Exponents}
@@ -317,10 +317,10 @@ size of the full structure.
\begin{code}
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"
| 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"
\end{code}
\begin{code}
@@ -337,19 +337,19 @@ unbias e eWidth = e + 1 - (2 `pow` (eWidth - 1))
\begin{code}
data Sign = Positive | Negative
deriving (Show)
deriving (Show)
newtype Exponent = Exponent Int
deriving (Show, Eq, Num, Ord, Real, Enum, Integral, Bits)
deriving (Show, Eq, Num, Ord, Real, Enum, Integral, Bits)
newtype Significand = Significand Integer
deriving (Show, Eq, Num, Ord, Real, Enum, Integral, Bits)
deriving (Show, Eq, Num, Ord, Real, Enum, Integral, Bits)
newtype BitCount = BitCount Int
deriving (Show, Eq, Num, Ord, Real, Enum, Integral)
deriving (Show, Eq, Num, Ord, Real, Enum, Integral)
newtype ByteCount = ByteCount Int
deriving (Show, Eq, Num, Ord, Real, Enum, Integral)
deriving (Show, Eq, Num, Ord, Real, Enum, Integral)
bitCount :: ByteCount -> BitCount
bitCount (ByteCount x) = BitCount (x * 8)
@@ -373,8 +373,8 @@ integer.
\begin{code}
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
step acc w = shiftL acc 8 + fromIntegral w
bitCount' = bitsInWord8 bs
\end{code}
Slice a single integer by start and end bit location
@@ -382,9 +382,9 @@ Slice a single integer by start and end bit location
\begin{code}
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
sliced = (x .&. startMask) `bitShiftR` (xBitCount - e)
startMask = n1Bits (xBitCount - s)
n1Bits n = (2 `pow` n) - 1
\end{code}
Integral version of {\tt (**)}