{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TypeApplications #-}

module Language.JavaScript.Inline.Core.Message where

import Control.Monad
import Data.Binary
import Data.Binary.Get
import Data.ByteString.Builder
import qualified Data.ByteString.Lazy as LBS
import Data.String
import Language.JavaScript.Inline.Core.JSVal
import Language.JavaScript.Inline.Core.Utils

data JSExprSegment
  = Code LBS.ByteString
  | BufferLiteral LBS.ByteString
  | StringLiteral LBS.ByteString
  | JSONLiteral LBS.ByteString
  | JSValLiteral JSVal
  deriving (Int -> JSExprSegment -> ShowS
[JSExprSegment] -> ShowS
JSExprSegment -> String
(Int -> JSExprSegment -> ShowS)
-> (JSExprSegment -> String)
-> ([JSExprSegment] -> ShowS)
-> Show JSExprSegment
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JSExprSegment] -> ShowS
$cshowList :: [JSExprSegment] -> ShowS
show :: JSExprSegment -> String
$cshow :: JSExprSegment -> String
showsPrec :: Int -> JSExprSegment -> ShowS
$cshowsPrec :: Int -> JSExprSegment -> ShowS
Show)

-- | Represents a JavaScript expression.
--
-- Use the 'IsString' instance to convert a 'String' to 'JSExpr', and the
-- 'Semigroup' instance for concating 'JSExpr'. It's also possible to embed
-- other things into 'JSExpr', e.g. a buffer literal, JSON value or a 'JSVal'.
newtype JSExpr = JSExpr
  { JSExpr -> [JSExprSegment]
unJSExpr :: [JSExprSegment]
  }
  deriving (b -> JSExpr -> JSExpr
NonEmpty JSExpr -> JSExpr
JSExpr -> JSExpr -> JSExpr
(JSExpr -> JSExpr -> JSExpr)
-> (NonEmpty JSExpr -> JSExpr)
-> (forall b. Integral b => b -> JSExpr -> JSExpr)
-> Semigroup JSExpr
forall b. Integral b => b -> JSExpr -> JSExpr
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> JSExpr -> JSExpr
$cstimes :: forall b. Integral b => b -> JSExpr -> JSExpr
sconcat :: NonEmpty JSExpr -> JSExpr
$csconcat :: NonEmpty JSExpr -> JSExpr
<> :: JSExpr -> JSExpr -> JSExpr
$c<> :: JSExpr -> JSExpr -> JSExpr
Semigroup, Semigroup JSExpr
JSExpr
Semigroup JSExpr
-> JSExpr
-> (JSExpr -> JSExpr -> JSExpr)
-> ([JSExpr] -> JSExpr)
-> Monoid JSExpr
[JSExpr] -> JSExpr
JSExpr -> JSExpr -> JSExpr
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [JSExpr] -> JSExpr
$cmconcat :: [JSExpr] -> JSExpr
mappend :: JSExpr -> JSExpr -> JSExpr
$cmappend :: JSExpr -> JSExpr -> JSExpr
mempty :: JSExpr
$cmempty :: JSExpr
$cp1Monoid :: Semigroup JSExpr
Monoid, Int -> JSExpr -> ShowS
[JSExpr] -> ShowS
JSExpr -> String
(Int -> JSExpr -> ShowS)
-> (JSExpr -> String) -> ([JSExpr] -> ShowS) -> Show JSExpr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JSExpr] -> ShowS
$cshowList :: [JSExpr] -> ShowS
show :: JSExpr -> String
$cshow :: JSExpr -> String
showsPrec :: Int -> JSExpr -> ShowS
$cshowsPrec :: Int -> JSExpr -> ShowS
Show)

instance IsString JSExpr where
  fromString :: String -> JSExpr
fromString = [JSExprSegment] -> JSExpr
JSExpr ([JSExprSegment] -> JSExpr)
-> (String -> [JSExprSegment]) -> String -> JSExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSExprSegment -> [JSExprSegment]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (JSExprSegment -> [JSExprSegment])
-> (String -> JSExprSegment) -> String -> [JSExprSegment]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> JSExprSegment
Code (ByteString -> JSExprSegment)
-> (String -> ByteString) -> String -> JSExprSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
stringToLBS

-- | To convert a JavaScript value to Haskell, we need to specify its "raw
-- type", which can be one of the following:
data RawJSType
  = -- | The JavaScript value is discarded.
    RawNone
  | -- | The JavaScript value is an @ArrayBufferView@, @ArrayBuffer@ or
    -- @string@.
    RawBuffer
  | -- | The JavaScript value can be JSON-encoded via @JSON.stringify()@.
    RawJSON
  | -- | The JavaScript value should be managed as a 'JSVal'.
    RawJSVal
  deriving (Int -> RawJSType -> ShowS
[RawJSType] -> ShowS
RawJSType -> String
(Int -> RawJSType -> ShowS)
-> (RawJSType -> String)
-> ([RawJSType] -> ShowS)
-> Show RawJSType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RawJSType] -> ShowS
$cshowList :: [RawJSType] -> ShowS
show :: RawJSType -> String
$cshow :: RawJSType -> String
showsPrec :: Int -> RawJSType -> ShowS
$cshowsPrec :: Int -> RawJSType -> ShowS
Show)

data MessageHS
  = JSEvalRequest
      { MessageHS -> Word64
jsEvalRequestId :: Word64,
        MessageHS -> JSExpr
code :: JSExpr,
        MessageHS -> RawJSType
returnType :: RawJSType
      }
  | HSExportRequest
      { MessageHS -> Bool
exportIsSync :: Bool,
        MessageHS -> Word64
exportRequestId :: Word64,
        MessageHS -> Word64
exportFuncId :: Word64,
        MessageHS -> [(JSExpr, RawJSType)]
argsType :: [(JSExpr, RawJSType)]
      }
  | HSEvalResponse
      { MessageHS -> Bool
hsEvalResponseIsSync :: Bool,
        MessageHS -> Word64
hsEvalResponseId :: Word64,
        MessageHS -> Either ByteString JSExpr
hsEvalResponseContent :: Either LBS.ByteString JSExpr
      }
  | JSValFree Word64
  | Close
  deriving (Int -> MessageHS -> ShowS
[MessageHS] -> ShowS
MessageHS -> String
(Int -> MessageHS -> ShowS)
-> (MessageHS -> String)
-> ([MessageHS] -> ShowS)
-> Show MessageHS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MessageHS] -> ShowS
$cshowList :: [MessageHS] -> ShowS
show :: MessageHS -> String
$cshow :: MessageHS -> String
showsPrec :: Int -> MessageHS -> ShowS
$cshowsPrec :: Int -> MessageHS -> ShowS
Show)

data MessageJS
  = JSEvalResponse
      { MessageJS -> Word64
jsEvalResponseId :: Word64,
        MessageJS -> Either ByteString ByteString
jsEvalResponseContent :: Either LBS.ByteString LBS.ByteString
      }
  | HSEvalRequest
      { MessageJS -> Bool
hsEvalRequestIsSync :: Bool,
        MessageJS -> Word64
hsEvalRequestId :: Word64,
        MessageJS -> Word64
hsEvalRequestFunc :: Word64,
        MessageJS -> [ByteString]
args :: [LBS.ByteString]
      }
  | FatalError LBS.ByteString
  deriving (Int -> MessageJS -> ShowS
[MessageJS] -> ShowS
MessageJS -> String
(Int -> MessageJS -> ShowS)
-> (MessageJS -> String)
-> ([MessageJS] -> ShowS)
-> Show MessageJS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MessageJS] -> ShowS
$cshowList :: [MessageJS] -> ShowS
show :: MessageJS -> String
$cshow :: MessageJS -> String
showsPrec :: Int -> MessageJS -> ShowS
$cshowsPrec :: Int -> MessageJS -> ShowS
Show)

messageHSPut :: MessageHS -> Builder
messageHSPut :: MessageHS -> Builder
messageHSPut MessageHS
msg = case MessageHS
msg of
  JSEvalRequest {Word64
RawJSType
JSExpr
returnType :: RawJSType
code :: JSExpr
jsEvalRequestId :: Word64
returnType :: MessageHS -> RawJSType
code :: MessageHS -> JSExpr
jsEvalRequestId :: MessageHS -> Word64
..} ->
    Word8 -> Builder
word8Put Word8
0
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64Put Word64
jsEvalRequestId
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> JSExpr -> Builder
exprPut JSExpr
code
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> RawJSType -> Builder
rawTypePut RawJSType
returnType
  HSExportRequest {Bool
[(JSExpr, RawJSType)]
Word64
argsType :: [(JSExpr, RawJSType)]
exportFuncId :: Word64
exportRequestId :: Word64
exportIsSync :: Bool
argsType :: MessageHS -> [(JSExpr, RawJSType)]
exportFuncId :: MessageHS -> Word64
exportRequestId :: MessageHS -> Word64
exportIsSync :: MessageHS -> Bool
..} ->
    Word8 -> Builder
word8Put Word8
1
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Bool -> Builder
boolPut Bool
exportIsSync
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64Put Word64
exportRequestId
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64Put Word64
exportFuncId
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64Put (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([(JSExpr, RawJSType)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(JSExpr, RawJSType)]
argsType))
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ((JSExpr, RawJSType) -> Builder)
-> [(JSExpr, RawJSType)] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
        (\(JSExpr
code, RawJSType
raw_type) -> JSExpr -> Builder
exprPut JSExpr
code Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> RawJSType -> Builder
rawTypePut RawJSType
raw_type)
        [(JSExpr, RawJSType)]
argsType
  HSEvalResponse {Bool
Word64
Either ByteString JSExpr
hsEvalResponseContent :: Either ByteString JSExpr
hsEvalResponseId :: Word64
hsEvalResponseIsSync :: Bool
hsEvalResponseContent :: MessageHS -> Either ByteString JSExpr
hsEvalResponseId :: MessageHS -> Word64
hsEvalResponseIsSync :: MessageHS -> Bool
..} ->
    Word8 -> Builder
word8Put Word8
2
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Bool -> Builder
boolPut Bool
hsEvalResponseIsSync
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64Put Word64
hsEvalResponseId
      Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ( case Either ByteString JSExpr
hsEvalResponseContent of
             Left ByteString
err -> Word8 -> Builder
word8Put Word8
0 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
lbsPut ByteString
err
             Right JSExpr
r -> Word8 -> Builder
word8Put Word8
1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> JSExpr -> Builder
exprPut JSExpr
r
         )
  JSValFree Word64
v -> Word8 -> Builder
word8Put Word8
3 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64Put Word64
v
  MessageHS
Close -> Word8 -> Builder
word8Put Word8
4
  where
    boolPut :: Bool -> Builder
boolPut = Word8 -> Builder
word8Put (Word8 -> Builder) -> (Bool -> Word8) -> Bool -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word8) -> (Bool -> Int) -> Bool -> Word8
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Int
forall a. Enum a => a -> Int
fromEnum
    word8Put :: Word8 -> Builder
word8Put = Storable Word8 => Word8 -> Builder
forall a. Storable a => a -> Builder
storablePut @Word8
    word64Put :: Word64 -> Builder
word64Put = Storable Word64 => Word64 -> Builder
forall a. Storable a => a -> Builder
storablePut @Word64
    lbsPut :: ByteString -> Builder
lbsPut ByteString
s = Int64 -> Builder
forall a. Storable a => a -> Builder
storablePut (ByteString -> Int64
LBS.length ByteString
s) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
lazyByteString ByteString
s
    exprPut :: JSExpr -> Builder
exprPut JSExpr
code =
      Word64 -> Builder
word64Put (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral ([JSExprSegment] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (JSExpr -> [JSExprSegment]
unJSExpr JSExpr
code)) :: Word64)
        Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (JSExprSegment -> Builder) -> [JSExprSegment] -> Builder
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap JSExprSegment -> Builder
exprSegmentPut (JSExpr -> [JSExprSegment]
unJSExpr JSExpr
code)
    exprSegmentPut :: JSExprSegment -> Builder
exprSegmentPut (Code ByteString
s) = Word8 -> Builder
word8Put Word8
0 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
lbsPut ByteString
s
    exprSegmentPut (BufferLiteral ByteString
s) = Word8 -> Builder
word8Put Word8
1 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
lbsPut ByteString
s
    exprSegmentPut (StringLiteral ByteString
s) = Word8 -> Builder
word8Put Word8
2 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
lbsPut ByteString
s
    exprSegmentPut (JSONLiteral ByteString
s) = Word8 -> Builder
word8Put Word8
3 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
lbsPut ByteString
s
    exprSegmentPut (JSValLiteral JSVal
v) = Word8 -> Builder
word8Put Word8
4 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Word64 -> Builder
word64Put (JSVal -> Word64
unsafeUseJSVal JSVal
v)
    rawTypePut :: RawJSType -> Builder
rawTypePut RawJSType
RawNone = Word8 -> Builder
word8Put Word8
0
    rawTypePut RawJSType
RawBuffer = Word8 -> Builder
word8Put Word8
1
    rawTypePut RawJSType
RawJSON = Word8 -> Builder
word8Put Word8
2
    rawTypePut RawJSType
RawJSVal = Word8 -> Builder
word8Put Word8
3

messageJSGet :: Get MessageJS
messageJSGet :: Get MessageJS
messageJSGet = do
  Word8
t <- Get Word8
getWord8
  case Word8
t of
    Word8
0 -> do
      Word64
_id <- Get Word64
getWord64host
      Word8
_tag <- Get Word8
getWord8
      case Word8
_tag of
        Word8
0 -> do
          ByteString
_err_buf <- Get ByteString
lbsGet
          MessageJS -> Get MessageJS
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            JSEvalResponse :: Word64 -> Either ByteString ByteString -> MessageJS
JSEvalResponse
              { jsEvalResponseId :: Word64
jsEvalResponseId = Word64
_id,
                jsEvalResponseContent :: Either ByteString ByteString
jsEvalResponseContent = ByteString -> Either ByteString ByteString
forall a b. a -> Either a b
Left ByteString
_err_buf
              }
        Word8
1 -> do
          ByteString
_result_buf <- Get ByteString
lbsGet
          MessageJS -> Get MessageJS
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            JSEvalResponse :: Word64 -> Either ByteString ByteString -> MessageJS
JSEvalResponse
              { jsEvalResponseId :: Word64
jsEvalResponseId = Word64
_id,
                jsEvalResponseContent :: Either ByteString ByteString
jsEvalResponseContent = ByteString -> Either ByteString ByteString
forall a b. b -> Either a b
Right ByteString
_result_buf
              }
        Word8
_ -> String -> Get MessageJS
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get MessageJS) -> String -> Get MessageJS
forall a b. (a -> b) -> a -> b
$ String
"messageJSGet: invalid _tag " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word8 -> String
forall a. Show a => a -> String
show Word8
_tag
    Word8
1 -> do
      Bool
_is_sync <- Int -> Bool
forall a. Enum a => Int -> a
toEnum (Int -> Bool) -> (Word8 -> Int) -> Word8 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Bool) -> Get Word8 -> Get Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word8
getWord8
      Word64
_id <- Get Word64
getWord64host
      Word64
_func <- Get Word64
getWord64host
      Int
l <- Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int) -> Get Word64 -> Get Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64host
      [ByteString]
_args <- Int -> Get ByteString -> Get [ByteString]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
l Get ByteString
lbsGet
      MessageJS -> Get MessageJS
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        HSEvalRequest :: Bool -> Word64 -> Word64 -> [ByteString] -> MessageJS
HSEvalRequest
          { hsEvalRequestIsSync :: Bool
hsEvalRequestIsSync = Bool
_is_sync,
            hsEvalRequestId :: Word64
hsEvalRequestId = Word64
_id,
            hsEvalRequestFunc :: Word64
hsEvalRequestFunc = Word64
_func,
            args :: [ByteString]
args = [ByteString]
_args
          }
    Word8
2 -> ByteString -> MessageJS
FatalError (ByteString -> MessageJS) -> Get ByteString -> Get MessageJS
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get ByteString
lbsGet
    Word8
_ -> String -> Get MessageJS
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get MessageJS) -> String -> Get MessageJS
forall a b. (a -> b) -> a -> b
$ String
"messageJSGet: invalid tag " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Word8 -> String
forall a. Show a => a -> String
show Word8
t
  where
    lbsGet :: Get ByteString
lbsGet = do
      Int64
l <- Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Int64) -> Get Word64 -> Get Int64
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word64
getWord64host
      Int64 -> Get ByteString
getLazyByteString Int64
l