diff --git a/Data/Binary/IEEE754.hs b/Data/Binary/IEEE754.hs --- a/Data/Binary/IEEE754.hs +++ b/Data/Binary/IEEE754.hs @@ -1,3 +1,20 @@ +{- Copyright (C) 2009 John Millikin + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation, either version 3 of the License, or + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . +-} + +{-# LANGUAGE GeneralizedNewtypeDeriving #-} module Data.Binary.IEEE754 ( -- * Parsing parseFloatBE, parseFloatLE @@ -32,9 +49,10 @@ ,Exponent ,Fraction ,BitCount + ,ByteCount ) where -import Data.Bits ((.&.), (.|.), shiftL, shiftR) +import Data.Bits ((.&.), (.|.), shiftL, shiftR, Bits) import Data.Word (Word8) import Data.List (foldl') @@ -53,83 +71,83 @@ parseFloatLE = parseFloat . reverse getFloat16be :: Get Float -getFloat16be = getFloat 2 parseFloatBE +getFloat16be = getFloat (ByteCount 2) parseFloatBE getFloat16le :: Get Float -getFloat16le = getFloat 2 parseFloatLE +getFloat16le = getFloat (ByteCount 2) parseFloatLE getFloat32be :: Get Float -getFloat32be = getFloat 4 parseFloatBE +getFloat32be = getFloat (ByteCount 4) parseFloatBE getFloat32le :: Get Float -getFloat32le = getFloat 4 parseFloatLE +getFloat32le = getFloat (ByteCount 4) parseFloatLE getFloat64be :: Get Double -getFloat64be = getFloat 8 parseFloatBE +getFloat64be = getFloat (ByteCount 8) parseFloatBE getFloat64le :: Get Double -getFloat64le = getFloat 8 parseFloatLE +getFloat64le = getFloat (ByteCount 8) parseFloatLE -- |Parse a floating-point value of the given width (in bytes) from within -- a Get monad. getFloat :: (RealFloat a) => ByteCount -> ([Word8] -> a) -> Get a -getFloat width parser = do +getFloat (ByteCount width) parser = do bytes <- getByteString width (return . parser . B.unpack) bytes --------------------------------------------------------------------- -putFloat32be :: (RealFloat a) => a -> Put -putFloat32be = putFloat 4 encodeIntBE +putFloat32be :: Float -> Put +putFloat32be x = putFloat (ByteCount 4) encodeIntBE x -putFloat32le :: (RealFloat a) => a -> Put -putFloat32le = putFloat 4 encodeIntLE +putFloat32le :: Float -> Put +putFloat32le x = putFloat (ByteCount 4) encodeIntLE x -putFloat64be :: (RealFloat a) => a -> Put -putFloat64be = putFloat 8 encodeIntBE +putFloat64be :: Double -> Put +putFloat64be x = putFloat (ByteCount 8) encodeIntBE x -putFloat64le :: (RealFloat a) => a -> Put -putFloat64le = putFloat 8 encodeIntLE +putFloat64le :: Double -> Put +putFloat64le x = putFloat (ByteCount 8) encodeIntLE x putFloat :: (RealFloat a) => ByteCount -> (ByteCount -> Integer -> [Word8]) -> a -> Put -putFloat width f v = putByteString $ B.pack words - where words = f width (floatToMerged width v) +putFloat width f v = putByteString $ B.pack words' + where words' = f width (floatToMerged width v) floatComponents :: (RealFloat a) => ByteCount -> a -> (Bool, Fraction, Exponent) floatComponents width v = case (dFraction, dExponent, biasedE) of (0, 0, _) -> (sign, 0, 0) (_, _, 0) -> (sign, truncatedFraction + 1, 0) - otherwise -> (sign, truncatedFraction, biasedE) - where dFraction = fst (decodeFloat v) - dExponent = snd (decodeFloat v) - eWidth = exponentWidth (width * 8) - fWidth = (width * 8) - eWidth - 1 -- 1 for sign bit - biasedE = bias (dExponent + fWidth) eWidth + _ -> (sign, truncatedFraction, biasedE) + where dFraction = Fraction $ fst (decodeFloat v) + dExponent = Exponent $ snd (decodeFloat v) + eWidth = exponentWidth (bitCount width) + fWidth = (bitCount width) - eWidth - 1 -- 1 for sign bit + biasedE = bias (dExponent + (fromIntegral fWidth)) eWidth absFraction = abs dFraction -- Weird check is for detecting -0.0 sign = (1.0 / v) < 0.0 -- Fraction needs to be truncated, depending on the exponent - truncatedFraction = absFraction - (1 `shiftL` fWidth) + truncatedFraction = absFraction - (1 `bitShiftL` fWidth) floatToMerged :: (RealFloat a) => ByteCount -> a -> Integer floatToMerged width v = mergeFloatBits' (floatComponents width v) where mergeFloatBits' (s, f, e) = mergeFloatBits fWidth eWidth s f e - eWidth = exponentWidth (width * 8) - fWidth = (width * 8) - eWidth - 1 -- 1 for sign bit + eWidth = exponentWidth (bitCount width) + fWidth = (bitCount width) - eWidth - 1 -- 1 for sign bit mergeFloatBits :: BitCount -> BitCount -> Bool -> Fraction -> Exponent -> Integer mergeFloatBits fWidth eWidth s f e = shiftedSign .|. shiftedFrac .|. shiftedExp where sBit = (if s then 1 else 0) :: Integer - shiftedSign = (sBit `shiftL` (fWidth + eWidth)) :: Integer - shiftedExp = ((fromIntegral e) `shiftL` fWidth) :: Integer - shiftedFrac = f + shiftedSign = (sBit `bitShiftL` (fWidth + eWidth)) :: Integer + shiftedExp = ((fromIntegral e) `bitShiftL` fWidth) :: Integer + shiftedFrac = fromIntegral f -- |Encode an integer to a list of words, in big-endian format encodeIntBE :: ByteCount -> Integer -> [Word8] -encodeIntBE 0 x = [] +encodeIntBE 0 _ = [] encodeIntBE width x = (encodeIntBE (width - 1) (x `shiftR` 8)) ++ [step] where step = (fromIntegral x) .&. 0xFF @@ -137,7 +155,7 @@ encodeIntLE :: ByteCount -> Integer -> [Word8] encodeIntLE width x = reverse (encodeIntBE width x) -bias :: (Integral a, Integral b) => a -> b -> a +bias :: Exponent -> BitCount -> Exponent bias e eWidth = e - (1 - (2 `iExp` (eWidth - 1))) --------------------------------------------------------------------- @@ -147,19 +165,19 @@ where merge' (sign, e, f) = encode' (mergeFloat e f width) * signFactor sign encode' (f, e) = encodeFloat f e signFactor s = if s then (-1) else 1 - width = length bs * 8 + width = bitsInWord8 bs -- |Considering a byte list as a sequence of bits, slice it from start -- inclusive to end exclusive, and return the resulting bit sequence as an -- integer bitSlice :: [Word8] -> BitCount -> BitCount -> Integer -bitSlice bs = sliceInt (foldl' step 0 bs) bitCount +bitSlice bs = sliceInt (foldl' step 0 bs) bitCount' where step acc w = (shiftL acc 8) + (fromIntegral w) - bitCount = ((length bs) * 8) + bitCount' = bitsInWord8 bs -- |Slice a single integer by start and end bit location sliceInt :: Integer -> BitCount -> BitCount -> BitCount -> Integer -sliceInt x xBitCount s e = fromIntegral $ (x .&. startMask) `shiftR` (xBitCount - e) +sliceInt x xBitCount s e = fromIntegral $ (x .&. startMask) `bitShiftR` (xBitCount - e) where startMask = n1Bits (xBitCount - s) n1Bits n = (2 `iExp` n) - 1 @@ -167,11 +185,11 @@ -- components have not been processed (unbiased, added significant bit, -- etc). splitRawIEEE754 :: [Word8] -> (Bool, Exponent, Fraction) -splitRawIEEE754 bs = (sign, exp, frac) +splitRawIEEE754 bs = (sign, exp', frac) where sign = (head bs .&. 0x80) == 0x80 - exp = fromIntegral $ bitSlice bs 1 (1 + w) - frac = bitSlice bs (1 + w) (length bs * 8) - w = exponentWidth $ length bs * 8 + exp' = Exponent (fromIntegral $ bitSlice bs 1 (1 + w)) + frac = Fraction (bitSlice bs (1 + w) (bitsInWord8 bs)) + w = exponentWidth $ bitsInWord8 bs -- |Unbias an exponent unbias :: Exponent -> BitCount -> Exponent @@ -185,15 +203,15 @@ mergeFloat 0 0 _ = (0, 0) mergeFloat e f width - -- Infinity / NaN (TODO + -- Infinity / NaN (TODO) | e == eMax = error "Infinity/NaN not supported" | otherwise = case e of -- Denormalized - 0 -> (f, (-fWidth) + (unbiasedE + 1)) + 0 -> (fromIntegral f, (fromIntegral unbiasedE + 1) - (fromIntegral fWidth)) -- Normalized - _ -> (f + (1 `shiftL` fWidth), (-fWidth) + unbiasedE) + _ -> (fromIntegral f + (1 `bitShiftL` fWidth), (fromIntegral unbiasedE) - (fromIntegral fWidth)) where eWidth = exponentWidth width fWidth = width - eWidth - 1 @@ -208,17 +226,33 @@ exponentWidth k | k == 16 = 5 | k == 32 = 8 - | k `mod` 32 == 0 = ceiling (4 * (log2 k)) - 13 + | k `mod` 32 == 0 = ceiling (4 * (logBase 2 (fromIntegral k))) - 13 | otherwise = error "Invalid length of floating-point value" --- |Base-2 log of an integer -log2 = (logBase 2) . fromIntegral - -- |Integral exponent +iExp :: (Integral a, Integral b, Integral c) => a -> b -> c iExp b e = floor $ (fromIntegral b) ** (fromIntegral e) -type Exponent = Int -type Fraction = Integer -type BitCount = Int -type ByteCount = Int +newtype Exponent = Exponent Int + deriving (Show, Eq, Num, Ord, Real, Enum, Integral, Bits) +newtype Fraction = Fraction 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 ws = bitCount (ByteCount (length ws)) + +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 diff --git a/data-binary-ieee754.cabal b/data-binary-ieee754.cabal --- a/data-binary-ieee754.cabal +++ b/data-binary-ieee754.cabal @@ -1,15 +1,21 @@ -Name: data-binary-ieee754 -Version: 0.2 -Synopsis: Parser/Serializer for IEEE-754 floating-point values -Description: Convert Float and Decimal values to/from raw octets. -License: GPL -License-file: License.txt -Author: John Millikin +name: data-binary-ieee754 +version: 0.3 +synopsis: Parser/Serializer for IEEE-754 floating-point values +description: Convert Float and Decimal values to/from raw octets. +license: GPL +license-file: License.txt +author: John Millikin maintainer: jmillikin@gmail.com -Build-Type: Simple -Cabal-Version: >=1.2 -Category: Data +build-type: Simple +cabal-version: >=1.6 +category: Data +stability: experimental +bug-reports: mailto:jmillikin@gmail.com -Library - Build-Depends: base >=3 && < 5, binary, bytestring - Exposed-modules: Data.Binary.IEEE754 +source-repository head + type: bzr + location: bzr+ssh://bazaar.launchpad.net/~jmillikin/%2Bjunk/data-binary-ieee754/ + +library + build-depends: base >=3 && < 5, binary, bytestring + exposed-modules: Data.Binary.IEEE754