src/Foreign/JavaScript/TH.hs · reflex-dom

git.iko.soy/reflex-dom

on a006cf0 help sign in

reflex-dom/src/Foreign/JavaScript/TH.hs

612 lines 24 kB history raw

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE EmptyDataDecls #-}

3{-# LANGUAGE ExistentialQuantification #-}

4{-# LANGUAGE FlexibleContexts #-}

5{-# LANGUAGE FlexibleInstances #-}

6{-# LANGUAGE ForeignFunctionInterface #-}

7{-# LANGUAGE FunctionalDependencies #-}

8{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9{-# LANGUAGE MultiParamTypeClasses #-}

10{-# LANGUAGE RankNTypes #-}

11{-# LANGUAGE StandaloneDeriving #-}

12{-# LANGUAGE TemplateHaskell #-}

13{-# LANGUAGE TypeFamilies #-}

14{-# LANGUAGE TypeSynonymInstances #-}

15{-# LANGUAGE UndecidableInstances #-}

16#ifdef __GHCJS__

17{-# LANGUAGE JavaScriptFFI #-}

18#endif

19module Foreign.JavaScript.TH ( module Foreign.JavaScript.TH

20 , Safety (..)

21 ) where

23import Reflex.Class

24import Reflex.DynamicWriter

25import Reflex.Host.Class

26import Reflex.PerformEvent.Base

27import Reflex.PerformEvent.Class

28import Reflex.PostBuild.Base

29import Reflex.Requester.Base

31import Language.Haskell.TH

33#ifdef __GHCJS__

34import qualified GHCJS.Buffer as JS

35import GHCJS.DOM

36import GHCJS.DOM.Types hiding (Text, fromJSString)

37import qualified GHCJS.DOM.Types as JS

38import qualified GHCJS.Foreign as JS

39import qualified GHCJS.Foreign.Callback as JS

40import qualified GHCJS.Foreign.Callback.Internal (Callback (..))

41import qualified GHCJS.Marshal as JS

42import qualified GHCJS.Marshal.Pure as JS

43import qualified GHCJS.Types as JS

44import qualified JavaScript.Array as JS

45import qualified JavaScript.Array.Internal (SomeJSArray (..))

46import qualified JavaScript.Object as JS

47import qualified JavaScript.Object.Internal (Object (..))

48import qualified JavaScript.TypedArray.ArrayBuffer as JSArrayBuffer

50import Data.Hashable

51import Data.Word

52import Foreign.C.Types

53import Foreign.Ptr

54import Text.Encoding.Z

55#else

56import Foreign.Marshal

57import Graphics.UI.Gtk.WebKit.DOM.Node

58import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

59import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef

60import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

61import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

62import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

63import Graphics.UI.Gtk.WebKit.WebView

64import System.Glib.FFI

65#endif

67import Control.Concurrent

68import Control.Monad

69import Control.Monad.Exception

70import Control.Monad.Fix

71import Control.Monad.IO.Class

72import Control.Monad.Primitive

73import Control.Monad.Reader

74import Control.Monad.Ref

75import Control.Monad.State

76import qualified Control.Monad.State.Strict as Strict

77import Control.Monad.Trans.Control

78import Data.ByteString (ByteString)

79import qualified Data.ByteString as BS

80import Data.Coerce

81import Data.Monoid

82import Data.Text (Text)

83import qualified Data.Text as T

85class Monad m => HasWebView m where

86 type WebViewPhantom m :: *

87 askWebView :: m (WebViewSingleton (WebViewPhantom m))

89instance HasWebView m => HasWebView (ReaderT r m) where

90 type WebViewPhantom (ReaderT r m) = WebViewPhantom m

91 askWebView = lift askWebView

93instance HasWebView m => HasWebView (StateT r m) where

94 type WebViewPhantom (StateT r m) = WebViewPhantom m

95 askWebView = lift askWebView

97instance HasWebView m => HasWebView (Strict.StateT r m) where

98 type WebViewPhantom (Strict.StateT r m) = WebViewPhantom m

99 askWebView = lift askWebView

100

101instance HasWebView m => HasWebView (PostBuildT t m) where

102 type WebViewPhantom (PostBuildT t m) = WebViewPhantom m

103 askWebView = lift askWebView

104

105instance (ReflexHost t, HasWebView (HostFrame t)) => HasWebView (PerformEventT t m) where

106 type WebViewPhantom (PerformEventT t m) = WebViewPhantom (HostFrame t)

107 askWebView = PerformEventT $ lift askWebView

108

109instance HasWebView m => HasWebView (DynamicWriterT t w m) where

110 type WebViewPhantom (DynamicWriterT t w m) = WebViewPhantom m

111 askWebView = lift askWebView

112

113instance HasWebView m => HasWebView (RequesterT t request response m) where

114 type WebViewPhantom (RequesterT t request response m) = WebViewPhantom m

115 askWebView = lift askWebView

116

117newtype WithWebView x m a = WithWebView { unWithWebView :: ReaderT (WebViewSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)

118

119instance PrimMonad m => PrimMonad (WithWebView x m) where

120 type PrimState (WithWebView x m) = PrimState m

121 primitive = lift . primitive

122

123instance MonadAdjust t m => MonadAdjust t (WithWebView x m) where

124 runWithReplace a0 a' = WithWebView $ runWithReplace (coerce a0) (coerceEvent a')

125 sequenceDMapWithAdjust dm0 dm' = WithWebView $ sequenceDMapWithAdjust (coerce dm0) (coerceEvent dm')

126

127instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView x m) where

128 {-# INLINABLE newEventWithTrigger #-}

129 newEventWithTrigger = lift . newEventWithTrigger

130 {-# INLINABLE newFanEventWithTrigger #-}

131 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

132

133instance MonadSubscribeEvent t m => MonadSubscribeEvent t (WithWebView x m) where

134 {-# INLINABLE subscribeEvent #-}

135 subscribeEvent = lift . subscribeEvent

136

137instance MonadReflexHost t m => MonadReflexHost t (WithWebView x m) where

138 type ReadPhase (WithWebView x m) = ReadPhase m

139 {-# INLINABLE fireEventsAndRead #-}

140 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a

141 {-# INLINABLE runHostFrame #-}

142 runHostFrame = lift . runHostFrame

143

144instance MonadSample t m => MonadSample t (WithWebView x m) where

145 {-# INLINABLE sample #-}

146 sample = lift . sample

147

148instance MonadHold t m => MonadHold t (WithWebView x m) where

149 {-# INLINABLE hold #-}

150 hold v0 = lift . hold v0

151 {-# INLINABLE holdDyn #-}

152 holdDyn v0 = lift . holdDyn v0

153 {-# INLINABLE holdIncremental #-}

154 holdIncremental v0 = lift . holdIncremental v0

155

156instance MonadTransControl (WithWebView x) where

157 type StT (WithWebView x) a = StT (ReaderT (WebViewSingleton x)) a

158 {-# INLINABLE liftWith #-}

159 liftWith = defaultLiftWith WithWebView unWithWebView

160 {-# INLINABLE restoreT #-}

161 restoreT = defaultRestoreT WithWebView

162

163instance PerformEvent t m => PerformEvent t (WithWebView x m) where

164 type Performable (WithWebView x m) = WithWebView x (Performable m)

165 {-# INLINABLE performEvent_ #-}

166 performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e

167 {-# INLINABLE performEvent #-}

168 performEvent e = liftWith $ \run -> performEvent $ fmap run e

169

170runWithWebView :: WithWebView x m a -> WebViewSingleton x -> m a

171runWithWebView = runReaderT . unWithWebView

172

173instance (Monad m) => HasWebView (WithWebView x m) where

174 type WebViewPhantom (WithWebView x m) = x

175 askWebView = WithWebView ask

176

177instance MonadRef m => MonadRef (WithWebView x m) where

178 type Ref (WithWebView x m) = Ref m

179 newRef = lift . newRef

180 readRef = lift . readRef

181 writeRef r = lift . writeRef r

182

183instance MonadAtomicRef m => MonadAtomicRef (WithWebView x m) where

184 atomicModifyRef r = lift . atomicModifyRef r

185

186withWebViewSingleton :: WebView -> (forall x. WebViewSingleton x -> r) -> r

187withWebViewSingleton wv f = f $ WebViewSingleton wv

188

189-- | Warning: `withWebViewSingletonMono` does not provide the same guarantees that `withWebViewSingleton` does.

190withWebViewSingletonMono :: WebView -> (WebViewSingleton () -> r) -> r

191withWebViewSingletonMono wv f = f $ WebViewSingleton wv

192

193-- | A singleton type for a given WebView; we use this to statically guarantee that different WebViews (and thus different javscript contexts) don't get mixed up

194newtype WebViewSingleton x = WebViewSingleton { unWebViewSingleton :: WebView }

195

196#ifdef __GHCJS__

197type JSFFI_Internal = JS.MutableJSArray -> IO JS.JSVal

198newtype JSFFI = JSFFI JSFFI_Internal

199#else

200newtype JSFFI = JSFFI String

201#endif

202

203newtype JSFun x = JSFun { unJSFun :: JSRef x }

204

205instance ToJS x (JSFun x) where

206 withJS (JSFun r) f = f r

207

208instance FromJS x (JSFun x) where

209 fromJS = return . JSFun

210

211class IsJSContext x where

212 data JSRef x

213

214class (Monad m, MonadIO (JSM m), MonadFix (JSM m), MonadJS x (JSM m)) => HasJS x m | m -> x where

215 type JSM m :: * -> *

216 liftJS :: JSM m a -> m a

217

218instance HasJS x m => HasJS x (ReaderT r m) where

219 type JSM (ReaderT r m) = JSM m

220 liftJS = lift . liftJS

221

222instance (HasJS x m, ReflexHost t) => HasJS x (PostBuildT t m) where

223 type JSM (PostBuildT t m) = JSM m

224 liftJS = lift . liftJS

225

226instance (HasJS x (HostFrame t), ReflexHost t) => HasJS x (PerformEventT t m) where

227 type JSM (PerformEventT t m) = JSM (HostFrame t)

228 liftJS = PerformEventT . lift . liftJS

229

230instance HasJS x m => HasJS x (DynamicWriterT t w m) where

231 type JSM (DynamicWriterT t w m) = JSM m

232 liftJS = lift . liftJS

233

234instance HasJS x m => HasJS x (RequesterT t request response m) where

235 type JSM (RequesterT t request response m) = JSM m

236 liftJS = lift . liftJS

237

238-- | A Monad that is capable of executing JavaScript

239class Monad m => MonadJS x m | m -> x where

240 runJS :: JSFFI -> [JSRef x] -> m (JSRef x)

241 forkJS :: m () -> m ThreadId

242 mkJSUndefined :: m (JSRef x)

243 isJSNull :: JSRef x -> m Bool

244 isJSUndefined :: JSRef x -> m Bool

245 fromJSBool :: JSRef x -> m Bool

246 fromJSString :: JSRef x -> m String

247 fromJSArray :: JSRef x -> m [JSRef x]

248 fromJSUint8Array :: JSRef x -> m ByteString

249 fromJSNumber :: JSRef x -> m Double

250 withJSBool :: Bool -> (JSRef x -> m r) -> m r

251 withJSString :: String -> (JSRef x -> m r) -> m r

252 withJSNumber :: Double -> (JSRef x -> m r) -> m r

253 withJSArray :: [JSRef x] -> (JSRef x -> m r) -> m r

254 withJSUint8Array :: ByteString -> (JSUint8Array x -> m r) -> m r

255 -- | Create a JSFun with zero arguments; should be equilvant to `syncCallback AlwaysRetain True` in GHCJS

256 mkJSFun :: ([JSRef x] -> m (JSRef x)) -> m (JSFun x) --TODO: Support 'this', exceptions

257 freeJSFun :: JSFun x -> m ()

258 setJSProp :: String -> JSRef x -> JSRef x -> m ()

259 getJSProp :: String -> JSRef x -> m (JSRef x)

260 withJSNode :: Node -> (JSRef x -> m r) -> m r

261

262#ifdef __GHCJS__

263

264data JSCtx_IO

265

266instance MonadIO m => HasJS JSCtx_IO (WithWebView x m) where

267 type JSM (WithWebView x m) = IO

268 liftJS = liftIO

269

270instance IsJSContext JSCtx_IO where

271 newtype JSRef JSCtx_IO = JSRef_IO { unJSRef_IO :: JS.JSVal }

272

273instance MonadJS JSCtx_IO IO where

274 runJS (JSFFI f) l = fmap JSRef_IO . f =<< JS.fromListIO (coerce l)

275 forkJS = forkIO

276 mkJSUndefined = return $ JSRef_IO JS.jsUndefined

277 isJSNull (JSRef_IO r) = return $ JS.isNull r

278 isJSUndefined (JSRef_IO r) = return $ JS.isUndefined r

279 fromJSBool (JSRef_IO r) = return $ JS.fromJSBool r

280 fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.pFromJSVal r

281 fromJSArray (JSRef_IO r) = fmap coerce $ JS.toListIO $ coerce r

282 fromJSUint8Array (JSRef_IO r) = fmap (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JSArrayBuffer.unsafeFreeze $ JS.pFromJSVal r --TODO: Assert that this is immutable

283 fromJSNumber (JSRef_IO r) = do

284 Just n <- JS.fromJSVal r

285 return n

286 withJSBool b f = f $ JSRef_IO $ JS.toJSBool b

287 withJSString s f = f $ JSRef_IO $ JS.pToJSVal $ JS.toJSString s

288 withJSNumber n f = do

289 r <- JS.toJSVal n

290 f $ JSRef_IO r

291 withJSArray l f = do

292 r <- JS.fromListIO $ coerce l

293 f $ JSRef_IO $ coerce r

294 withJSUint8Array payload f = BS.useAsCString payload $ \cStr -> do

295 ba <- extractByteArray cStr $ BS.length payload

296 f $ JSUint8Array $ JSRef_IO ba

297 mkJSFun f = do

298 cb <- JS.syncCallback1' $ \args -> do

299 l <- JS.toListIO $ coerce args

300 JSRef_IO result <- f $ coerce l

301 return result

302 fmap (JSFun . JSRef_IO) $ funWithArguments $ coerce cb

303 freeJSFun (JSFun (JSRef_IO r)) = JS.releaseCallback $ coerce r

304 setJSProp s (JSRef_IO v) (JSRef_IO o) = JS.setProp (JS.toJSString s) v $ coerce o

305 getJSProp s (JSRef_IO o) = do

306 r <- JS.getProp (JS.toJSString s) $ coerce o

307 return $ JSRef_IO r

308 withJSNode n f = f $ JSRef_IO $ unNode n

309

310foreign import javascript unsafe "new Uint8Array($1_1.buf, $1_2, $2)" extractByteArray :: Ptr CChar -> Int -> IO JS.JSVal

311

312foreign import javascript unsafe "function(){ return $1(arguments); }" funWithArguments :: JS.Callback (JS.MutableJSArray -> IO a) -> IO JS.JSVal

313

314#else

315

316-- | Make a JS string available that is not wrapped up as a JSValueRef

317withJSStringRaw :: MonadAsyncException m => String -> (JSStringRef -> m r) -> m r

318withJSStringRaw str a = do

319 bracket (liftIO $ jsstringcreatewithutf8cstring str) (liftIO . jsstringrelease) $ \strRef -> do

320 a strRef

321

322fromJSNumberRaw :: (MonadIO m, HasJSContext m) => JSValueRef -> m Double

323fromJSNumberRaw val = do

324 jsContext <- askJSContext

325 liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions

326

327

328data JSCtx_JavaScriptCore x

329

330instance IsJSContext (JSCtx_JavaScriptCore x) where

331 newtype JSRef (JSCtx_JavaScriptCore x) = JSRef_JavaScriptCore { unJSRef_JavaScriptCore :: JSValueRef }

332

333instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithWebView x m) where

334 type JSM (WithWebView x m) = WithWebView x IO

335 liftJS a = do

336 wv <- askWebView

337 liftIO $ runWithWebView a wv

338

339newtype WithJSContext x m a = WithJSContext { unWithJSContext :: ReaderT JSContextRef m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)

340

341runWithJSContext :: WithJSContext x m a -> JSContextRef -> m a

342runWithJSContext = runReaderT . unWithJSContext

343

344class Monad m => HasJSContext m where

345 askJSContext :: m JSContextRef

346

347instance MonadIO m => HasJSContext (WithWebView x m) where

348 askJSContext = do

349 wv <- askWebView

350 liftIO $ webFrameGetGlobalContext =<< webViewGetMainFrame (unWebViewSingleton wv)

351

352instance Monad m => HasJSContext (WithJSContext x m) where

353 askJSContext = WithJSContext ask

354

355lowerWithJSContext :: (HasJSContext m, MonadIO m) => WithJSContext x IO a -> m a

356lowerWithJSContext a = do

357 c <- askJSContext

358 liftIO $ runWithJSContext a c

359

360liftWithWebViewThroughWithJSContext :: (HasJSContext m, HasWebView m, MonadIO m, MonadTrans t, Monad m1)

361 => ((t1 -> t m1 a) -> WithJSContext x IO b)

362 -> (t1 -> WithWebView (WebViewPhantom m) m1 a)

363 -> m b

364liftWithWebViewThroughWithJSContext f a = do

365 wv <- askWebView

366 lowerWithJSContext $ f $ \b' -> lift $ runWithWebView (a b') wv

367

368instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where

369 forkJS a = do

370 wv <- askWebView

371 liftIO $ forkIO $ runWithWebView a wv

372 mkJSFun a = do

373 wv <- askWebView

374 lowerWithJSContext $ mkJSFun $ \args -> lift $ runWithWebView (a args) wv

375 runJS expr args = lowerWithJSContext $ runJS expr args

376 mkJSUndefined = lowerWithJSContext mkJSUndefined

377 isJSNull = lowerWithJSContext . isJSNull

378 isJSUndefined = lowerWithJSContext . isJSUndefined

379 fromJSBool = lowerWithJSContext . fromJSBool

380 fromJSString = lowerWithJSContext . fromJSString

381 fromJSArray = lowerWithJSContext . fromJSArray

382 fromJSUint8Array = lowerWithJSContext . fromJSUint8Array

383 fromJSNumber = lowerWithJSContext . fromJSNumber

384 freeJSFun = lowerWithJSContext . freeJSFun

385 withJSBool = liftWithWebViewThroughWithJSContext . withJSBool

386 withJSString = liftWithWebViewThroughWithJSContext . withJSString

387 withJSNumber = liftWithWebViewThroughWithJSContext . withJSNumber

388 withJSArray = liftWithWebViewThroughWithJSContext . withJSArray

389 withJSUint8Array = liftWithWebViewThroughWithJSContext . withJSUint8Array

390 withJSNode = liftWithWebViewThroughWithJSContext . withJSNode

391 setJSProp propName valRef objRef = lowerWithJSContext $ setJSProp propName valRef objRef

392 getJSProp propName objRef = lowerWithJSContext $ getJSProp propName objRef

393

394instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContext x IO) where

395 runJS (JSFFI body) args = do

396 jsContext <- askJSContext

397 withJSArray args $ \(JSRef_JavaScriptCore this) -> liftIO $ do

398 result <- bracket (jsstringcreatewithutf8cstring body) jsstringrelease $ \script -> jsevaluatescript jsContext script this nullPtr 1 nullPtr

399 return $ JSRef_JavaScriptCore result --TODO: Protect and unprotect result

400 forkJS a = do

401 c <- askJSContext

402 liftIO $ forkIO $ runWithJSContext a c

403 mkJSUndefined = do

404 jsContext <- askJSContext

405 fmap JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext

406 isJSNull (JSRef_JavaScriptCore r) = do

407 jsContext <- askJSContext

408 liftIO $ jsvalueisnull jsContext r

409 isJSUndefined (JSRef_JavaScriptCore r) = do

410 jsContext <- askJSContext

411 liftIO $ jsvalueisundefined jsContext r

412 fromJSBool (JSRef_JavaScriptCore r) = do

413 jsContext <- askJSContext

414 liftIO $ jsvaluetoboolean jsContext r

415 fromJSString (JSRef_JavaScriptCore r) = do

416 jsContext <- askJSContext

417 liftIO $ do

418 s <- jsvaluetostringcopy jsContext r nullPtr --TODO: Deal with exceptions

419 l <- jsstringgetmaximumutf8cstringsize s

420 allocaBytes (fromIntegral l) $ \ps -> do

421 _ <- jsstringgetutf8cstring'_ s ps (fromIntegral l)

422 peekCString ps

423 withJSBool b a = do

424 jsContext <- askJSContext

425 valRef <- liftIO $ jsvaluemakeboolean jsContext b

426 a $ JSRef_JavaScriptCore valRef

427 withJSString str a = do

428 jsContext <- askJSContext

429 withJSStringRaw str $ \strRef -> do

430 valRef <- liftIO $ jsvaluemakestring jsContext strRef

431 a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef

432 withJSNumber n a = do

433 jsContext <- askJSContext

434 valRef <- liftIO $ jsvaluemakenumber jsContext n

435 a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef

436 withJSArray elems a = do

437 jsContext <- askJSContext

438 let numElems = length elems

439 bracket (liftIO $ mallocArray numElems) (liftIO . free) $ \elemsArr -> do

440 liftIO $ pokeArray elemsArr $ coerce elems

441 bracket (liftIO $ jsobjectmakearray jsContext (fromIntegral numElems) elemsArr nullPtr) (const $ return ()) $ \arrRef -> do --TODO: Do we need to protect/unprotect the array object?

442 a $ JSRef_JavaScriptCore arrRef --TODO: Protect/unprotect valRef

443 --TODO: When supported by webkitgtk3-javascriptcore, go directly from C string to Uint8Array without creating each item individually

444 withJSUint8Array payload f = withJSArrayFromList (BS.unpack payload) $ \x -> do

445 payloadRef <- runJS (JSFFI "new Uint8Array(this[0])") [x]

446 f $ JSUint8Array payloadRef

447 fromJSArray (JSRef_JavaScriptCore a) = do

448 jsContext <- askJSContext

449 lenRef <- withJSStringRaw "length" $ \lengthStr -> do

450 liftIO $ jsobjectgetproperty jsContext a lengthStr nullPtr --TODO: Exceptions

451 lenDouble <- fromJSNumberRaw lenRef

452 let len = round lenDouble

453 liftIO $ forM [0..len-1] $ \i -> do