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

git.iko.soy/reflex-dom

on 776e2fa help sign in

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

618 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.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)

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

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

177runWithWebView = runReaderT . unWithWebView

178

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

180 type WebViewPhantom (WithWebView x m) = x

181 askWebView = WithWebView ask

182

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

184 type Ref (WithWebView x m) = Ref m

185 newRef = lift . newRef

186 readRef = lift . readRef

187 writeRef r = lift . writeRef r

188

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

190 atomicModifyRef r = lift . atomicModifyRef r

191

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

193withWebViewSingleton wv f = f $ WebViewSingleton wv

194

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

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

197withWebViewSingletonMono wv f = f $ WebViewSingleton wv

198

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

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

201

202#ifdef __GHCJS__

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

204newtype JSFFI = JSFFI JSFFI_Internal

205#else

206newtype JSFFI = JSFFI String

207#endif

208

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

210

211instance ToJS x (JSFun x) where

212 withJS (JSFun r) f = f r

213

214instance FromJS x (JSFun x) where

215 fromJS = return . JSFun

216

217class IsJSContext x where

218 data JSRef x

219

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

221 type JSM m :: * -> *

222 liftJS :: JSM m a -> m a

223

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

225 type JSM (ReaderT r m) = JSM m

226 liftJS = lift . liftJS

227

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

229 type JSM (PostBuildT t m) = JSM m

230 liftJS = lift . liftJS

231

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

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

234 liftJS = PerformEventT . lift . liftJS

235

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

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

238 liftJS = lift . liftJS

239

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

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

242 liftJS = lift . liftJS

243

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

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

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

247 forkJS :: m () -> m ThreadId

248 mkJSUndefined :: m (JSRef x)

249 isJSNull :: JSRef x -> m Bool

250 isJSUndefined :: JSRef x -> m Bool

251 fromJSBool :: JSRef x -> m Bool

252 fromJSString :: JSRef x -> m String

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

254 fromJSUint8Array :: JSRef x -> m ByteString

255 fromJSNumber :: JSRef x -> m Double

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

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

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

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

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

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

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

263 freeJSFun :: JSFun x -> m ()

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

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

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

267

268#ifdef __GHCJS__

269

270data JSCtx_IO

271

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

273 type JSM (WithWebView x m) = IO

274 liftJS = liftIO

275

276instance IsJSContext JSCtx_IO where

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

278

279instance MonadJS JSCtx_IO IO where

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

281 forkJS = forkIO

282 mkJSUndefined = return $ JSRef_IO JS.jsUndefined

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

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

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

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

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

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

289 fromJSNumber (JSRef_IO r) = do

290 Just n <- JS.fromJSVal r

291 return n

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

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

294 withJSNumber n f = do

295 r <- JS.toJSVal n

296 f $ JSRef_IO r

297 withJSArray l f = do

298 r <- JS.fromListIO $ coerce l

299 f $ JSRef_IO $ coerce r

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

301 ba <- extractByteArray cStr $ BS.length payload

302 f $ JSUint8Array $ JSRef_IO ba

303 mkJSFun f = do

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

305 l <- JS.toListIO $ coerce args

306 JSRef_IO result <- f $ coerce l

307 return result

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

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

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

311 getJSProp s (JSRef_IO o) = do

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

313 return $ JSRef_IO r

314 withJSNode n f = f $ JSRef_IO $ unNode n

315

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

317

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

319

320#else

321

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

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

324withJSStringRaw str a = do

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

326 a strRef

327

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

329fromJSNumberRaw val = do

330 jsContext <- askJSContext

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

332

333

334data JSCtx_JavaScriptCore x

335

336instance IsJSContext (JSCtx_JavaScriptCore x) where

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

338

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

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

341 liftJS a = do

342 wv <- askWebView

343 liftIO $ runWithWebView a wv

344

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

346

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

348runWithJSContext = runReaderT . unWithJSContext

349

350class Monad m => HasJSContext m where

351 askJSContext :: m JSContextRef

352

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

354 askJSContext = do

355 wv <- askWebView

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

357

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

359 askJSContext = WithJSContext ask

360

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

362lowerWithJSContext a = do

363 c <- askJSContext

364 liftIO $ runWithJSContext a c

365

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

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

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

369 -> m b

370liftWithWebViewThroughWithJSContext f a = do

371 wv <- askWebView

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

373

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

375 forkJS a = do

376 wv <- askWebView

377 liftIO $ forkIO $ runWithWebView a wv

378 mkJSFun a = do

379 wv <- askWebView

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

381 runJS expr args = lowerWithJSContext $ runJS expr args

382 mkJSUndefined = lowerWithJSContext mkJSUndefined

383 isJSNull = lowerWithJSContext . isJSNull

384 isJSUndefined = lowerWithJSContext . isJSUndefined

385 fromJSBool = lowerWithJSContext . fromJSBool

386 fromJSString = lowerWithJSContext . fromJSString

387 fromJSArray = lowerWithJSContext . fromJSArray

388 fromJSUint8Array = lowerWithJSContext . fromJSUint8Array

389 fromJSNumber = lowerWithJSContext . fromJSNumber

390 freeJSFun = lowerWithJSContext . freeJSFun

391 withJSBool = liftWithWebViewThroughWithJSContext . withJSBool

392 withJSString = liftWithWebViewThroughWithJSContext . withJSString

393 withJSNumber = liftWithWebViewThroughWithJSContext . withJSNumber

394 withJSArray = liftWithWebViewThroughWithJSContext . withJSArray

395 withJSUint8Array = liftWithWebViewThroughWithJSContext . withJSUint8Array

396 withJSNode = liftWithWebViewThroughWithJSContext . withJSNode

397 setJSProp propName valRef objRef = lowerWithJSContext $ setJSProp propName valRef objRef

398 getJSProp propName objRef = lowerWithJSContext $ getJSProp propName objRef

399

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

401 runJS (JSFFI body) args = do

402 jsContext <- askJSContext

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

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

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

406 forkJS a = do

407 c <- askJSContext

408 liftIO $ forkIO $ runWithJSContext a c

409 mkJSUndefined = do

410 jsContext <- askJSContext

411 fmap JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext

412 isJSNull (JSRef_JavaScriptCore r) = do

413 jsContext <- askJSContext

414 liftIO $ jsvalueisnull jsContext r

415 isJSUndefined (JSRef_JavaScriptCore r) = do

416 jsContext <- askJSContext

417 liftIO $ jsvalueisundefined jsContext r

418 fromJSBool (JSRef_JavaScriptCore r) = do

419 jsContext <- askJSContext

420 liftIO $ jsvaluetoboolean jsContext r

421 fromJSString (JSRef_JavaScriptCore r) = do

422 jsContext <- askJSContext

423 liftIO $ do

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

425 l <- jsstringgetmaximumutf8cstringsize s

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

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

428 peekCString ps

429 withJSBool b a = do

430 jsContext <- askJSContext

431 valRef <- liftIO $ jsvaluemakeboolean jsContext b

432 a $ JSRef_JavaScriptCore valRef

433 withJSString str a = do

434 jsContext <- askJSContext

435 withJSStringRaw str $ \strRef -> do

436 valRef <- liftIO $ jsvaluemakestring jsContext strRef

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

438 withJSNumber n a = do

439 jsContext <- askJSContext

440 valRef <- liftIO $ jsvaluemakenumber jsContext n

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

442 withJSArray elems a = do

443 jsContext <- askJSContext

444 let numElems = length elems

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

446 liftIO $ pokeArray elemsArr $ coerce elems

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

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

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

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

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

452 f $ JSUint8Array payloadRef

453 fromJSArray (JSRef_JavaScriptCore a) = do

454 jsContext <- askJSContext

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

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

457 lenDouble <- fromJSNumberRaw lenRef

458 let len = round lenDouble

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