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

git.iko.soy/reflex-dom

on 05fe043 help sign in

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

621 lines 25 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.EventWriter

26import Reflex.Host.Class

27import Reflex.PerformEvent.Base

28import Reflex.PerformEvent.Class

29import Reflex.PostBuild.Base

30import Reflex.Requester.Base

32import Language.Haskell.TH

34#ifdef __GHCJS__

35import qualified GHCJS.Buffer as JS

36import GHCJS.DOM

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

38import qualified GHCJS.DOM.Types as JS

39import qualified GHCJS.Foreign as JS

40import qualified GHCJS.Foreign.Callback as JS

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

42import qualified GHCJS.Marshal as JS

43import qualified GHCJS.Marshal.Pure as JS

44import qualified GHCJS.Types as JS

45import qualified JavaScript.Array as JS

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

47import qualified JavaScript.Object as JS

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

49import qualified JavaScript.TypedArray.ArrayBuffer as JSArrayBuffer

51import Data.Hashable

52import Data.Word

53import Foreign.C.Types

54import Foreign.Ptr

55import Text.Encoding.Z

56#else

57import Foreign.Marshal

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

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

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

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

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

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

64import Graphics.UI.Gtk.WebKit.WebView

65import System.Glib.FFI

66#endif

68import Control.Concurrent

69import Control.Monad

70import Control.Monad.Exception

71import Control.Monad.Fix

72import Control.Monad.IO.Class

73import Control.Monad.Primitive

74import Control.Monad.Reader

75import Control.Monad.Ref

76import Control.Monad.State

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

78import Control.Monad.Trans.Control

79import Data.ByteString (ByteString)

80import qualified Data.ByteString as BS

81import Data.Coerce

82import Data.Monoid

83import Data.Text (Text)

84import qualified Data.Text as T

86class Monad m => HasWebView m where

87 type WebViewPhantom m :: *

88 askWebView :: m (WebViewSingleton (WebViewPhantom m))

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

91 type WebViewPhantom (ReaderT r m) = WebViewPhantom m

92 askWebView = lift askWebView

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

95 type WebViewPhantom (StateT r m) = WebViewPhantom m

96 askWebView = lift askWebView

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

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

100 askWebView = lift askWebView

101

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

103 type WebViewPhantom (PostBuildT t m) = WebViewPhantom m

104 askWebView = lift askWebView

105

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

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

108 askWebView = PerformEventT $ lift askWebView

109

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

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

112 askWebView = lift askWebView

113

114instance HasWebView m => HasWebView (EventWriterT t w m) where

115 type WebViewPhantom (EventWriterT t w m) = WebViewPhantom m

116 askWebView = lift askWebView

117

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

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

120 askWebView = lift askWebView

121

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

123

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

125 type PrimState (WithWebView x m) = PrimState m

126 primitive = lift . primitive

127

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

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

130 traverseDMapWithKeyWithAdjust f dm0 dm' = WithWebView $ traverseDMapWithKeyWithAdjust (\k v -> unWithWebView $ f k v) (coerce dm0) (coerceEvent dm')

131 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = WithWebView $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unWithWebView $ f k v) (coerce dm0) (coerceEvent dm')

132

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

134 {-# INLINABLE newEventWithTrigger #-}

135 newEventWithTrigger = lift . newEventWithTrigger

136 {-# INLINABLE newFanEventWithTrigger #-}

137 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

138

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

140 {-# INLINABLE subscribeEvent #-}

141 subscribeEvent = lift . subscribeEvent

142

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

144 type ReadPhase (WithWebView x m) = ReadPhase m

145 {-# INLINABLE fireEventsAndRead #-}

146 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a

147 {-# INLINABLE runHostFrame #-}

148 runHostFrame = lift . runHostFrame

149

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

151 {-# INLINABLE sample #-}

152 sample = lift . sample

153

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

155 {-# INLINABLE hold #-}

156 hold v0 = lift . hold v0

157 {-# INLINABLE holdDyn #-}

158 holdDyn v0 = lift . holdDyn v0

159 {-# INLINABLE holdIncremental #-}

160 holdIncremental v0 = lift . holdIncremental v0

161

162instance MonadTransControl (WithWebView x) where

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

164 {-# INLINABLE liftWith #-}

165 liftWith = defaultLiftWith WithWebView unWithWebView

166 {-# INLINABLE restoreT #-}

167 restoreT = defaultRestoreT WithWebView

168

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

170 type Performable (WithWebView x m) = WithWebView x (Performable m) --TODO: Can we eliminate this wrapper?

171 {-# INLINABLE performEvent_ #-}

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

173 {-# INLINABLE performEvent #-}

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

175

176instance ExhaustiblePerformEvent t m => ExhaustiblePerformEvent t (WithWebView x m) where

177 withPerformEventExhausted a = liftWith $ \run -> withPerformEventExhausted $ run a

178

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

180runWithWebView = runReaderT . unWithWebView

181

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

183 type WebViewPhantom (WithWebView x m) = x

184 askWebView = WithWebView ask

185

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

187 type Ref (WithWebView x m) = Ref m

188 newRef = lift . newRef

189 readRef = lift . readRef

190 writeRef r = lift . writeRef r

191

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

193 atomicModifyRef r = lift . atomicModifyRef r

194

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

196withWebViewSingleton wv f = f $ WebViewSingleton wv

197

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

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

200withWebViewSingletonMono wv f = f $ WebViewSingleton wv

201

202-- | 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

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

204

205#ifdef __GHCJS__

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

207newtype JSFFI = JSFFI JSFFI_Internal

208#else

209newtype JSFFI = JSFFI String

210#endif

211

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

213

214instance ToJS x (JSFun x) where

215 withJS (JSFun r) f = f r

216

217instance FromJS x (JSFun x) where

218 fromJS = return . JSFun

219

220class IsJSContext x where

221 data JSRef x

222

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

224 type JSM m :: * -> *

225 liftJS :: JSM m a -> m a

226

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

228 type JSM (ReaderT r m) = JSM m

229 liftJS = lift . liftJS

230

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

232 type JSM (PostBuildT t m) = JSM m

233 liftJS = lift . liftJS

234

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

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

237 liftJS = PerformEventT . lift . liftJS

238

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

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

241 liftJS = lift . liftJS

242

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

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

245 liftJS = lift . liftJS

246

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

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

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

250 forkJS :: m () -> m ThreadId

251 mkJSUndefined :: m (JSRef x)

252 isJSNull :: JSRef x -> m Bool

253 isJSUndefined :: JSRef x -> m Bool

254 fromJSBool :: JSRef x -> m Bool

255 fromJSString :: JSRef x -> m String

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

257 fromJSUint8Array :: JSRef x -> m ByteString

258 fromJSNumber :: JSRef x -> m Double

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

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

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

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

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

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

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

266 freeJSFun :: JSFun x -> m ()

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

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

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

270

271#ifdef __GHCJS__

272

273data JSCtx_IO

274

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

276 type JSM (WithWebView x m) = IO

277 liftJS = liftIO

278

279instance IsJSContext JSCtx_IO where

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

281

282instance MonadJS JSCtx_IO IO where

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

284 forkJS = forkIO

285 mkJSUndefined = return $ JSRef_IO JS.jsUndefined

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

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

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

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

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

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

292 fromJSNumber (JSRef_IO r) = do

293 Just n <- JS.fromJSVal r

294 return n

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

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

297 withJSNumber n f = do

298 r <- JS.toJSVal n

299 f $ JSRef_IO r

300 withJSArray l f = do

301 r <- JS.fromListIO $ coerce l

302 f $ JSRef_IO $ coerce r

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

304 ba <- extractByteArray cStr $ BS.length payload

305 f $ JSUint8Array $ JSRef_IO ba

306 mkJSFun f = do

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

308 l <- JS.toListIO $ coerce args

309 JSRef_IO result <- f $ coerce l

310 return result

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

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

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

314 getJSProp s (JSRef_IO o) = do

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

316 return $ JSRef_IO r

317 withJSNode n f = f $ JSRef_IO $ unNode n

318

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

320

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

322

323#else

324

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

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

327withJSStringRaw str a = do

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

329 a strRef

330

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

332fromJSNumberRaw val = do

333 jsContext <- askJSContext

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

335

336

337data JSCtx_JavaScriptCore x

338

339instance IsJSContext (JSCtx_JavaScriptCore x) where

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

341

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

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

344 liftJS a = do

345 wv <- askWebView

346 liftIO $ runWithWebView a wv

347

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

349

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

351runWithJSContext = runReaderT . unWithJSContext

352

353class Monad m => HasJSContext m where

354 askJSContext :: m JSContextRef

355

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

357 askJSContext = do

358 wv <- askWebView

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

360

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

362 askJSContext = WithJSContext ask

363

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

365lowerWithJSContext a = do

366 c <- askJSContext

367 liftIO $ runWithJSContext a c

368

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

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

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

372 -> m b

373liftWithWebViewThroughWithJSContext f a = do

374 wv <- askWebView

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

376

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

378 forkJS a = do

379 wv <- askWebView

380 liftIO $ forkIO $ runWithWebView a wv

381 mkJSFun a = do

382 wv <- askWebView

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

384 runJS expr args = lowerWithJSContext $ runJS expr args

385 mkJSUndefined = lowerWithJSContext mkJSUndefined

386 isJSNull = lowerWithJSContext . isJSNull

387 isJSUndefined = lowerWithJSContext . isJSUndefined

388 fromJSBool = lowerWithJSContext . fromJSBool

389 fromJSString = lowerWithJSContext . fromJSString

390 fromJSArray = lowerWithJSContext . fromJSArray

391 fromJSUint8Array = lowerWithJSContext . fromJSUint8Array

392 fromJSNumber = lowerWithJSContext . fromJSNumber

393 freeJSFun = lowerWithJSContext . freeJSFun

394 withJSBool = liftWithWebViewThroughWithJSContext . withJSBool

395 withJSString = liftWithWebViewThroughWithJSContext . withJSString

396 withJSNumber = liftWithWebViewThroughWithJSContext . withJSNumber

397 withJSArray = liftWithWebViewThroughWithJSContext . withJSArray

398 withJSUint8Array = liftWithWebViewThroughWithJSContext . withJSUint8Array

399 withJSNode = liftWithWebViewThroughWithJSContext . withJSNode

400 setJSProp propName valRef objRef = lowerWithJSContext $ setJSProp propName valRef objRef

401 getJSProp propName objRef = lowerWithJSContext $ getJSProp propName objRef

402

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

404 runJS (JSFFI body) args = do

405 jsContext <- askJSContext

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

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

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

409 forkJS a = do

410 c <- askJSContext

411 liftIO $ forkIO $ runWithJSContext a c

412 mkJSUndefined = do

413 jsContext <- askJSContext

414 fmap JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext

415 isJSNull (JSRef_JavaScriptCore r) = do

416 jsContext <- askJSContext

417 liftIO $ jsvalueisnull jsContext r

418 isJSUndefined (JSRef_JavaScriptCore r) = do

419 jsContext <- askJSContext

420 liftIO $ jsvalueisundefined jsContext r

421 fromJSBool (JSRef_JavaScriptCore r) = do

422 jsContext <- askJSContext

423 liftIO $ jsvaluetoboolean jsContext r

424 fromJSString (JSRef_JavaScriptCore r) = do

425 jsContext <- askJSContext

426 liftIO $ do

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

428 l <- jsstringgetmaximumutf8cstringsize s

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

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

431 peekCString ps

432 withJSBool b a = do

433 jsContext <- askJSContext

434 valRef <- liftIO $ jsvaluemakeboolean jsContext b

435 a $ JSRef_JavaScriptCore valRef

436 withJSString str a = do

437 jsContext <- askJSContext

438 withJSStringRaw str $ \strRef -> do

439 valRef <- liftIO $ jsvaluemakestring jsContext strRef

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

441 withJSNumber n a = do

442 jsContext <- askJSContext

443 valRef <- liftIO $ jsvaluemakenumber jsContext n

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

445 withJSArray elems a = do

446 jsContext <- askJSContext

447 let numElems = length elems

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

449 liftIO $ pokeArray elemsArr $ coerce elems

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

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

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

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

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

455 f $ JSUint8Array payloadRef

456 fromJSArray (JSRef_JavaScriptCore a) = do

457 jsContext <- askJSContext

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

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

460 lenDouble <- fromJSNumberRaw lenRef

461 let len = round lenDouble

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