module Graphics.UI.Threepenny.Internal.FFI (
ffi,
FFI(..), ToJS(..),
JSFunction, HsFunction,
showJSON,
toCode, marshalResult,
) where
import Data.Aeson as JSON
import qualified Data.Aeson.Types as JSON
import qualified Data.Aeson.Encode
import Data.ByteString (ByteString)
import Data.Data
import Data.Functor
import Data.Maybe
import Data.String (fromString)
import Data.Text (Text)
import qualified Data.Text.Lazy
import qualified Data.Text.Lazy.Builder
import Safe (atMay)
import Graphics.UI.Threepenny.Internal.Types
showJSON :: ToJSON a => a -> String
showJSON
= Data.Text.Lazy.unpack
. Data.Text.Lazy.Builder.toLazyText
. Data.Aeson.Encode.fromValue . JSON.toJSON
newtype JSCode = JSCode { unJSCode :: String }
deriving (Eq, Ord, Show, Data, Typeable)
class ToJS a where
render :: a -> JSCode
instance ToJS String where render = render . JSON.String . fromString
instance ToJS Text where render = render . JSON.String
instance ToJS Float where render = JSCode . showJSON
instance ToJS Double where render = JSCode . showJSON
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 ByteString where render = JSCode . show
instance ToJS ElementId where
render (ElementId x) = apply "elidToElement(%1)" [render x]
instance ToJS Element where render = render . unprotectedGetElementId
instance ToJS (HsFunction (IO ())) where
render (HsFunction (ElementId elid) name) =
apply "callback(%1,%2)" [render elid, render name]
data JSFunction a = JSFunction
{ code :: JSCode
, marshal :: Window -> JSON.Value -> JSON.Parser a
}
toCode :: JSFunction a -> String
toCode = unJSCode . code
marshalResult
:: JSFunction a
-> Window
-> JSON.Value
-> JSON.Result a
marshalResult fun w = JSON.parse (marshal fun w)
instance Functor JSFunction where
fmap f = fmapWindow (const f)
fmapWindow :: (Window -> a -> b) -> JSFunction a -> JSFunction b
fmapWindow f (JSFunction c m) = JSFunction c (\w v -> f w <$> m w v)
fromJSCode :: JSCode -> JSFunction ()
fromJSCode c = JSFunction { code = c, marshal = \_ _ -> return () }
class FFI a where
fancy :: ([JSCode] -> JSCode) -> a
instance (ToJS a, FFI b) => FFI (a -> b) where
fancy f a = fancy $ f . (render a:)
instance FFI (JSFunction ()) where fancy f = fromJSCode $ f []
instance FFI (JSFunction String) where fancy = mkResult "%1.toString()"
instance FFI (JSFunction Text) where fancy = mkResult "%1.toString()"
instance FFI (JSFunction JSON.Value) where fancy = mkResult "%1"
instance FFI (JSFunction Int) where fancy = mkResult "%1"
instance FFI (JSFunction Double) where fancy = mkResult "%1"
instance FFI (JSFunction Float) where fancy = mkResult "%1"
instance FFI (JSFunction [ElementId]) where fancy = mkResult "elementsToElids(%1)"
mkResult :: FromJSON a => String -> ([JSCode] -> JSCode) -> JSFunction a
mkResult client f = JSFunction
{ code = apply client [f []]
, marshal = \w -> parseJSON
}
ffi :: FFI a => String -> a
ffi macro = fancy (apply macro)
testFFI :: String -> Int -> JSFunction String
testFFI = ffi "$(%1).prop('checked',%2)"
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 ('%':c:cs) = argument index ++ go cs
where index = fromEnum c fromEnum '1'
go (c:cs) = c : go cs