    -----------------------------------------------------------------------------
    -- |
    -- 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)