module Haste.Binary.Put (
Put, PutM,
putWord8, putWord16le, putWord32le,
putInt8, putInt16le, putInt32le,
putFloat32le, putFloat64le,
putBlob, putJSString,
runPut
) where
import Data.Int
import Data.Word
import Haste.Prim
import Haste.Binary.Types
#if __GLASGOW_HASKELL__ < 710
import Control.Applicative
#endif
#ifdef __HASTE__
import Control.Monad
import Haste.Foreign
import System.IO.Unsafe
#else
import Data.Char (ord)
import qualified Data.Binary as B
import qualified Data.Binary.IEEE754 as BI
import qualified Data.Binary.Put as BP
#endif
type Put = PutM ()
#ifdef __HASTE__
type JSArr = JSAny
newArr :: IO JSArr
newArr = ffi "(function(){return [];})"
push :: JSArr -> JSAny -> 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 JSAny
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 JSAny
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 (toAny b)
toAB :: ToAny a => JSString -> Int -> a -> JSAny
toAB view size el = unsafePerformIO $ toABle view size (toAny el)
toABle :: ToAny a => JSString -> Int -> a -> IO JSAny
toABle s n x = jsToABle s n (toAny x)
jsToABle :: JSString -> Int -> JSAny -> IO JSAny
jsToABle = ffi "window['toABle']"
putJSString :: JSString -> Put
putJSString s = PutM $ \a -> push a (unsafePerformIO $ str2ab s)
str2ab :: JSString -> IO JSAny
str2ab = ffi "(function(s) {\
var l = s.length;\
var v = new Uint16Array(new ArrayBuffer(l*2));\
for (var i=0; i<l; ++i) {\
v[i]=s.charCodeAt(i);\
}\
return v.buffer;})"
-- | Run a Put computation.
runPut :: Put -> Blob
runPut (PutM putEverything) = unsafePerformIO $ do
a <- newArr
putEverything a
jsGetBlob a
jsGetBlob :: JSArr -> IO Blob
jsGetBlob = 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
putJSString :: JSString -> Put
putJSString = mapM_ (putWord16le . fromIntegral . ord) . fromJSStr
#endif