{-# 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)
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
(JSCode -> JSCode -> Bool)
-> (JSCode -> JSCode -> Bool) -> Eq JSCode
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
Eq JSCode
-> (JSCode -> JSCode -> Ordering)
-> (JSCode -> JSCode -> Bool)
-> (JSCode -> JSCode -> Bool)
-> (JSCode -> JSCode -> Bool)
-> (JSCode -> JSCode -> Bool)
-> (JSCode -> JSCode -> JSCode)
-> (JSCode -> JSCode -> JSCode)
-> Ord 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
$cp1Ord :: Eq JSCode
Ord, Int -> JSCode -> ShowS
[JSCode] -> ShowS
JSCode -> String
(Int -> JSCode -> ShowS)
-> (JSCode -> String) -> ([JSCode] -> ShowS) -> Show JSCode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [JSCode] -> ShowS
$cshowList :: [JSCode] -> ShowS
show :: JSCode -> String
$cshow :: JSCode -> String
showsPrec :: Int -> JSCode -> ShowS
$cshowsPrec :: Int -> JSCode -> ShowS
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 <- (a -> IO JSCode) -> [a] -> IO [JSCode]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> IO JSCode
forall a. ToJS a => a -> IO JSCode
render [a]
xs
        String -> IO JSCode
jsCode (String -> IO JSCode) -> String -> IO JSCode
forall a b. (a -> b) -> a -> b
$ String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((JSCode -> String) -> [JSCode] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map JSCode -> String
unJSCode [JSCode]
ys) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]"

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

instance ToJS Float      where render :: Float -> IO JSCode
render   = Value -> IO JSCode
forall a. ToJS a => a -> IO JSCode
render (Value -> IO JSCode) -> (Float -> Value) -> Float -> IO JSCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON
instance ToJS Double     where render :: Double -> IO JSCode
render   = Value -> IO JSCode
forall a. ToJS a => a -> IO JSCode
render (Value -> IO JSCode) -> (Double -> Value) -> Double -> IO JSCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON
instance ToJS Int        where render :: Int -> IO JSCode
render   = String -> IO JSCode
jsCode (String -> IO JSCode) -> (Int -> String) -> Int -> IO JSCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> String
forall a. Show a => a -> String
show
instance ToJS Bool       where render :: Bool -> IO JSCode
render Bool
b = String -> IO JSCode
jsCode (String -> IO JSCode) -> String -> IO 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 (String -> IO JSCode) -> (Value -> String) -> Value -> IO JSCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> String
forall a. ToJSON a => a -> String
showJSON
instance ToJS T.Text     where render :: Text -> IO JSCode
render   = Value -> IO JSCode
forall a. ToJS a => a -> IO JSCode
render (Value -> IO JSCode) -> (Text -> Value) -> Text -> IO JSCode
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   = String -> IO JSCode
forall a. ToJS a => [a] -> IO JSCode
renderList [Char
x]
    renderList :: String -> IO JSCode
renderList = Value -> IO JSCode
forall a. ToJS a => a -> IO JSCode
render (Value -> IO JSCode) -> (String -> Value) -> String -> IO JSCode
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
JSON.String (Text -> Value) -> (String -> Text) -> String -> Value
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 = [a] -> IO JSCode
forall a. ToJS a => [a] -> IO JSCode
renderList

instance ToJS HsEvent    where
    render :: HsEvent -> IO JSCode
render HsEvent
x   = Text -> IO JSCode
forall a. ToJS a => a -> IO JSCode
render (Text -> IO JSCode) -> IO Text -> IO JSCode
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< HsEvent -> IO Text
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)"
                 (JSCode -> JSCode) -> IO JSCode -> IO JSCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Text -> IO JSCode
forall a. ToJS a => a -> IO JSCode
render (Text -> IO JSCode) -> IO Text -> IO JSCode
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< JSObject -> IO Text
forall a. RemotePtr a -> IO Text
unprotectedGetCoupon JSObject
x)

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

{-----------------------------------------------------------------------------
    Convert JavaScript values to Haskell values
------------------------------------------------------------------------------}
data FromJS' a = FromJS'
    { FromJS' a -> JSCode -> JSCode
wrapCode :: (JSCode -> JSCode)
    , 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 :: (JSCode -> JSCode) -> FromJS' a
simple JSCode -> JSCode
f =
    FromJS' :: forall a.
(JSCode -> JSCode) -> (Window -> Value -> IO a) -> FromJS' a
FromJS' { wrapCode :: JSCode -> JSCode
wrapCode = JSCode -> JSCode
f , marshal :: Window -> Value -> IO a
marshal = \Window
_ -> Result a -> IO a
forall (m :: * -> *) a. Monad m => Result a -> m a
fromSuccessIO (Result a -> IO a) -> (Value -> Result a) -> Value -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Result a
forall a. FromJSON a => Value -> Result a
JSON.fromJSON }
    where
    fromSuccessIO :: Result a -> m a
fromSuccessIO (JSON.Success a
a) = a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
a

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

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

instance FromJS JSObject   where
    fromJS :: FromJS' JSObject
fromJS = FromJS' :: forall a.
(JSCode -> JSCode) -> (Window -> Value -> IO a) -> FromJS' a
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' :: forall a.
(JSCode -> JSCode) -> (Window -> Value -> IO a) -> FromJS' a
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
            (Value -> IO JSObject) -> [Value] -> IO [JSObject]
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) (Array -> [Value]
forall a. Vector a -> [a]
Vector.toList Array
vs)
        }

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

wrapImposeStablePtr :: Window -> JSFunction NewJSObject -> IO (JSFunction JSObject)
wrapImposeStablePtr :: Window -> JSFunction NewJSObject -> IO (JSFunction JSObject)
wrapImposeStablePtr w :: Window
w@(Window{[Cookie]
IO ()
TVar CallBufferMode
TVar ShowS
RemotePtr ()
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 -> TVar ShowS
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 :: TVar ShowS
callEval :: String -> IO Value
runEval :: String -> IO ()
getCookies :: [Cookie]
getServer :: Server
..}) JSFunction NewJSObject
f = do
    Text
coupon  <- Vendor JSPtr -> IO Text
forall a. Vendor a -> IO Text
newCoupon Vendor JSPtr
wJSObjects
    JSCode
rcoupon <- Text -> IO JSCode
forall a. ToJS a => a -> IO JSCode
render Text
coupon
    JSCode
rcode   <- JSFunction NewJSObject -> IO JSCode
forall a. JSFunction a -> IO JSCode
code JSFunction NewJSObject
f
    JSFunction JSObject -> IO (JSFunction JSObject)
forall (m :: * -> *) a. Monad m => a -> m a
return (JSFunction JSObject -> IO (JSFunction JSObject))
-> JSFunction JSObject -> IO (JSFunction JSObject)
forall a b. (a -> b) -> a -> b
$ JSFunction :: forall a. IO JSCode -> (Window -> Value -> IO a) -> JSFunction a
JSFunction
        { code :: IO JSCode
code = JSCode -> IO JSCode
forall (m :: * -> *) a. Monad m => a -> m a
return (JSCode -> IO JSCode) -> JSCode -> IO JSCode
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
_ -> Text -> JSPtr -> Vendor JSPtr -> IO JSObject
forall a. Text -> a -> Vendor a -> IO (RemotePtr a)
newRemotePtr Text
coupon (Text -> JSPtr
JSPtr Text
coupon) Vendor JSPtr
wJSObjects
        }

{-----------------------------------------------------------------------------
    Variable argument JavaScript functions
------------------------------------------------------------------------------}
-- | A JavaScript function with a given output type @a@.
data JSFunction a = JSFunction
    { JSFunction a -> IO JSCode
code          :: IO JSCode
      -- ^ Code snippet that implements the function.
    , 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 :: (a -> b) -> JSFunction a -> JSFunction b
fmap a -> b
f (JSFunction IO JSCode
c Window -> Value -> IO a
m) = IO JSCode -> (Window -> Value -> IO b) -> JSFunction b
forall a. IO JSCode -> (Window -> Value -> IO a) -> JSFunction a
JSFunction IO JSCode
c (\Window
w Value
v -> (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f (IO a -> IO b) -> IO a -> IO b
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 :: JSFunction a -> IO String
toCode = (JSCode -> String) -> IO JSCode -> IO String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap JSCode -> String
unJSCode (IO JSCode -> IO String)
-> (JSFunction a -> IO JSCode) -> JSFunction a -> IO String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JSFunction a -> IO JSCode
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 = ([JSCode] -> IO JSCode) -> b
forall a. FFI a => ([JSCode] -> IO JSCode) -> a
fancy (([JSCode] -> IO JSCode) -> b) -> ([JSCode] -> IO JSCode) -> b
forall a b. (a -> b) -> a -> b
$ \[JSCode]
xs -> do
        JSCode
x <- a -> IO JSCode
forall a. ToJS a => a -> IO JSCode
render a
a
        [JSCode] -> IO JSCode
f (JSCode
xJSCode -> [JSCode] -> [JSCode]
forall 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 :: forall a. IO JSCode -> (Window -> Value -> IO a) -> JSFunction a
JSFunction
        { code :: IO JSCode
code          = FromJS' b -> JSCode -> JSCode
forall a. FromJS' a -> JSCode -> JSCode
wrapCode FromJS' b
b (JSCode -> JSCode) -> IO JSCode -> IO JSCode
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [JSCode] -> IO JSCode
f []
        , marshalResult :: Window -> Value -> IO b
marshalResult = FromJS' b -> Window -> Value -> IO b
forall a. FromJS' a -> Window -> Value -> IO a
marshal FromJS' b
b
        }
        where b :: FromJS' b
b = FromJS' 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 :: String -> a
ffi String
macro = ([JSCode] -> IO JSCode) -> a
forall a. FFI a => ([JSCode] -> IO JSCode) -> a
fancy (JSCode -> IO JSCode
forall (m :: * -> *) a. Monad m => a -> m a
return (JSCode -> IO JSCode)
-> ([JSCode] -> JSCode) -> [JSCode] -> IO JSCode
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 = String -> String -> Int -> JSFunction String
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 = (a -> b) -> Int -> [JSCode]
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 <- FromJS' a -> Window -> Value -> IO a
forall a. FromJS' a -> Window -> Value -> IO a
marshal FromJS' a
forall a. FromJS a => FromJS' a
fromJS Window
w Value
a
        b -> Window -> [Value] -> IO ()
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' :: (a -> b) -> Int -> [JSCode]
convertArgs' a -> b
f Int
n = JSCode -> JSCode
wrap JSCode
arg JSCode -> [JSCode] -> [JSCode]
forall a. a -> [a] -> [a]
: b -> Int -> [JSCode]
forall a. IsHandler a => a -> Int -> [JSCode]
convertArgs (a -> b
f a
x) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
    where
    x :: a
x    = a
forall a. HasCallStack => a
undefined :: a
    wrap :: JSCode -> JSCode
wrap = FromJS' a -> JSCode -> JSCode
forall a. FromJS' a -> JSCode -> JSCode
wrapCode (FromJS' a
forall a. FromJS a => FromJS' a
fromJS :: FromJS' a)
    arg :: JSCode
arg  = String -> JSCode
JSCode (String -> JSCode) -> String -> JSCode
forall a b. (a -> b) -> a -> b
$ String
"arguments[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
n String -> ShowS
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 :: a -> String
convertArguments a
f =
    String
"[" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"," ((JSCode -> String) -> [JSCode] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map JSCode -> String
unJSCode ([JSCode] -> [String]) -> [JSCode] -> [String]
forall a b. (a -> b) -> a -> b
$ a -> Int -> [JSCode]
forall a. IsHandler a => a -> Int -> [JSCode]
convertArgs a
f Int
0) String -> ShowS
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 (String -> JSCode) -> String -> JSCode
forall a b. (a -> b) -> a -> b
$ ShowS
go String
code
    where
    at :: [b] -> Int -> b
at [b]
xs Int
i = b -> (b -> b) -> Maybe b -> b
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> b
forall a. HasCallStack => String -> a
error String
err) b -> b
forall a. a -> a
id (Maybe b -> b) -> Maybe b -> b
forall a b. (a -> b) -> a -> b
$ [b] -> Int -> Maybe 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 [JSCode] -> Int -> JSCode
forall b. [b] -> Int -> b
`at` Int
i)

    go :: ShowS
go []           = []
    go (Char
'%':Char
'%':String
cs) = Char
'%' Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
go String
cs
    go (Char
'%':Char
c  :String
cs) = Int -> String
argument Int
index String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
go String
cs
        where index :: Int
index = Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
'1'
    go (Char
c:String
cs)       = Char
c Char -> ShowS
forall a. a -> [a] -> [a]
: ShowS
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]