{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE CPP #-}

-- | IEEE-754 parsing, as described in this stack-overflow article:
--
-- <http://stackoverflow.com/questions/6976684/converting-ieee-754-floating-point-in-haskell-word32-64-to-and-from-haskell-float/7002812#7002812>

module Data.Serialize.IEEE754 (

    -- * IEEE-754 reads
      getFloat32le
    , getFloat32be
    , getFloat64le
    , getFloat64be

    -- * IEEE-754 writes
    , putFloat32le
    , putFloat32be
    , putFloat64le
    , putFloat64be

) where

import Control.Applicative ( (<$>) )
import Control.Monad.ST ( runST, ST )

import Data.Array.ST ( newArray, readArray, MArray, STUArray )
import Data.Word ( Word32, Word64 )
import Data.Serialize.Get
import Data.Serialize.Put

#if __GLASGOW_HASKELL__ >= 704
import Data.Array.Unsafe (castSTUArray)
#else
import Data.Array.ST (castSTUArray)
#endif

-- | Read a Float in little endian IEEE-754 format
getFloat32le :: Get Float
getFloat32le = wordToFloat <$> getWord32le

-- | Read a Float in big endian IEEE-754 format
getFloat32be :: Get Float
getFloat32be = wordToFloat <$> getWord32be

-- | Read a Double in little endian IEEE-754 format
getFloat64le :: Get Double
getFloat64le = wordToDouble <$> getWord64le

-- | Read a Double in big endian IEEE-754 format
getFloat64be :: Get Double
getFloat64be = wordToDouble <$> getWord64be

-- | Write a Float in little endian IEEE-754 format
putFloat32le :: Float -> Put
putFloat32le = putWord32le . floatToWord

-- | Write a Float in big endian IEEE-754 format
putFloat32be :: Float -> Put
putFloat32be = putWord32be . floatToWord

-- | Write a Double in little endian IEEE-754 format
putFloat64le :: Double -> Put
putFloat64le = putWord64le . doubleToWord

-- | Write a Double in big endian IEEE-754 format
putFloat64be :: Double -> Put
putFloat64be = putWord64be . doubleToWord

{-# INLINE wordToFloat #-}
wordToFloat :: Word32 -> Float
wordToFloat x = runST (cast x)

{-# INLINE floatToWord #-}
floatToWord :: Float -> Word32
floatToWord x = runST (cast x)

{-# INLINE wordToDouble #-}
wordToDouble :: Word64 -> Double
wordToDouble x = runST (cast x)

{-# INLINE doubleToWord #-}
doubleToWord :: Double -> Word64
doubleToWord x = runST (cast x)

{-# INLINE cast #-}
cast :: (MArray (STUArray s) a (ST s),
         MArray (STUArray s) b (ST s)) =>
        a -> ST s b
cast x = newArray (0 :: Int, 0) x >>= castSTUArray >>= flip readArray 0