{-# LANGUAGE CPP #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Foreign.JavaScript.Utils
  ( bsFromMutableArrayBuffer
  , bsToArrayBuffer
  , jsonDecode
  , js_jsonParse
  ) where

import Control.Lens
import Data.Aeson
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Foreign.JavaScript.Internal.Utils (js_dataView)
import qualified GHCJS.Buffer as JS
import GHCJS.DOM.Types (ArrayBuffer (..))
import GHCJS.Marshal ()
import Language.Javascript.JSaddle (jsg, js1)
import qualified JavaScript.TypedArray.ArrayBuffer as JS
import Language.Javascript.JSaddle.Types (JSString, JSM, JSVal, MonadJSM, ghcjsPure, jsval, liftJSM)
#ifdef ghcjs_HOST_OS
import Control.Exception (SomeException)
import Language.Javascript.JSaddle (fromJSVal, catch)
import System.IO.Unsafe
#else
import qualified Data.ByteString.Lazy as LBS
import Data.Text.Encoding
import Language.Javascript.JSaddle (textFromJSString)
#endif

{-# INLINABLE bsFromMutableArrayBuffer #-}
bsFromMutableArrayBuffer :: MonadJSM m => JS.MutableArrayBuffer -> m ByteString
bsFromMutableArrayBuffer :: forall (m :: * -> *).
MonadJSM m =>
MutableArrayBuffer -> m ByteString
bsFromMutableArrayBuffer MutableArrayBuffer
ab = JSM ByteString -> m ByteString
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM ByteString -> m ByteString) -> JSM ByteString -> m ByteString
forall a b. (a -> b) -> a -> b
$ MutableArrayBuffer -> JSM ArrayBuffer
JS.unsafeFreeze MutableArrayBuffer
ab JSM ArrayBuffer
-> (ArrayBuffer -> JSM (SomeBuffer Immutable))
-> JSM (SomeBuffer Immutable)
forall a b. JSM a -> (a -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
    GHCJSPure (SomeBuffer Immutable) -> JSM (SomeBuffer Immutable)
forall a. GHCJSPure a -> JSM a
ghcjsPure (GHCJSPure (SomeBuffer Immutable) -> JSM (SomeBuffer Immutable))
-> (ArrayBuffer -> GHCJSPure (SomeBuffer Immutable))
-> ArrayBuffer
-> JSM (SomeBuffer Immutable)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArrayBuffer -> GHCJSPure (SomeBuffer Immutable)
forall (any :: MutabilityType (*)).
SomeArrayBuffer any -> GHCJSPure (SomeBuffer any)
JS.createFromArrayBuffer JSM (SomeBuffer Immutable)
-> (SomeBuffer Immutable -> JSM ByteString) -> JSM ByteString
forall a b. JSM a -> (a -> JSM b) -> JSM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= GHCJSPure ByteString -> JSM ByteString
forall a. GHCJSPure a -> JSM a
ghcjsPure (GHCJSPure ByteString -> JSM ByteString)
-> (SomeBuffer Immutable -> GHCJSPure ByteString)
-> SomeBuffer Immutable
-> JSM ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Maybe Int -> SomeBuffer Immutable -> GHCJSPure ByteString
JS.toByteString Int
0 Maybe Int
forall a. Maybe a
Nothing

{-# INLINABLE bsToArrayBuffer #-}
bsToArrayBuffer :: MonadJSM m => ByteString -> m ArrayBuffer
bsToArrayBuffer :: forall (m :: * -> *). MonadJSM m => ByteString -> m ArrayBuffer
bsToArrayBuffer ByteString
bs = JSM ArrayBuffer -> m ArrayBuffer
forall (m :: * -> *) a. MonadJSM m => JSM a -> m a
liftJSM (JSM ArrayBuffer -> m ArrayBuffer)
-> JSM ArrayBuffer -> m ArrayBuffer
forall a b. (a -> b) -> a -> b
$ do
  (b, off, len) <- GHCJSPure (SomeBuffer Immutable, Int, Int)
-> JSM (SomeBuffer Immutable, Int, Int)
forall a. GHCJSPure a -> JSM a
ghcjsPure (GHCJSPure (SomeBuffer Immutable, Int, Int)
 -> JSM (SomeBuffer Immutable, Int, Int))
-> GHCJSPure (SomeBuffer Immutable, Int, Int)
-> JSM (SomeBuffer Immutable, Int, Int)
forall a b. (a -> b) -> a -> b
$ ByteString -> GHCJSPure (SomeBuffer Immutable, Int, Int)
JS.fromByteString ByteString
bs
  ArrayBuffer <$> if BS.length bs == 0 --TODO: remove this logic when https://github.com/ghcjs/ghcjs-base/issues/49 is fixed
                  then JS.create 0 >>= ghcjsPure . JS.getArrayBuffer >>= ghcjsPure . jsval
                  else do
                    ref <- ghcjsPure (JS.getArrayBuffer b) >>= ghcjsPure . jsval
                    js_dataView off len ref

jsonDecode :: FromJSON a => JSString -> Maybe a
#ifdef ghcjs_HOST_OS
jsonDecode t = do
  result <- unsafePerformIO $ (fromJSVal =<< js_jsonParse t) `catch` (\(_ :: SomeException) -> pure Nothing)
  case fromJSON result of
    Success a -> Just a
    Error _ -> Nothing
#else
jsonDecode :: forall a. FromJSON a => JSString -> Maybe a
jsonDecode = ByteString -> Maybe a
forall a. FromJSON a => ByteString -> Maybe a
decode (ByteString -> Maybe a)
-> (JSString -> ByteString) -> JSString -> Maybe a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString)
-> (JSString -> ByteString) -> JSString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString)
-> (JSString -> Text) -> JSString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSString -> Text
textFromJSString
#endif

js_jsonParse :: JSString -> JSM JSVal
js_jsonParse :: JSString -> JSM JSVal
js_jsonParse JSString
a = String -> JSM JSVal
forall a. ToJSString a => a -> JSM JSVal
jsg String
"JSON" JSM JSVal
-> Getting (JSM JSVal) (JSM JSVal) (JSM JSVal) -> JSM JSVal
forall s a. s -> Getting a s a -> a
^. String -> JSString -> JSF
forall name a0. (ToJSString name, ToJSVal a0) => name -> a0 -> JSF
js1 String
"parse" JSString
a