module Foreign.JavaScript.Marshal (
ToJS(..), FromJS,
FFI, JSFunction, toCode, marshalResult, ffi,
IsHandler, convertArguments, handle,
NewJSObject, wrapImposeStablePtr,
) where
import Data.Aeson as JSON
#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
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
newtype JSCode = JSCode { unJSCode :: String }
deriving (Eq, Ord, Show)
class ToJS a where
render :: a -> IO JSCode
renderList :: [a] -> IO JSCode
renderList xs = do
ys <- mapM render xs
jsCode $ "[" ++ intercalate "," (map unJSCode ys) ++ "]"
jsCode = return . JSCode
instance ToJS Float where render = render . JSON.toJSON
instance ToJS Double where render = render . JSON.toJSON
instance ToJS Int where render = jsCode . show
instance ToJS Bool where render b = jsCode $ if b then "true" else "false"
instance ToJS JSON.Value where render = jsCode . showJSON
instance ToJS T.Text where render = render . JSON.String
instance ToJS Char where
render x = renderList [x]
renderList = render . JSON.String . T.pack
instance ToJS a => ToJS [a] where
render = renderList
instance ToJS HsEvent where
render x = render =<< unprotectedGetCoupon x
instance ToJS JSObject where
render x = apply1 "Haskell.deRefStablePtr(%1)"
<$> (render =<< unprotectedGetCoupon x)
showJSON :: ToJSON a => a -> String
showJSON
= Data.Text.Lazy.unpack
. Data.Text.Lazy.Builder.toLazyText
. JSON.encodeToTextBuilder . JSON.toJSON
data FromJS' a = FromJS'
{ wrapCode :: (JSCode -> JSCode)
, marshal :: Window -> JSON.Value -> IO a
}
class FromJS a where
fromJS :: FromJS' a
simple :: FromJSON a => (JSCode -> JSCode) -> FromJS' a
simple f =
FromJS' { wrapCode = f , marshal = \_ -> fromSuccessIO . JSON.fromJSON }
where
fromSuccessIO (JSON.Success a) = return a
instance FromJS String where fromJS = simple $ apply1 "%1.toString()"
instance FromJS T.Text where fromJS = simple $ apply1 "%1.toString()"
instance FromJS Int where fromJS = simple id
instance FromJS Double where fromJS = simple id
instance FromJS Float where fromJS = simple id
instance FromJS JSON.Value where fromJS = simple id
instance FromJS () where
fromJS = FromJS' { wrapCode = id, marshal = \_ _ -> return () }
instance FromJS JSObject where
fromJS = FromJS'
{ wrapCode = apply1 "Haskell.getStablePtr(%1)"
, marshal = \w v -> fromJSStablePtr v w
}
instance FromJS [JSObject] where
fromJS = FromJS'
{ wrapCode = apply1 "Haskell.map(Haskell.getStablePtr, %1)"
, marshal = \w (JSON.Array vs) -> do
mapM (\v -> fromJSStablePtr v w) (Vector.toList vs)
}
instance FromJS NewJSObject where
fromJS = FromJS' { wrapCode = id, marshal = \_ _ -> return NewJSObject }
wrapImposeStablePtr :: Window -> JSFunction NewJSObject -> IO (JSFunction JSObject)
wrapImposeStablePtr w@(Window{..}) f = do
coupon <- newCoupon wJSObjects
rcoupon <- render coupon
rcode <- code f
return $ JSFunction
{ code = return $ apply "Haskell.imposeStablePtr(%1,%2)" [rcode, rcoupon]
, marshalResult = \w _ -> newRemotePtr coupon (JSPtr coupon) wJSObjects
}
data JSFunction a = JSFunction
{ code :: IO JSCode
, marshalResult :: Window -> JSON.Value -> IO a
}
instance Functor JSFunction where
fmap f (JSFunction c m) = JSFunction c (\w v -> fmap f $ m w v)
toCode :: JSFunction a -> IO String
toCode = fmap unJSCode . code
class FFI a where
fancy :: ([JSCode] -> IO JSCode) -> a
instance (ToJS a, FFI b) => FFI (a -> b) where
fancy f a = fancy $ \xs -> do
x <- render a
f (x:xs)
instance FromJS b => FFI (JSFunction b) where
fancy f = JSFunction
{ code = wrapCode b <$> f []
, marshalResult = marshal b
}
where b = fromJS
ffi :: FFI a => String -> a
ffi macro = fancy (return . apply macro)
testFFI :: String -> Int -> JSFunction String
testFFI = ffi "$(%1).prop('checked',%2)"
class IsHandler a where
convertArgs :: a -> Int -> [JSCode]
handle :: a -> Window -> [JSON.Value] -> IO ()
instance (FromJS a, IsHandler b) => IsHandler (a -> b) where
convertArgs = convertArgs'
handle f = \w (a:as) -> do
x <- marshal fromJS w a
handle (f x) w as
convertArgs' :: forall a b. (FromJS a, IsHandler b) => (a -> b) -> Int -> [JSCode]
convertArgs' f n = wrap arg : convertArgs (f x) (n+1)
where
x = undefined :: a
wrap = wrapCode (fromJS :: FromJS' a)
arg = JSCode $ "arguments[" ++ show n ++ "]"
instance IsHandler (IO ()) where
convertArgs _ _ = []
handle m = \_ _ -> m
convertArguments :: IsHandler a => a -> String
convertArguments f =
"[" ++ intercalate "," (map unJSCode $ convertArgs f 0) ++ "]"
apply :: String -> [JSCode] -> JSCode
apply code args = JSCode $ go code
where
at xs i = maybe (error err) id $ atMay xs i
err = "Graphics.UI.Threepenny.FFI: Too few arguments in FFI call!"
argument i = unJSCode (args `at` i)
go [] = []
go ('%':'%':cs) = '%' : go cs
go ('%':c :cs) = argument index ++ go cs
where index = fromEnum c fromEnum '1'
go (c:cs) = c : go cs
apply1 :: String -> JSCode -> JSCode
apply1 s x = apply s [x]