module Haste.Binary.Get (
Get,
getWord8, getWord16le, getWord32le,
getInt8, getInt16le, getInt32le,
getFloat32le, getFloat64le,
getBytes, skip,
runGet
) 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.Get as BG
import qualified Control.Exception as Ex
#endif
#ifdef __HASTE__
data Get a = Get {unG :: Unpacked -> Int -> Either String (Int, a)}
instance Functor Get where
fmap f (Get m) = Get $ \buf next -> fmap (fmap f) (m buf next)
instance Applicative Get where
(<*>) = ap
pure = return
instance Monad Get where
return x = Get $ \_ next -> Right (next, x)
(Get m) >>= f = Get $ \buf next ->
case m buf next of
Right (next', x) -> unG (f x) buf next'
Left e -> Left e
fail s = Get $ \_ _ -> Left s
getW8 :: Unpacked -> Int -> IO Word8
getW8 = ffi "(function(b,i){return b.getUint8(i);})"
getWord8 :: Get Word8
getWord8 =
Get $ \buf next -> Right (next+1, unsafePerformIO $ getW8 buf next)
getW16le :: Unpacked -> Int -> IO Word16
getW16le = ffi "(function(b,i){return b.getUint16(i,true);})"
getWord16le :: Get Word16
getWord16le =
Get $ \buf next -> Right (next+2, unsafePerformIO $ getW16le buf next)
getW32le :: Unpacked -> Int -> IO Word32
getW32le = ffi "(function(b,i){return b.getUint32(i,true);})"
getWord32le :: Get Word32
getWord32le =
Get $ \buf next -> Right (next+4, unsafePerformIO $ getW32le buf next)
getI8 :: Unpacked -> Int -> IO Int8
getI8 = ffi "(function(b,i){return b.getInt8(i);})"
getInt8 :: Get Int8
getInt8 =
Get $ \buf next -> Right (next+1, unsafePerformIO $ getI8 buf next)
getI16le :: Unpacked -> Int -> IO Int16
getI16le = ffi "(function(b,i){return b.getInt16(i,true);})"
getInt16le :: Get Int16
getInt16le =
Get $ \buf next -> Right (next+2, unsafePerformIO $ getI16le buf next)
getI32le :: Unpacked -> Int -> IO Int32
getI32le = ffi "(function(b,i){return b.getInt32(i,true);})"
getInt32le :: Get Int32
getInt32le =
Get $ \buf next -> Right (next+4, unsafePerformIO $ getI32le buf next)
getF32le :: Unpacked -> Int -> IO Float
getF32le = ffi "(function(b,i){return b.getFloat32(i,true);})"
getFloat32le :: Get Float
getFloat32le =
Get $ \buf next -> Right (next+4, unsafePerformIO $ getF32le buf next)
getF64le :: Unpacked -> Int -> IO Double
getF64le = ffi "(function(b,i){return b.getFloat64(i,true);})"
getFloat64le :: Get Double
getFloat64le =
Get $ \buf next -> Right (next+8, unsafePerformIO $ getF64le buf next)
getBytes :: Int -> Get BlobData
getBytes len = Get $ \buf next -> Right (next+len, BlobData next len buf)
skip :: Int -> Get ()
skip len = Get $ \buf next -> Right (next+len, ())
runGet :: Get a -> BlobData -> Either String a
runGet (Get p) (BlobData off len bd) = do
(consumed, x) <- p bd off
if consumed <= len
then Right x
else Left "Not enough data!"
#else
newtype Get a = Get (BG.Get a) deriving (Functor, Applicative, Monad)
runGet :: Get a -> BlobData -> Either String a
runGet (Get g) (BlobData bd) = unsafePerformIO $ do
Ex.catch (Right <$> (return $! BG.runGet g bd)) mEx
mEx :: Ex.SomeException -> IO (Either String a)
mEx ex = return . Left $ show ex
getWord8 :: Get Word8
getWord8 = Get BG.getWord8
getWord16le :: Get Word16
getWord16le = Get BG.getWord16le
getWord32le :: Get Word32
getWord32le = Get BG.getWord32le
getInt8 :: Get Int8
getInt8 = Get B.get
getInt16le :: Get Int16
getInt16le = fromIntegral <$> getWord16le
getInt32le :: Get Int32
getInt32le = fromIntegral <$> getWord32le
getFloat32le :: Get Float
getFloat32le = Get BI.getFloat32le
getFloat64le :: Get Double
getFloat64le = Get BI.getFloat64le
getBytes :: Int -> Get BlobData
getBytes len = Get $ do
bs <- BG.getLazyByteString (fromIntegral len)
return (BlobData bs)
skip :: Int -> Get ()
skip = Get . BG.skip
#endif