{-# LANGUAGE FlexibleContexts #-}

module Language.Wasm.FloatUtils (
    wordToFloat,
    floatToWord,
    wordToDouble,
    doubleToWord,
    makeNaN,
    doubleToFloat
) where

import Data.Word (Word32, Word64)
import Data.Bits ((.|.), (.&.), shiftR)
import Data.Array.ST (newArray, readArray, MArray, STUArray)
import Data.Array.Unsafe (castSTUArray)
import GHC.ST (runST, ST)

-- brough from https://stackoverflow.com/questions/6976684/converting-ieee-754-floating-point-in-haskell-word32-64-to-and-from-haskell-floa
wordToFloat :: Word32 -> Float
wordToFloat :: Word32 -> Float
wordToFloat Word32
x = (forall s. ST s Float) -> Float
forall a. (forall s. ST s a) -> a
runST (Word32 -> ST s Float
forall s a b.
(MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) =>
a -> ST s b
cast Word32
x)

floatToWord :: Float -> Word32
floatToWord :: Float -> Word32
floatToWord Float
x = (forall s. ST s Word32) -> Word32
forall a. (forall s. ST s a) -> a
runST (Float -> ST s Word32
forall s a b.
(MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) =>
a -> ST s b
cast Float
x)

wordToDouble :: Word64 -> Double
wordToDouble :: Word64 -> Double
wordToDouble Word64
x = (forall s. ST s Double) -> Double
forall a. (forall s. ST s a) -> a
runST (Word64 -> ST s Double
forall s a b.
(MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) =>
a -> ST s b
cast Word64
x)

doubleToWord :: Double -> Word64
doubleToWord :: Double -> Word64
doubleToWord Double
x = (forall s. ST s Word64) -> Word64
forall a. (forall s. ST s a) -> a
runST (Double -> ST s Word64
forall s a b.
(MArray (STUArray s) a (ST s), MArray (STUArray s) b (ST s)) =>
a -> ST s b
cast Double
x)

{-# INLINE cast #-}
cast :: (MArray (STUArray s) a (ST s),
         MArray (STUArray s) b (ST s)) => a -> ST s b
cast :: a -> ST s b
cast a
x = (Int, Int) -> a -> ST s (STUArray s Int a)
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
(i, i) -> e -> m (a i e)
newArray (Int
0 :: Int, Int
0) a
x ST s (STUArray s Int a)
-> (STUArray s Int a -> ST s (STUArray s Int b))
-> ST s (STUArray s Int b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= STUArray s Int a -> ST s (STUArray s Int b)
forall s ix a b. STUArray s ix a -> ST s (STUArray s ix b)
castSTUArray ST s (STUArray s Int b) -> (STUArray s Int b -> ST s b) -> ST s b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (STUArray s Int b -> Int -> ST s b)
-> Int -> STUArray s Int b -> ST s b
forall a b c. (a -> b -> c) -> b -> a -> c
flip STUArray s Int b -> Int -> ST s b
forall (a :: * -> * -> *) e (m :: * -> *) i.
(MArray a e m, Ix i) =>
a i e -> i -> m e
readArray Int
0

makeNaN :: Word64 -> Double
makeNaN :: Word64 -> Double
makeNaN Word64
w = Word64 -> Double
wordToDouble (Word64 -> Double) -> Word64 -> Double
forall a b. (a -> b) -> a -> b
$ Word64
0x7FF0000000000000 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
0x000FFFFFFFFFFFFF Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
w)

doubleToFloat :: Double -> Float
doubleToFloat :: Double -> Float
doubleToFloat Double
d =
    let w :: Word64
w = Double -> Word64
doubleToWord Double
d in
    if Word64
0x7FF0000000000000 Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
== (Word64
w Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x7FF0000000000000) Bool -> Bool -> Bool
&& (Word64
w Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
0x0007FFFFFFFFFFFF) Word64 -> Word64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word64
0
    then Word32 -> Float
wordToFloat (Word32 -> Float) -> Word32 -> Float
forall a b. (a -> b) -> a -> b
$ Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word32) -> Word64 -> Word32
forall a b. (a -> b) -> a -> b
$ ((Word64
0x8000000000000000 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
w) Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`shiftR` Int
32) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
0x7F800000 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. (Word64
0x7FFFFF Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
w)
    else Double -> Float
forall a b. (Real a, Fractional b) => a -> b
realToFrac Double
d