mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-22 11:19:32 -06:00
move the custom Binary package back to src/runtime/haskell
This commit is contained in:
@@ -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 (**)}
|
||||
Reference in New Issue
Block a user