-----------------------------------------------------------------------------
-- |
-- Module: Data.Binary.IEEE754
-- Copyright: 2010 John Millikin
-- License: MIT
--
-- Maintainer: jmillikin@gmail.com
-- Portability: portable
--
-----------------------------------------------------------------------------
module Data.Binary.IEEE754 (
	-- * Parsing
	  getFloat16be, getFloat16le
	, getFloat32be, getFloat32le
	, getFloat64be, getFloat64le
	
	-- * Serializing
	, putFloat32be, putFloat32le
	, putFloat64be, putFloat64le
	
	-- * Float <-> Word conversion
	, floatToWord, wordToFloat
	, doubleToWord, wordToDouble
) where

import           Prelude hiding (exp)
import           Data.Bits (shiftL, shiftR, (.|.), (.&.))
import qualified Foreign as F
import           System.IO.Unsafe (unsafePerformIO)

import qualified Data.Binary.Get as G
import qualified Data.Binary.Put as P

getFloat16be :: G.Get Float
getFloat16be :: Get Float
getFloat16be = (Word16 -> Float) -> Get Word16 -> Get Float
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word16 -> Float
toFloat16 Get Word16
G.getWord16be

getFloat16le :: G.Get Float
getFloat16le :: Get Float
getFloat16le = (Word16 -> Float) -> Get Word16 -> Get Float
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word16 -> Float
toFloat16 Get Word16
G.getWord16le

getFloat32be :: G.Get Float
getFloat32be :: Get Float
getFloat32be = (Word32 -> Float) -> Get Word32 -> Get Float
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word32 -> Float
forall word float. (Storable word, Storable float) => word -> float
toFloat Get Word32
G.getWord32be

getFloat32le :: G.Get Float
getFloat32le :: Get Float
getFloat32le = (Word32 -> Float) -> Get Word32 -> Get Float
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word32 -> Float
forall word float. (Storable word, Storable float) => word -> float
toFloat Get Word32
G.getWord32le

getFloat64be :: G.Get Double
getFloat64be :: Get Double
getFloat64be = (Word64 -> Double) -> Get Word64 -> Get Double
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word64 -> Double
forall word float. (Storable word, Storable float) => word -> float
toFloat Get Word64
G.getWord64be

getFloat64le :: G.Get Double
getFloat64le :: Get Double
getFloat64le = (Word64 -> Double) -> Get Word64 -> Get Double
forall a b. (a -> b) -> Get a -> Get b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Word64 -> Double
forall word float. (Storable word, Storable float) => word -> float
toFloat Get Word64
G.getWord64le

putFloat32be :: Float -> P.Put
putFloat32be :: Float -> Put
putFloat32be = Word32 -> Put
P.putWord32be (Word32 -> Put) -> (Float -> Word32) -> Float -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Word32
forall word float. (Storable word, Storable float) => float -> word
fromFloat

putFloat32le :: Float -> P.Put
putFloat32le :: Float -> Put
putFloat32le = Word32 -> Put
P.putWord32le (Word32 -> Put) -> (Float -> Word32) -> Float -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Word32
forall word float. (Storable word, Storable float) => float -> word
fromFloat

putFloat64be :: Double -> P.Put
putFloat64be :: Double -> Put
putFloat64be = Word64 -> Put
P.putWord64be (Word64 -> Put) -> (Double -> Word64) -> Double -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Word64
forall word float. (Storable word, Storable float) => float -> word
fromFloat

putFloat64le :: Double -> P.Put
putFloat64le :: Double -> Put
putFloat64le = Word64 -> Put
P.putWord64le (Word64 -> Put) -> (Double -> Word64) -> Double -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Word64
forall word float. (Storable word, Storable float) => float -> word
fromFloat

floatToWord :: Float -> F.Word32
floatToWord :: Float -> Word32
floatToWord = Float -> Word32
forall word float. (Storable word, Storable float) => float -> word
fromFloat

wordToFloat :: F.Word32 -> Float
wordToFloat :: Word32 -> Float
wordToFloat = Word32 -> Float
forall word float. (Storable word, Storable float) => word -> float
toFloat

doubleToWord :: Double -> F.Word64
doubleToWord :: Double -> Word64
doubleToWord = Double -> Word64
forall word float. (Storable word, Storable float) => float -> word
fromFloat

wordToDouble :: F.Word64 -> Double
wordToDouble :: Word64 -> Double
wordToDouble = Word64 -> Double
forall word float. (Storable word, Storable float) => word -> float
toFloat

toFloat :: (F.Storable word, F.Storable float) => word -> float
toFloat :: forall word float. (Storable word, Storable float) => word -> float
toFloat word
word = IO float -> float
forall a. IO a -> a
unsafePerformIO (IO float -> float) -> IO float -> float
forall a b. (a -> b) -> a -> b
$ (Ptr float -> IO float) -> IO float
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca ((Ptr float -> IO float) -> IO float)
-> (Ptr float -> IO float) -> IO float
forall a b. (a -> b) -> a -> b
$ \Ptr float
buf -> do
	Ptr word -> word -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
F.poke (Ptr float -> Ptr word
forall a b. Ptr a -> Ptr b
F.castPtr Ptr float
buf) word
word
	Ptr float -> IO float
forall a. Storable a => Ptr a -> IO a
F.peek Ptr float
buf

fromFloat :: (F.Storable word, F.Storable float) => float -> word
fromFloat :: forall word float. (Storable word, Storable float) => float -> word
fromFloat float
float = IO word -> word
forall a. IO a -> a
unsafePerformIO (IO word -> word) -> IO word -> word
forall a b. (a -> b) -> a -> b
$ (Ptr word -> IO word) -> IO word
forall a b. Storable a => (Ptr a -> IO b) -> IO b
F.alloca ((Ptr word -> IO word) -> IO word)
-> (Ptr word -> IO word) -> IO word
forall a b. (a -> b) -> a -> b
$ \Ptr word
buf -> do
	Ptr float -> float -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
F.poke (Ptr word -> Ptr float
forall a b. Ptr a -> Ptr b
F.castPtr Ptr word
buf) float
float
	Ptr word -> IO word
forall a. Storable a => Ptr a -> IO a
F.peek Ptr word
buf

toFloat16 :: F.Word16 -> Float
toFloat16 :: Word16 -> Float
toFloat16 Word16
word16 = Word32 -> Float
forall word float. (Storable word, Storable float) => word -> float
toFloat (Word32
sign32 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32
word32) where
	sign16 :: Word16
sign16 = Word16
word16 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x8000
	exp16 :: Word16
exp16 = Word16
word16 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x7C00
	frac16 :: Word16
frac16 = Word16
word16 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x3FF
	
	sign32 :: Word32
sign32 = if Word16
sign16 Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
> Word16
0
		then Word32
0x80000000 -- -0.0
		else Word32
0
	
	word32 :: F.Word32
	word32 :: Word32
word32 | Word16
word16 Word16 -> Word16 -> Word16
forall a. Bits a => a -> a -> a
.&. Word16
0x7FFF Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
0 = Word32
0
	       | Word16
exp16 Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
0x7C00 = Word32
special
	       | Bool
otherwise = Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
exp32 Int
23 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
shiftL Word32
frac32 Int
13
	
	special :: Word32
special = if Word16
frac16 Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
== Word16
0
		-- Infinity
		then Word32
0x7F800000
		
		-- NaN; signals are maintained in lower 10 bits
		else Word32
0x7FC00000 Word32 -> Word32 -> Word32
forall a. Bits a => a -> a -> a
.|. Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
frac16
	
	(Word32
exp32, Word32
frac32) = if Word16
exp16 Word16 -> Word16 -> Bool
forall a. Ord a => a -> a -> Bool
> Word16
0
		then (Word32, Word32)
normalised
		else (Word32, Word32)
denormalised
	
	normalised :: (Word32, Word32)
normalised = (Word32
exp, Word32
frac) where
		exp :: Word32
exp = (Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
exp16 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
10) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
15 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
127
		frac :: Word32
frac = Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
frac16
	
	denormalised :: (Word32, Word32)
denormalised = (Word32
exp, Word32
frac) where
		exp :: Word32
exp = (Word16 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word16
exp16 Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` Int
10) Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
15 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
+ Word32
127 Word32 -> Word32 -> Word32
forall a. Num a => a -> a -> a
- Word32
e
		(Word32
e, Word32
frac ) = Word32 -> Word16 -> (Word32, Word32)
forall {a} {b} {a}.
(Bits a, Bits b, Integral a, Num a, Num b) =>
a -> a -> (a, b)
step Word32
0 (Word16 -> Int -> Word16
forall a. Bits a => a -> Int -> a
shiftL Word16
frac16 Int
1) where
			step :: a -> a -> (a, b)
step a
acc a
x = if a
x a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
0x400 a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0
				then a -> a -> (a, b)
step (a
acc a -> a -> a
forall a. Num a => a -> a -> a
+ a
1) (a -> Int -> a
forall a. Bits a => a -> Int -> a
shiftL a
x Int
1)
				else (a
acc, a -> b
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
x b -> b -> b
forall a. Bits a => a -> a -> a
.&. b
0x3FF)