{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, ScopedTypeVariables #-}
{-# LANGUAGE RecordWildCards #-}
module Foreign.JavaScript.Marshal (
    ToJS(..), FromJS,
    FFI, JSFunction, toCode, marshalResult, ffi,
    IsHandler, convertArguments, handle,

    NewJSObject, wrapImposeStablePtr,
    ) where

import           Data.Aeson             as JSON
#if defined(CABAL)
#if MIN_VERSION_aeson(1,0,0)
import qualified Data.Aeson.Text        as JSON   (encodeToTextBuilder)
#else
import qualified Data.Aeson.Encode      as JSON   (encodeToTextBuilder)
#endif
#else
import qualified Data.Aeson.Text        as JSON   (encodeToTextBuilder)
#endif
import qualified Data.Aeson.Types       as JSON
import           Data.Functor                     ((<$>))
import           Data.List                        (intercalate)
import qualified Data.Text              as T
import qualified Data.Text.Lazy
import qualified Data.Text.Lazy.Builder
import qualified Data.Vector            as Vector
import           Safe                             (atMay)

import Foreign.JavaScript.EventLoop (fromJSStablePtr, newJSObjectFromCoupon )
import Foreign.JavaScript.Types
import Foreign.RemotePtr

{-----------------------------------------------------------------------------
    Convert Haskell values to JavaScript values
------------------------------------------------------------------------------}
-- | JavaScript code snippet.
newtype JSCode = JSCode { JSCode -> String
unJSCode :: String }
    deriving (JSCode -> JSCode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: JSCode -> JSCode -> Bool
$c/= :: JSCode -> JSCode -> Bool
== :: JSCode -> JSCode -> Bool
$c== :: JSCode -> JSCode -> Bool
Eq, Eq JSCode
JSCode -> JSCode -> Bool
JSCode -> JSCode -> Ordering
JSCode -> JSCode -> JSCode
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: JSCode -> JSCode -> JSCode
$cmin :: JSCode -> JSCode -> JSCode
max :: JSCode -> JSCode -> JSCode
$cmax :: JSCode -> JSCode -> JSCode
>= :: JSCode -> JSCode -> Bool
$c>= :: JSCode -> JSCode -> Bool
> :: JSCode -> JSCode -> Bool
$c> :: JSCode -> JSCode -> Bool
<= :: JSCode -> JSCode -> Bool
$c<= :: JSCode -> JSCode -> Bool
< :: JSCode -> JSCode -> Bool
$c< :: JSCode -> JSCode -> Bool
compare :: JSCode -> JSCode -> Ordering
$ccompare :: JSCode -> JSCode -> Ordering
Ord, Int -> JSCode -> String -> String
[JSCode] -> String -> String
JSCode -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [JSCode] -> String -> String
$cshowList :: [JSCode] -> String -> String
show :: JSCode -> String
$cshow :: JSCode -> String
showsPrec :: Int -> JSCode -> String -> String
$cshowsPrec :: Int -> JSCode -> String -> String
Show)

-- | Helper class for rendering Haskell values as JavaScript expressions.
class ToJS a where
    render     :: a   -> IO JSCode
    renderList :: [a] -> IO JSCode

    renderList [a]
xs = do
        [JSCode]
ys <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. ToJS a => a -> IO JSCode
render [a]
xs
        String -> IO JSCode
jsCode forall a b. (a -> b) -> a -> b
$ String
"[" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall a b. (a -> b) -> [a] -> [b]
map JSCode -> String
unJSCode [JSCode]
ys) forall a. [a] -> [a] -> [a]
++ String
"]"

jsCode :: String -> IO JSCode
jsCode = forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> JSCode
JSCode

instance ToJS Float      where render :: Float -> IO JSCode
render   = forall a. ToJS a => a -> IO JSCode
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Value
JSON.toJSON
instance ToJS Double     where render :: Double -> IO JSCode
render   = forall a. ToJS a => a -> IO JSCode
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Value
JSON.toJSON
instance ToJS Int        where render :: Int -> IO JSCode
render   = String -> IO JSCode
jsCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show
instance ToJS Bool       where render :: Bool -> IO JSCode
render Bool
b = String -> IO JSCode
jsCode forall a b. (a -> b) -> a -> b
$ if Bool
b then String
"true" else String
"false"
instance ToJS JSON.Value where render :: Value -> IO JSCode
render   = String -> IO JSCode
jsCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> String
showJSON
instance ToJS T.Text     where render :: Text -> IO JSCode
render   = forall a. ToJS a => a -> IO JSCode
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
JSON.String
instance ToJS Char       where
    render :: Char -> IO JSCode
render Char
x   = forall a. ToJS a => [a] -> IO JSCode
renderList [Char
x]
    renderList :: String -> IO JSCode
renderList = forall a. ToJS a => a -> IO JSCode
render forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
JSON.String forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack

instance ToJS a => ToJS [a] where
    render :: [a] -> IO JSCode
render = forall a. ToJS a => [a] -> IO JSCode
renderList

instance ToJS HsEvent    where
    render :: HsEvent -> IO JSCode
render HsEvent
x   = forall a. ToJS a => a -> IO JSCode
render forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. RemotePtr a -> IO Text
unprotectedGetCoupon HsEvent
x
instance ToJS JSObject   where
    render :: JSObject -> IO JSCode
render JSObject
x   = String -> JSCode -> JSCode
apply1 String
"Haskell.deRefStablePtr(%1)"
                 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. ToJS a => a -> IO JSCode
render forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. RemotePtr a -> IO Text
unprotectedGetCoupon JSObject
x)

-- | Show a type in a JSON compatible way.
showJSON :: ToJSON a => a -> String
showJSON :: forall a. ToJSON a => a -> String
showJSON
    = Text -> String
Data.Text.Lazy.unpack
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
Data.Text.Lazy.Builder.toLazyText
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Builder
JSON.encodeToTextBuilder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Value
JSON.toJSON

{-----------------------------------------------------------------------------
    Convert JavaScript values to Haskell values
------------------------------------------------------------------------------}
data FromJS' a = FromJS'
    { forall a. FromJS' a -> JSCode -> JSCode
wrapCode :: (JSCode -> JSCode)
    , forall a. FromJS' a -> Window -> Value -> IO a
marshal  :: Window -> JSON.Value -> IO a
    }

-- | Helper class for converting JavaScript values to Haskell values.
class FromJS a where
    fromJS   :: FromJS' a

-- | Marshal a simple type to Haskell.
simple :: FromJSON a => (JSCode -> JSCode) -> FromJS' a
simple :: forall a. FromJSON a => (JSCode -> JSCode) -> FromJS' a
simple JSCode -> JSCode
f =
    FromJS' { wrapCode :: JSCode -> JSCode
wrapCode = JSCode -> JSCode
f , marshal :: Window -> Value -> IO a
marshal = \Window
_ -> forall {m :: * -> *} {a}. Monad m => Result a -> m a
fromSuccessIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FromJSON a => Value -> Result a
JSON.fromJSON }
    where
    fromSuccessIO :: Result a -> m a
fromSuccessIO (JSON.Success a
a) = forall (m :: * -> *) a. Monad m => a -> m a
return a
a

instance FromJS String     where fromJS :: FromJS' String
fromJS = forall a. FromJSON a => (JSCode -> JSCode) -> FromJS' a
simple forall a b. (a -> b) -> a -> b
$ String -> JSCode -> JSCode
apply1 String
"%1.toString()"
instance FromJS T.Text     where fromJS :: FromJS' Text
fromJS = forall a. FromJSON a => (JSCode -> JSCode) -> FromJS' a
simple forall a b. (a -> b) -> a -> b
$ String -> JSCode -> JSCode
apply1 String
"%1.toString()"
instance FromJS Int        where fromJS :: FromJS' Int
fromJS = forall a. FromJSON a => (JSCode -> JSCode) -> FromJS' a
simple forall a. a -> a
id
instance FromJS Double     where fromJS :: FromJS' Double
fromJS = forall a. FromJSON a => (JSCode -> JSCode) -> FromJS' a
simple forall a. a -> a
id
instance FromJS Float      where fromJS :: FromJS' Float
fromJS = forall a. FromJSON a => (JSCode -> JSCode) -> FromJS' a
simple forall a. a -> a
id
instance FromJS JSON.Value where fromJS :: FromJS' Value
fromJS = forall a. FromJSON a => (JSCode -> JSCode) -> FromJS' a
simple forall a. a -> a
id

instance FromJS ()         where
    fromJS :: FromJS' ()
fromJS = FromJS' { wrapCode :: JSCode -> JSCode
wrapCode = forall a. a -> a
id, marshal :: Window -> Value -> IO ()
marshal = \Window
_ Value
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return () }

instance FromJS JSObject   where
    fromJS :: FromJS' JSObject
fromJS = FromJS'
        { wrapCode :: JSCode -> JSCode
wrapCode = String -> JSCode -> JSCode
apply1 String
"Haskell.getStablePtr(%1)"
        , marshal :: Window -> Value -> IO JSObject
marshal  = \Window
w Value
v -> Value -> Window -> IO JSObject
fromJSStablePtr Value
v Window
w
        }

-- FIXME: Not sure whether this instance is really a good idea.
instance FromJS [JSObject] where
    fromJS :: FromJS' [JSObject]
fromJS = FromJS'
        { wrapCode :: JSCode -> JSCode
wrapCode = String -> JSCode -> JSCode
apply1 String
"Haskell.map(Haskell.getStablePtr, %1)"
        , marshal :: Window -> Value -> IO [JSObject]
marshal  = \Window
w (JSON.Array Array
vs) -> do
            forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\Value
v -> Value -> Window -> IO JSObject
fromJSStablePtr Value
v Window
w) (forall a. Vector a -> [a]
Vector.toList Array
vs)
        }

instance FromJS NewJSObject where
    fromJS :: FromJS' NewJSObject
fromJS = FromJS' { wrapCode :: JSCode -> JSCode
wrapCode = forall a. a -> a
id, marshal :: Window -> Value -> IO NewJSObject
marshal = \Window
_ Value
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return NewJSObject
NewJSObject }

-- | Impose a JS stable pointer upon a newly created JavaScript object.
--   In this way, JSObject can be created without waiting for the browser
--   to return a result.
wrapImposeStablePtr :: Window -> JSFunction NewJSObject -> IO (JSFunction JSObject)
wrapImposeStablePtr :: Window -> JSFunction NewJSObject -> IO (JSFunction JSObject)
wrapImposeStablePtr (Window{[Cookie]
IO ()
TVar CallBufferMode
RemotePtr ()
TMVar (String -> String)
Vendor JSPtr
Vendor (Value -> IO ())
Server
String -> IO ()
String -> IO Value
IO () -> IO ()
wJSObjects :: Window -> Vendor JSPtr
wEventHandlers :: Window -> Vendor (Value -> IO ())
wRoot :: Window -> RemotePtr ()
onDisconnect :: Window -> IO () -> IO ()
debug :: Window -> String -> IO ()
timestamp :: Window -> IO ()
wCallBufferMode :: Window -> TVar CallBufferMode
wCallBuffer :: Window -> TMVar (String -> String)
callEval :: Window -> String -> IO Value
runEval :: Window -> String -> IO ()
getCookies :: Window -> [Cookie]
getServer :: Window -> Server
wJSObjects :: Vendor JSPtr
wEventHandlers :: Vendor (Value -> IO ())
wRoot :: RemotePtr ()
onDisconnect :: IO () -> IO ()
debug :: String -> IO ()
timestamp :: IO ()
wCallBufferMode :: TVar CallBufferMode
wCallBuffer :: TMVar (String -> String)
callEval :: String -> IO Value
runEval :: String -> IO ()
getCookies :: [Cookie]
getServer :: Server
..}) JSFunction NewJSObject
f = do
    Text
coupon  <- forall a. Vendor a -> IO Text
newCoupon Vendor JSPtr
wJSObjects
    JSCode
rcoupon <- forall a. ToJS a => a -> IO JSCode
render Text
coupon
    JSCode
rcode   <- forall a. JSFunction a -> IO JSCode
code JSFunction NewJSObject
f
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ JSFunction
        { code :: IO JSCode
code = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> [JSCode] -> JSCode
apply String
"Haskell.imposeStablePtr(%1,%2)" [JSCode
rcode, JSCode
rcoupon]
        , marshalResult :: Window -> Value -> IO JSObject
marshalResult = \Window
w Value
_ -> Window -> Text -> IO JSObject
newJSObjectFromCoupon Window
w Text
coupon
        }

{-----------------------------------------------------------------------------
    Variable argument JavaScript functions
------------------------------------------------------------------------------}
-- | A JavaScript function with a given output type @a@.
data JSFunction a = JSFunction
    { forall a. JSFunction a -> IO JSCode
code          :: IO JSCode
      -- ^ Code snippet that implements the function.
    , forall a. JSFunction a -> Window -> Value -> IO a
marshalResult :: Window -> JSON.Value -> IO a
      -- ^ Marshal the function result to a Haskell value.
    }

-- | Change the output type of a 'JSFunction'.
instance Functor JSFunction where
    fmap :: forall a b. (a -> b) -> JSFunction a -> JSFunction b
fmap a -> b
f (JSFunction IO JSCode
c Window -> Value -> IO a
m) = forall a. IO JSCode -> (Window -> Value -> IO a) -> JSFunction a
JSFunction IO JSCode
c (\Window
w Value
v -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f forall a b. (a -> b) -> a -> b
$ Window -> Value -> IO a
m Window
w Value
v)

-- | Render function to a textual representation using JavaScript syntax.
toCode :: JSFunction a -> IO String
toCode :: forall a. JSFunction a -> IO String
toCode = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JSCode -> String
unJSCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. JSFunction a -> IO JSCode
code


-- | Helper class for making 'ffi' a variable argument function.
class FFI a where
    fancy :: ([JSCode] -> IO JSCode) -> a

instance (ToJS a, FFI b) => FFI (a -> b) where
    fancy :: ([JSCode] -> IO JSCode) -> a -> b
fancy [JSCode] -> IO JSCode
f a
a = forall a. FFI a => ([JSCode] -> IO JSCode) -> a
fancy forall a b. (a -> b) -> a -> b
$ \[JSCode]
xs -> do
        JSCode
x <- forall a. ToJS a => a -> IO JSCode
render a
a
        [JSCode] -> IO JSCode
f (JSCode
xforall a. a -> [a] -> [a]
:[JSCode]
xs)

instance FromJS b        => FFI (JSFunction b) where
    fancy :: ([JSCode] -> IO JSCode) -> JSFunction b
fancy [JSCode] -> IO JSCode
f   = JSFunction
        { code :: IO JSCode
code          = forall a. FromJS' a -> JSCode -> JSCode
wrapCode FromJS' b
b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [JSCode] -> IO JSCode
f []
        , marshalResult :: Window -> Value -> IO b
marshalResult = forall a. FromJS' a -> Window -> Value -> IO a
marshal FromJS' b
b
        }
        where b :: FromJS' b
b = forall a. FromJS a => FromJS' a
fromJS

-- | Simple JavaScript FFI with string substitution.
--
-- Inspired by the Fay language. <https://github.com/faylang/fay/wiki>
--
-- > example :: String -> Int -> JSFunction String
-- > example = ffi "$(%1).prop('checked',%2)"
--
-- The 'ffi' function takes a string argument representing the JavaScript
-- code to be executed on the client.
-- Occurrences of the substrings @%1@ to @%9@ will be replaced by
-- subequent arguments.
-- The substring @%%@ in the original will be replaced by @%@ (character escape).
--
-- Note: Always specify a type signature! The types automate
-- how values are marshalled between Haskell and JavaScript.
-- The class instances for the 'FFI' class show which conversions are supported.
--
ffi :: FFI a => String -> a
ffi :: forall a. FFI a => String -> a
ffi String
macro = forall a. FFI a => ([JSCode] -> IO JSCode) -> a
fancy (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> [JSCode] -> JSCode
apply String
macro)

testFFI :: String -> Int -> JSFunction String
testFFI :: String -> Int -> JSFunction String
testFFI = forall a. FFI a => String -> a
ffi String
"$(%1).prop('checked',%2)"

{-----------------------------------------------------------------------------
    Type classes
------------------------------------------------------------------------------}
-- | Helper class for exporting Haskell functions to JavaScript
-- as event handlers.
class IsHandler a where
    convertArgs :: a -> Int -> [JSCode]
    handle      :: a -> Window -> [JSON.Value] -> IO ()

instance (FromJS a, IsHandler b) => IsHandler (a -> b) where
    convertArgs :: (a -> b) -> Int -> [JSCode]
convertArgs = forall a b. (FromJS a, IsHandler b) => (a -> b) -> Int -> [JSCode]
convertArgs'
    handle :: (a -> b) -> Window -> [Value] -> IO ()
handle a -> b
f = \Window
w (Value
a:[Value]
as) -> do
        a
x <- forall a. FromJS' a -> Window -> Value -> IO a
marshal forall a. FromJS a => FromJS' a
fromJS Window
w Value
a
        forall a. IsHandler a => a -> Window -> [Value] -> IO ()
handle (a -> b
f a
x) Window
w [Value]
as

convertArgs' :: forall a b. (FromJS a, IsHandler b) => (a -> b) -> Int -> [JSCode]
convertArgs' :: forall a b. (FromJS a, IsHandler b) => (a -> b) -> Int -> [JSCode]
convertArgs' a -> b
f Int
n = JSCode -> JSCode
wrap JSCode
arg forall a. a -> [a] -> [a]
: forall a. IsHandler a => a -> Int -> [JSCode]
convertArgs (a -> b
f a
x) (Int
nforall a. Num a => a -> a -> a
+Int
1)
    where
    x :: a
x    = forall a. HasCallStack => a
undefined :: a
    wrap :: JSCode -> JSCode
wrap = forall a. FromJS' a -> JSCode -> JSCode
wrapCode (forall a. FromJS a => FromJS' a
fromJS :: FromJS' a)
    arg :: JSCode
arg  = String -> JSCode
JSCode forall a b. (a -> b) -> a -> b
$ String
"arguments[" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
n forall a. [a] -> [a] -> [a]
++ String
"]"

instance IsHandler (IO ()) where
    convertArgs :: IO () -> Int -> [JSCode]
convertArgs IO ()
_ Int
_ = []
    handle :: IO () -> Window -> [Value] -> IO ()
handle      IO ()
m   = \Window
_ [Value]
_ -> IO ()
m

-- | Code needed to preconvert arguments on the JavaScript side.
convertArguments :: IsHandler a => a -> String
convertArguments :: forall a. IsHandler a => a -> String
convertArguments a
f =
    String
"[" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," (forall a b. (a -> b) -> [a] -> [b]
map JSCode -> String
unJSCode forall a b. (a -> b) -> a -> b
$ forall a. IsHandler a => a -> Int -> [JSCode]
convertArgs a
f Int
0) forall a. [a] -> [a] -> [a]
++ String
"]"


{-----------------------------------------------------------------------------
    String utilities
------------------------------------------------------------------------------}
-- | String substitution.
-- Substitute occurences of %1, %2 up to %9 with the argument strings.
-- The types ensure that the % character has no meaning in the generated output.
--
-- > apply "%1 and %2" [x,y] = x ++ " and " ++ y
apply :: String -> [JSCode] -> JSCode
apply :: String -> [JSCode] -> JSCode
apply String
code [JSCode]
args = String -> JSCode
JSCode forall a b. (a -> b) -> a -> b
$ String -> String
go String
code
    where
    at :: [b] -> Int -> b
at [b]
xs Int
i = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error String
err) forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Int -> Maybe a
atMay [b]
xs Int
i
    err :: String
err     = String
"Graphics.UI.Threepenny.FFI: Too few arguments in FFI call!"
    argument :: Int -> String
argument Int
i = JSCode -> String
unJSCode ([JSCode]
args forall {b}. [b] -> Int -> b
`at` Int
i)

    go :: String -> String
go []           = []
    go (Char
'%':Char
'%':String
cs) = Char
'%' forall a. a -> [a] -> [a]
: String -> String
go String
cs
    go (Char
'%':Char
c  :String
cs) = Int -> String
argument Int
index forall a. [a] -> [a] -> [a]
++ String -> String
go String
cs
        where index :: Int
index = forall a. Enum a => a -> Int
fromEnum Char
c forall a. Num a => a -> a -> a
- forall a. Enum a => a -> Int
fromEnum Char
'1'
    go (Char
c:String
cs)       = Char
c forall a. a -> [a] -> [a]
: String -> String
go String
cs

-- | Apply string substitution that expects a single argument.
apply1 :: String -> JSCode -> JSCode
apply1 :: String -> JSCode -> JSCode
apply1 String
s JSCode
x = String -> [JSCode] -> JSCode
apply String
s [JSCode
x]