module Haste.Binary.Put (
Put, PutM,
putWord8, putWord16le, putWord32le,
putInt8, putInt16le, putInt32le,
putFloat32le, putFloat64le,
putBlob,
runPut
) where
import Data.Int
import Data.Word
import Haste.Prim
import Haste.Foreign
import Haste.Binary.Types
import Control.Applicative
import Control.Monad
import System.IO.Unsafe
#ifndef __HASTE__
import qualified Data.Binary as B
import qualified Data.Binary.IEEE754 as BI
import qualified Data.Binary.Put as BP
import qualified Data.Binary.Put as BP
#endif
type Put = PutM ()
#ifdef __HASTE__
type JSArr = Unpacked
newArr :: IO JSArr
newArr = ffi "(function(){return [];})"
push :: Marshal a => JSArr -> a -> IO ()
push = ffi "(function(a,x) {a.push(x);})"
data PutM a = PutM {unP :: JSArr -> IO a}
instance Functor PutM where
fmap f (PutM m) = PutM $ \a -> fmap f (m a)
instance Applicative PutM where
(<*>) = ap
pure = return
instance Monad PutM where
return x = PutM $ \_ -> return x
PutM m >>= f = PutM $ \a -> do
x <- m a
unP (f x) a
putWord8 :: Word8 -> Put
putWord8 w = PutM $ \a -> push a (toAB "Uint8Array" 1 w)
putWord16le :: Word16 -> Put
putWord16le w = PutM $ \a -> push a (toAB "Uint16Array" 2 w)
putWord32le :: Word32 -> Put
putWord32le w = PutM $ \a -> push a (toAB "Uint32Array" 4 w)
putInt8 :: Int8 -> Put
putInt8 i = PutM $ \a -> push a (toAB "Int8Array" 1 i)
putInt16le :: Int16 -> Put
putInt16le i = PutM $ \a -> push a (toAB "Int16Array" 2 i)
putInt32le :: Int32 -> Put
putInt32le i = PutM $ \a -> push a (toAB "Int32Array" 4 i)
putFloat32le :: Float -> Put
putFloat32le f = PutM $ \a -> push a (unsafePerformIO $ f2ab f)
f2ab :: Float -> IO Unpacked
f2ab = ffi "(function(f) {var a=new ArrayBuffer(4);new DataView(a).setFloat32(0,f,true);return a;})"
putFloat64le :: Double -> Put
putFloat64le f = PutM $ \a -> push a (unsafePerformIO $ d2ab f)
d2ab :: Double -> IO Unpacked
d2ab = ffi "(function(f) {var a=new ArrayBuffer(8);new DataView(a).setFloat64(0,f,true);return a;})"
putBlob :: Blob -> Put
putBlob b = PutM $ \a -> push a (unpack b)
toAB :: Marshal a => JSString -> Int -> a -> Unpacked
toAB view size elem = unsafePerformIO $ toABle view size (unpack elem)
toABle :: Marshal a => JSString -> Int -> a -> IO Unpacked
toABle = ffi "window['toABle']"
runPut :: Put -> Blob
runPut (PutM putEverything) = unsafePerformIO $ do
a <- newArr
putEverything a
go a
where
go :: JSArr -> IO Blob
go = ffi "(function(parts){return new Blob(parts);})"
#else
newtype PutM a = PutM (BP.PutM a) deriving (Functor, Applicative, Monad)
runPut :: Put -> Blob
runPut (PutM p) = Blob (BP.runPut p)
putWord8 :: Word8 -> Put
putWord8 = PutM . BP.putWord8
putWord16le :: Word16 -> Put
putWord16le = PutM . BP.putWord16le
putWord32le :: Word32 -> Put
putWord32le = PutM . BP.putWord32le
putInt8 :: Int8 -> Put
putInt8 = PutM . B.put
putInt16le :: Int16 -> Put
putInt16le = putWord16le . fromIntegral
putInt32le :: Int32 -> Put
putInt32le = putWord32le . fromIntegral
putFloat32le :: Float -> Put
putFloat32le = PutM . BI.putFloat32le
putFloat64le :: Double -> Put
putFloat64le = PutM . BI.putFloat64le
putBlob :: Blob -> Put
putBlob (Blob b) = PutM $ BP.putLazyByteString b
#endif