Get.hs

{-# Language CPP, OverloadedStrings, GeneralizedNewtypeDeriving #-}
module Haste.Binary.Get (
    Get,
    getWord8, getWord16le, getWord32le,
    getInt8, getInt16le, getInt32le,
    getFloat32le, getFloat64le,
    getBytes, getJSString, skip,
    runGet
  ) where
import Data.Int
import Data.Word
import Haste.Prim
import Haste.Binary.Types
import Control.Monad
import System.IO.Unsafe
import qualified Control.Exception as Ex
#ifdef __HASTE__
import Haste.Prim.Foreign hiding (get)
#else
import Data.Char (chr)
import qualified Data.Binary as B
import qualified Data.Binary.IEEE754 as BI
import qualified Data.Binary.Get as BG
#endif

#ifdef __HASTE__
data Result a = Ok !Int !a | Fail !JSString
data Get a = Get {unG :: JSAny -> Int -> Result a}

instance Functor Get where
  fmap f (Get m) = Get $ \buf next ->
    case m buf next of
      Ok next' x -> Ok next' (f x)
      Fail s     -> Fail s

instance Applicative Get where
  (<*>) = ap
  pure  = return

instance Monad Get where
  return x = Get $ \_ next -> Ok next x
  (Get m) >>= f = Get $ \buf next ->
    case m buf next of
      Ok next' x -> unG (f x) buf next'
      Fail e     -> Fail e
  fail s = Get $ \_ _ -> Fail (toJSStr s)

getW8 :: JSAny -> Int -> IO Word8
getW8 = ffi "(function(b,i){return b.getUint8(i);})"

getWord8 :: Get Word8
getWord8 =
  Get $ \buf next -> Ok (next+1) (unsafePerformIO $ getW8 buf next)

getW16le :: JSAny -> Int -> IO Word16
getW16le = ffi "(function(b,i){return b.getUint16(i,true);})"

getWord16le :: Get Word16
getWord16le =
  Get $ \buf next -> Ok (next+2) (unsafePerformIO $ getW16le buf next)

getW32le :: JSAny -> Int -> IO Word32
getW32le = ffi "(function(b,i){return b.getUint32(i,true);})"

getWord32le :: Get Word32
getWord32le =
  Get $ \buf next -> Ok (next+4) (unsafePerformIO $ getW32le buf next)

getI8 :: JSAny -> Int -> IO Int8
getI8 = ffi "(function(b,i){return b.getInt8(i);})"

getInt8 :: Get Int8
getInt8 =
  Get $ \buf next -> Ok (next+1) (unsafePerformIO $ getI8 buf next)

getI16le :: JSAny -> Int -> IO Int16
getI16le = ffi "(function(b,i){return b.getInt16(i,true);})"

getInt16le :: Get Int16
getInt16le =
  Get $ \buf next -> Ok (next+2) (unsafePerformIO $ getI16le buf next)

getI32le :: JSAny -> Int -> IO Int32
getI32le = ffi "(function(b,i){return b.getInt32(i,true);})"

getInt32le :: Get Int32
getInt32le =
  Get $ \buf next -> Ok (next+4) (unsafePerformIO $ getI32le buf next)

getF32le :: JSAny -> Int -> IO Float
getF32le = ffi "(function(b,i){return b.getFloat32(i,true);})"

getFloat32le :: Get Float
getFloat32le =
  Get $ \buf next -> Ok (next+4) (unsafePerformIO $ getF32le buf next)

getF64le :: JSAny -> Int -> IO Double
getF64le = ffi "(function(b,i){return b.getFloat64(i,true);})"

getFloat64le :: Get Double
getFloat64le =
  Get $ \buf next -> Ok (next+8) (unsafePerformIO $ getF64le buf next)

getBytes :: Int -> Get BlobData
getBytes len = Get $ \buf next -> Ok (next+len) (BlobData next len buf)

-- | Read a 'JSString' of @n@ characters. Encoding is assumed to be UTF-16.
getJSString :: Word32 -> Get JSString
getJSString len = Get $ \buf next ->
  Ok (next+fromIntegral (len+len)) (unsafePerformIO $ getJSS buf next len)

getJSS :: JSAny -> Int -> Word32 -> IO JSString
getJSS = ffi "(function(b,off,len){return String.fromCharCode.apply(null,new Uint16Array(b.buffer,off,len));})"

-- | Skip n bytes of input.
skip :: Int -> Get ()
skip len = Get $ \_buf next -> Ok (next+len) ()

-- | Run a Get computation.
runGet :: Get a -> BlobData -> Either JSString a
runGet (Get p) (BlobData off len bd) = do
  let res = unsafePerformIO $ do
        Ex.catch (pure $! p bd off)
                 (\(JSException e) -> pure (Fail e))
  case res of
    Ok consumed x
      | consumed <= len -> Right x
      | otherwise       -> Left "Not enough data!"
    Fail s              -> Left s

#else

newtype Get a = Get (BG.Get a) deriving (Functor, Applicative, Monad)

runGet :: Get a -> BlobData -> Either JSString a
runGet (Get g) (BlobData bd) = unsafePerformIO $ do
  Ex.catch (Right <$> (return $! BG.runGet g bd)) mEx

mEx :: Ex.SomeException -> IO (Either JSString a)
mEx ex = return . Left $ toJSStr $ 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)

getJSString :: Int -> Get JSString
getJSString len = Get $ do
  toJSStr `fmap` forM [1..len] (\_ -> fmap (chr . fromIntegral) BG.getWord16le)

-- | Skip n bytes of input.
skip :: Int -> Get ()
skip = Get . BG.skip

#endif