44f2bb4 · reflex-dom · git.iko.soy

git.iko.soy/reflex-dom

Merge branch 'ghcjs-dom-update' of https://github.com/hamishmack/reflex-dom into hamishmack-ghcjs-dom-update

commit44f2bb4544dd3aa4393d0ea0d21599e93b71f272 authorRyan Trinkle <ryan.trinkle@gmail.com> dateSat 24 Dec 2016, 20:46 (10 years ago) parentefaaa52 68150eb

42 files changed+1556−1355

compare with develop

unifiedsplit

.gitignore+1

@@ -38,3 +38,4 @@ cabal.sandbox.config

3838codex.tags

3939*.dump-*

4040*.verbose-core2core

41+*.lkshf

LICENSE → reflex-dom-core/LICENSErenamed

The content is the same.

Setup.hs → reflex-dom-core/Setup.hsrenamed

The content is the same.

reflex-dom.cabal → reflex-dom-core/reflex-dom-core.cabalrenamed+30−30

@@ -1,4 +1,4 @@

1−Name: reflex-dom

1+Name: reflex-dom-core

22Version: 0.4

33Synopsis: Functional Reactive Web Apps with Reflex

44Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine

@@ -11,15 +11,16 @@ Category: FRP, Web, GUI, HTML, Javascript, Reactive, Reactivity, User Interfaces

1111Build-type: Simple

1212Cabal-version: >=1.9.2

1313-- Deal with https://github.com/haskell/cabal/issues/2544 / https://github.com/haskell/cabal/issues/367

14−extra-source-files: src-ghc/Reflex/Dom/Internal/Foreign.hs

15− src-ghc/Reflex/Dom/Xhr/Foreign.hs

16− src-ghc/Reflex/Dom/WebSocket/Foreign.hs

17− src-ghcjs/Reflex/Dom/Internal/Foreign.hs

18− src-ghcjs/Reflex/Dom/Xhr/Foreign.hs

19− src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs

14+extra-source-files: src/Reflex/Dom/Xhr/Foreign.hs

15+ src/Reflex/Dom/WebSocket/Foreign.hs

2016 src/Reflex/Dom/Xhr/ResponseType.hs

2117 src/Reflex/Dom/Xhr/Exception.hs

2218

19+flag use-template-haskell

20+ description: Use template haskell to generate lenses

21+ default: True

22+ manual: True

23+

2324flag use-reflex-optimizer

2425 description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental.

2526 default: False

@@ -35,13 +36,13 @@ library

3536 blaze-builder,

3637 bytestring == 0.10.*,

3738 containers == 0.5.*,

39+ contravariant >= 1.4 && < 1.5,

3840 data-default >= 0.5 && < 0.8,

3941 dependent-map == 0.2.*,

40− dependent-sum == 0.3.*,

41− dependent-sum-template >= 0.0.0.4 && < 0.1,

4242 directory == 1.2.*,

4343 exception-transformers == 0.4.*,

44− ghcjs-dom >= 0.2.1 && < 0.3,

44+ ghcjs-dom >= 0.7.0.4 && < 0.8,

45+ jsaddle >=0.8.0.1 && <0.9,

4546 -- keycode-0.2 has a bug on firefox

4647 keycode >= 0.2.1 && < 0.3,

4748 lens >= 4.7 && < 5,

@@ -53,7 +54,6 @@ library

5354 reflex == 0.5.*,

5455 semigroups >= 0.16 && < 0.19,

5556 stm == 2.4.*,

56− template-haskell,

5757 text == 1.2.*,

5858 these >= 0.4 && < 0.8,

5959 time >= 1.4 && < 1.7,

@@ -62,35 +62,24 @@ library

6262 zenc == 0.1.*

6363

6464 if impl(ghcjs)

65− hs-source-dirs: src-ghcjs

6665 build-depends:

6766 ghcjs-base,

6867 hashable == 1.2.*

6968 else

70− hs-source-dirs: src-ghc

71− build-depends:

72− glib == 0.13.*,

73− gtk3 >= 0.13.0 && < 0.15,

74− webkitgtk3 == 0.14.*,

75− webkitgtk3-javascriptcore == 0.13.*,

76− raw-strings-qq

77− pkgconfig-depends:

78− webkitgtk-3.0 >= 1.8

7969 if !os(windows)

8070 build-depends: unix == 2.7.*

8171

8272 exposed-modules:

8373 Foreign.JavaScript.TH

84− Reflex.Dom

8574 Reflex.Dom.Builder.Class

8675 Reflex.Dom.Builder.Class.Events

8776 Reflex.Dom.Builder.Immediate

8877 Reflex.Dom.Builder.InputDisabled

8978 Reflex.Dom.Builder.Static

9079 Reflex.Dom.Class

91− Reflex.Dom.Internal

92− Reflex.Dom.Internal.Foreign

80+ Reflex.Dom.Core

9381 Reflex.Dom.Location

82+ Reflex.Dom.Main

9483 Reflex.Dom.Old

9584 Reflex.Dom.Time

9685 Reflex.Dom.WebSocket

@@ -106,18 +95,29 @@ library

10695 Reflex.Dom.Xhr.ResponseType

10796 Reflex.Dom.Xhr.Exception

10897

109− other-extensions: TemplateHaskell

11098 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans

11199

112100 if flag(use-reflex-optimizer)

113101 ghc-options: -fplugin=Reflex.Optimizer

114102

115−test-suite hlint

116− build-depends: base, hlint == 1.9.*

117− hs-source-dirs: test

118− main-is: hlint.hs

119− type: exitcode-stdio-1.0

103+ if flag(use-template-haskell)

104+ build-depends:

105+ dependent-sum == 0.3.*,

106+ dependent-sum-template >= 0.0.0.5 && < 0.1,

107+ template-haskell

108+ other-extensions: TemplateHaskell

109+ cpp-options: -DUSE_TEMPLATE_HASKELL

110+ else

111+ build-depends:

112+ dependent-sum == 0.4.*

113+

114+--test-suite hlint

115+-- build-depends: base, hlint == 1.9.*

116+-- hs-source-dirs: test

117+-- main-is: hlint.hs

118+-- type: exitcode-stdio-1.0

120119

121120source-repository head

122121 type: git

123122 location: https://github.com/reflex-frp/reflex-dom

123+ subdir: reflex-dom-core

src/Foreign/JavaScript/TH.hs → reflex-dom-core/src/Foreign/JavaScript/TH.hsrenamed+155−211

@@ -3,23 +3,29 @@

33{-# LANGUAGE ExistentialQuantification #-}

44{-# LANGUAGE FlexibleContexts #-}

55{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE ForeignFunctionInterface #-}

76{-# LANGUAGE FunctionalDependencies #-}

87{-# LANGUAGE GeneralizedNewtypeDeriving #-}

98{-# LANGUAGE MultiParamTypeClasses #-}

109{-# LANGUAGE RankNTypes #-}

1110{-# LANGUAGE StandaloneDeriving #-}

11+#ifdef USE_TEMPLATE_HASKELL

1212{-# LANGUAGE TemplateHaskell #-}

13+#endif

1314{-# LANGUAGE TypeFamilies #-}

1415{-# LANGUAGE TypeSynonymInstances #-}

1516{-# LANGUAGE UndecidableInstances #-}

17+{-# LANGUAGE ConstraintKinds #-}

1618#ifdef __GHCJS__

19+{-# LANGUAGE ForeignFunctionInterface #-}

1720{-# LANGUAGE JavaScriptFFI #-}

1821#endif

1922module Foreign.JavaScript.TH ( module Foreign.JavaScript.TH

23+#ifdef USE_TEMPLATE_HASKELL

2024 , Safety (..)

25+#endif

2126 ) where

2227

28+import Prelude hiding((!!))

2329import Reflex.Class

2430import Reflex.DynamicWriter

2531import Reflex.Host.Class

@@ -28,12 +34,15 @@ import Reflex.PerformEvent.Class

2834import Reflex.PostBuild.Base

2935import Reflex.Requester.Base

3036

37+#ifdef USE_TEMPLATE_HASKELL

3138import Language.Haskell.TH

39+#endif

3240

41+import GHCJS.DOM.Types

42+ (toJSString, liftJSM, askJSM, runJSM, JSContextRef,

43+ Node(..), MonadJSM(..), toJSVal, JSVal)

3344#ifdef __GHCJS__

3445import qualified GHCJS.Buffer as JS

35−import GHCJS.DOM

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

3746import qualified GHCJS.DOM.Types as JS

3847import qualified GHCJS.Foreign as JS

3948import qualified GHCJS.Foreign.Callback as JS

@@ -53,15 +62,13 @@ import Foreign.C.Types

5362import Foreign.Ptr

5463import Text.Encoding.Z

5564#else

56−import Foreign.Marshal

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

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

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

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

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

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

63−import Graphics.UI.Gtk.WebKit.WebView

64−import System.Glib.FFI

65+import Data.Word (Word8)

66+import Control.Lens.Operators ((^.))

67+import Language.Javascript.JSaddle

68+ (eval, valMakeString, valToNumber, function,

69+ valMakeNumber, valBool, valToText, valToBool, valIsUndefined,

70+ valUndefined, valIsNull, Function(..), (!!),

71+ js, js1, jss, array, freeFunction)

6572#endif

6673

6774import Control.Concurrent

@@ -77,75 +84,74 @@ import qualified Control.Monad.State.Strict as Strict

7784import Control.Monad.Trans.Control

7885import Data.ByteString (ByteString)

7986import qualified Data.ByteString as BS

80−import Data.Coerce

87+import Data.Coerce (coerce)

8188import Data.Monoid

8289import Data.Text (Text)

8390import qualified Data.Text as T

8491

85−class Monad m => HasWebView m where

86− type WebViewPhantom m :: *

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

92+class Monad m => HasJSContext m where

93+ type JSContextPhantom m :: *

94+ askJSContext :: m (JSContextSingleton (JSContextPhantom m))

8895

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

90− type WebViewPhantom (ReaderT r m) = WebViewPhantom m

91− askWebView = lift askWebView

96+type HasWebView = HasJSContext

97+-- Not sure if we should deprecate this {-# DEPRECATED HasWebView "Use HasJSContext" #-}

9298

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

94− type WebViewPhantom (StateT r m) = WebViewPhantom m

95− askWebView = lift askWebView

99+instance HasJSContext m => HasJSContext (ReaderT r m) where

100+ type JSContextPhantom (ReaderT r m) = JSContextPhantom m

101+ askJSContext = lift askJSContext

96102

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

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

99− askWebView = lift askWebView

103+instance HasJSContext m => HasJSContext (StateT r m) where

104+ type JSContextPhantom (StateT r m) = JSContextPhantom m

105+ askJSContext = lift askJSContext

100106

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

102− type WebViewPhantom (PostBuildT t m) = WebViewPhantom m

103− askWebView = lift askWebView

107+instance HasJSContext m => HasJSContext (Strict.StateT r m) where

108+ type JSContextPhantom (Strict.StateT r m) = JSContextPhantom m

109+ askJSContext = lift askJSContext

104110

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

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

107− askWebView = PerformEventT $ lift askWebView

111+instance HasJSContext m => HasJSContext (PostBuildT t m) where

112+ type JSContextPhantom (PostBuildT t m) = JSContextPhantom m

113+ askJSContext = lift askJSContext

108114

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

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

111− askWebView = lift askWebView

115+instance (ReflexHost t, HasJSContext (HostFrame t)) => HasJSContext (PerformEventT t m) where

116+ type JSContextPhantom (PerformEventT t m) = JSContextPhantom (HostFrame t)

117+ askJSContext = PerformEventT $ lift askJSContext

112118

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

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

115− askWebView = lift askWebView

119+instance HasJSContext m => HasJSContext (DynamicWriterT t w m) where

120+ type JSContextPhantom (DynamicWriterT t w m) = JSContextPhantom m

121+ askJSContext = lift askJSContext

116122

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

123+newtype WithJSContextSingleton x m a = WithJSContextSingleton { unWithJSContextSingleton :: ReaderT (JSContextSingleton x) m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)

118124

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

120− type PrimState (WithWebView x m) = PrimState m

125+instance PrimMonad m => PrimMonad (WithJSContextSingleton x m) where

126+ type PrimState (WithJSContextSingleton x m) = PrimState m

121127 primitive = lift . primitive

122128

123−instance 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')

129+instance MonadAdjust t m => MonadAdjust t (WithJSContextSingleton x m) where

130+ runWithReplace a0 a' = WithJSContextSingleton $ runWithReplace (coerce a0) (coerceEvent a')

131+ sequenceDMapWithAdjust dm0 dm' = WithJSContextSingleton $ sequenceDMapWithAdjust (coerce dm0) (coerceEvent dm')

126132

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

133+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithJSContextSingleton x m) where

128134 {-# INLINABLE newEventWithTrigger #-}

129135 newEventWithTrigger = lift . newEventWithTrigger

130136 {-# INLINABLE newFanEventWithTrigger #-}

131137 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

132138

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

139+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (WithJSContextSingleton x m) where

134140 {-# INLINABLE subscribeEvent #-}

135141 subscribeEvent = lift . subscribeEvent

136142

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

138− type ReadPhase (WithWebView x m) = ReadPhase m

143+instance MonadReflexHost t m => MonadReflexHost t (WithJSContextSingleton x m) where

144+ type ReadPhase (WithJSContextSingleton x m) = ReadPhase m

139145 {-# INLINABLE fireEventsAndRead #-}

140146 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a

141147 {-# INLINABLE runHostFrame #-}

142148 runHostFrame = lift . runHostFrame

143149

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

150+instance MonadSample t m => MonadSample t (WithJSContextSingleton x m) where

145151 {-# INLINABLE sample #-}

146152 sample = lift . sample

147153

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

154+instance MonadHold t m => MonadHold t (WithJSContextSingleton x m) where

149155 {-# INLINABLE hold #-}

150156 hold v0 = lift . hold v0

151157 {-# INLINABLE holdDyn #-}

@@ -153,41 +159,41 @@ instance MonadHold t m => MonadHold t (WithWebView x m) where

153159 {-# INLINABLE holdIncremental #-}

154160 holdIncremental v0 = lift . holdIncremental v0

155161

156−instance MonadTransControl (WithWebView x) where

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

162+instance MonadTransControl (WithJSContextSingleton x) where

163+ type StT (WithJSContextSingleton x) a = StT (ReaderT (JSContextSingleton x)) a

158164 {-# INLINABLE liftWith #-}

159− liftWith = defaultLiftWith WithWebView unWithWebView

165+ liftWith = defaultLiftWith WithJSContextSingleton unWithJSContextSingleton

160166 {-# INLINABLE restoreT #-}

161− restoreT = defaultRestoreT WithWebView

167+ restoreT = defaultRestoreT WithJSContextSingleton

162168

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

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

169+instance PerformEvent t m => PerformEvent t (WithJSContextSingleton x m) where

170+ type Performable (WithJSContextSingleton x m) = WithJSContextSingleton x (Performable m)

165171 {-# INLINABLE performEvent_ #-}

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

167173 {-# INLINABLE performEvent #-}

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

169175

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

171−runWithWebView = runReaderT . unWithWebView

176+runWithJSContextSingleton :: WithJSContextSingleton x m a -> JSContextSingleton x -> m a

177+runWithJSContextSingleton = runReaderT . unWithJSContextSingleton

172178

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

174− type WebViewPhantom (WithWebView x m) = x

175− askWebView = WithWebView ask

179+instance (Monad m) => HasJSContext (WithJSContextSingleton x m) where

180+ type JSContextPhantom (WithJSContextSingleton x m) = x

181+ askJSContext = WithJSContextSingleton ask

176182

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

178− type Ref (WithWebView x m) = Ref m

183+instance MonadRef m => MonadRef (WithJSContextSingleton x m) where

184+ type Ref (WithJSContextSingleton x m) = Ref m

179185 newRef = lift . newRef

180186 readRef = lift . readRef

181187 writeRef r = lift . writeRef r

182188

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

189+instance MonadAtomicRef m => MonadAtomicRef (WithJSContextSingleton x m) where

184190 atomicModifyRef r = lift . atomicModifyRef r

185191

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

187−withWebViewSingleton wv f = f $ WebViewSingleton wv

192+withJSContextSingleton :: MonadJSM m => (forall x. JSContextSingleton x -> m r) -> m r

193+withJSContextSingleton f = askJSM >>= f . JSContextSingleton

188194

189−-- | 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

190−newtype WebViewSingleton x = WebViewSingleton { unWebViewSingleton :: WebView }

195+-- | A singleton type for a given JS Context; we use this to statically guarantee that different JSContexts (and thus different javscript contexts) don't get mixed up

196+newtype JSContextSingleton x = JSContextSingleton { unJSContextSingleton :: JSContextRef }

191197

192198#ifdef __GHCJS__

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

@@ -196,39 +202,40 @@ newtype JSFFI = JSFFI JSFFI_Internal

196202newtype JSFFI = JSFFI String

197203#endif

198204

199−newtype JSFun x = JSFun { unJSFun :: JSRef x }

205+data JSFun x = JSFun { unJSFun :: JSRef x

206+#ifndef __GHCJS__

207+ , unJSFunction :: Function

208+#endif

209+ }

200210

201211instance ToJS x (JSFun x) where

202− withJS (JSFun r) f = f r

203−

204−instance FromJS x (JSFun x) where

205− fromJS = return . JSFun

212+ withJS r f = f (unJSFun r)

206213

207214class IsJSContext x where

208215 data JSRef x

209216

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

211− type JSM m :: * -> *

212− liftJS :: JSM m a -> m a

217+class (Monad m, MonadIO (JSX m), MonadFix (JSX m), MonadJS x (JSX m)) => HasJS x m | m -> x where

218+ type JSX m :: * -> *

219+ liftJS :: JSX m a -> m a

213220

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

215− type JSM (ReaderT r m) = JSM m

222+ type JSX (ReaderT r m) = JSX m

216223 liftJS = lift . liftJS

217224

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

219− type JSM (PostBuildT t m) = JSM m

226+ type JSX (PostBuildT t m) = JSX m

220227 liftJS = lift . liftJS

221228

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

223− type JSM (PerformEventT t m) = JSM (HostFrame t)

230+ type JSX (PerformEventT t m) = JSX (HostFrame t)

224231 liftJS = PerformEventT . lift . liftJS

225232

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

227− type JSM (DynamicWriterT t w m) = JSM m

234+ type JSX (DynamicWriterT t w m) = JSX m

228235 liftJS = lift . liftJS

229236

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

231− type JSM (RequesterT t request response m) = JSM m

238+ type JSX (RequesterT t request response m) = JSX m

232239 liftJS = lift . liftJS

233240

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

@@ -259,8 +266,8 @@ class Monad m => MonadJS x m | m -> x where

259266

260267data JSCtx_IO

261268

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

263− type JSM (WithWebView x m) = IO

269+instance MonadIO m => HasJS JSCtx_IO (WithJSContextSingleton x m) where

270+ type JSX (WithJSContextSingleton x m) = IO

264271 liftJS = liftIO

265272

266273instance IsJSContext JSCtx_IO where

@@ -276,9 +283,7 @@ instance MonadJS JSCtx_IO IO where

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

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

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

279− fromJSNumber (JSRef_IO r) = do

280− Just n <- JS.fromJSVal r

281− return n

286+ fromJSNumber (JSRef_IO r) = JS.fromJSValUnchecked r

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

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

284289 withJSNumber n f = do

@@ -309,65 +314,51 @@ foreign import javascript unsafe "function(){ return $1(arguments); }" funWithAr

309314

310315#else

311316

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

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

314−withJSStringRaw str a = do

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

316− a strRef

317−

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

319−fromJSNumberRaw val = do

320− jsContext <- askJSContext

321− liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions

322−

323−

324317data JSCtx_JavaScriptCore x

325318

326319instance IsJSContext (JSCtx_JavaScriptCore x) where

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

320+ newtype JSRef (JSCtx_JavaScriptCore x) = JSRef_JavaScriptCore { unJSRef_JavaScriptCore :: JSVal }

328321

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

330− type JSM (WithWebView x m) = WithWebView x IO

322+instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithJSContextSingleton x m) where

323+ type JSX (WithJSContextSingleton x m) = WithJSContextSingleton x IO

331324 liftJS a = do

332− wv <- askWebView

333− liftIO $ runWithWebView a wv

325+ wv <- askJSContext

326+ liftIO $ runWithJSContextSingleton a wv

334327

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

336329

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

338331runWithJSContext = runReaderT . unWithJSContext

339332

340−class Monad m => HasJSContext m where

341− askJSContext :: m JSContextRef

342−

343−instance MonadIO m => HasJSContext (WithWebView x m) where

344− askJSContext = do

345− wv <- askWebView

346− liftIO $ webFrameGetGlobalContext =<< webViewGetMainFrame (unWebViewSingleton wv)

333+instance MonadIO m => MonadJSM (WithJSContextSingleton x m) where

334+ liftJSM' f = do

335+ wv <- askJSContext

336+ runJSM f $ unJSContextSingleton wv

347337

348−instance Monad m => HasJSContext (WithJSContext x m) where

349− askJSContext = WithJSContext ask

338+instance MonadIO m => MonadJSM (WithJSContext x m) where

339+ liftJSM' f =

340+ runJSM f =<< WithJSContext ask

350341

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

342+lowerWithJSContext :: MonadJSM m => WithJSContext x IO a -> m a

352343lowerWithJSContext a = do

353− c <- askJSContext

344+ c <- askJSM

354345 liftIO $ runWithJSContext a c

355346

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

347+liftWithJSContextSingletonThroughWithJSContext :: (HasJSContext m, MonadJSM m, MonadTrans t, Monad m1)

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

358− -> (t1 -> WithWebView (WebViewPhantom m) m1 a)

349+ -> (t1 -> WithJSContextSingleton (JSContextPhantom m) m1 a)

359350 -> m b

360−liftWithWebViewThroughWithJSContext f a = do

361− wv <- askWebView

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

351+liftWithJSContextSingletonThroughWithJSContext f a = do

352+ wv <- askJSContext

353+ lowerWithJSContext $ f $ \b' -> lift $ runWithJSContextSingleton (a b') wv

363354

364−instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where

355+instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContextSingleton x IO) where

365356 forkJS a = do

366− wv <- askWebView

367− liftIO $ forkIO $ runWithWebView a wv

357+ wv <- askJSContext

358+ liftIO $ forkIO $ runWithJSContextSingleton a wv

368359 mkJSFun a = do

369− wv <- askWebView

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

360+ wv <- askJSContext

361+ lowerWithJSContext $ mkJSFun $ \args -> lift $ runWithJSContextSingleton (a args) wv

371362 runJS expr args = lowerWithJSContext $ runJS expr args

372363 mkJSUndefined = lowerWithJSContext mkJSUndefined

373364 isJSNull = lowerWithJSContext . isJSNull

@@ -378,106 +369,55 @@ instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where

378369 fromJSUint8Array = lowerWithJSContext . fromJSUint8Array

379370 fromJSNumber = lowerWithJSContext . fromJSNumber

380371 freeJSFun = lowerWithJSContext . freeJSFun

381− withJSBool = liftWithWebViewThroughWithJSContext . withJSBool

382− withJSString = liftWithWebViewThroughWithJSContext . withJSString

383− withJSNumber = liftWithWebViewThroughWithJSContext . withJSNumber

384− withJSArray = liftWithWebViewThroughWithJSContext . withJSArray

385− withJSUint8Array = liftWithWebViewThroughWithJSContext . withJSUint8Array

386− withJSNode = liftWithWebViewThroughWithJSContext . withJSNode

372+ withJSBool = liftWithJSContextSingletonThroughWithJSContext . withJSBool

373+ withJSString = liftWithJSContextSingletonThroughWithJSContext . withJSString

374+ withJSNumber = liftWithJSContextSingletonThroughWithJSContext . withJSNumber

375+ withJSArray = liftWithJSContextSingletonThroughWithJSContext . withJSArray

376+ withJSUint8Array = liftWithJSContextSingletonThroughWithJSContext . withJSUint8Array

377+ withJSNode = liftWithJSContextSingletonThroughWithJSContext . withJSNode

387378 setJSProp propName valRef objRef = lowerWithJSContext $ setJSProp propName valRef objRef

388379 getJSProp propName objRef = lowerWithJSContext $ getJSProp propName objRef

389380

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

391− runJS (JSFFI body) args = do

392− jsContext <- askJSContext

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

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

395− return $ JSRef_JavaScriptCore result --TODO: Protect and unprotect result

382+ runJS (JSFFI body) args =

383+ withJSArray args $ \(JSRef_JavaScriptCore this) -> do

384+ result <- liftJSM $ eval ("(function(){ return (" <> body <> "); })") ^. js1 "apply" this

385+ return $ JSRef_JavaScriptCore result

396386 forkJS a = do

397− c <- askJSContext

398− liftIO $ forkIO $ runWithJSContext a c

399− mkJSUndefined = do

400− jsContext <- askJSContext

401− fmap JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext

402− isJSNull (JSRef_JavaScriptCore r) = do

403− jsContext <- askJSContext

404− liftIO $ jsvalueisnull jsContext r

405− isJSUndefined (JSRef_JavaScriptCore r) = do

406− jsContext <- askJSContext

407− liftIO $ jsvalueisundefined jsContext r

408− fromJSBool (JSRef_JavaScriptCore r) = do

409− jsContext <- askJSContext

410− liftIO $ jsvaluetoboolean jsContext r

411− fromJSString (JSRef_JavaScriptCore r) = do

412− jsContext <- askJSContext

413− liftIO $ do

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

415− l <- jsstringgetmaximumutf8cstringsize s

416− allocaBytes (fromIntegral l) $ \ps -> do

417− _ <- jsstringgetutf8cstring'_ s ps (fromIntegral l)

418− peekCString ps

419− withJSBool b a = do

420− jsContext <- askJSContext

421− valRef <- liftIO $ jsvaluemakeboolean jsContext b

422− a $ JSRef_JavaScriptCore valRef

423− withJSString str a = do

424− jsContext <- askJSContext

425− withJSStringRaw str $ \strRef -> do

426− valRef <- liftIO $ jsvaluemakestring jsContext strRef

427− a $ JSRef_JavaScriptCore valRef --TODO: Protect/unprotect valRef

428− withJSNumber n a = do

429− jsContext <- askJSContext

430− valRef <- liftIO $ jsvaluemakenumber jsContext n

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

432− withJSArray elems a = do

433− jsContext <- askJSContext

434− let numElems = length elems

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

436− liftIO $ pokeArray elemsArr $ coerce elems

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

438− a $ JSRef_JavaScriptCore arrRef --TODO: Protect/unprotect valRef

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

387+ c <- askJSM

388+ liftIO . forkIO $ runWithJSContext a c

389+ mkJSUndefined = return $ JSRef_JavaScriptCore valUndefined

390+ isJSNull (JSRef_JavaScriptCore r) = liftJSM $ valIsNull r

391+ isJSUndefined (JSRef_JavaScriptCore r) = liftJSM $ valIsUndefined r

392+ fromJSBool (JSRef_JavaScriptCore r) = liftJSM $ valToBool r

393+ fromJSString (JSRef_JavaScriptCore r) = liftJSM (T.unpack <$> valToText r)

394+ withJSBool b a = a $ JSRef_JavaScriptCore (valBool b)

395+ withJSString str a = a . JSRef_JavaScriptCore =<< liftJSM (valMakeString $ toJSString str)

396+ withJSNumber n a = a . JSRef_JavaScriptCore =<< liftJSM (valMakeNumber n)

397+ withJSArray elems a = a . JSRef_JavaScriptCore =<< liftJSM

398+ (toJSVal =<< array (map (\(JSRef_JavaScriptCore r) -> r) elems))

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

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

442401 f $ JSUint8Array payloadRef

443− fromJSArray (JSRef_JavaScriptCore a) = do

444− jsContext <- askJSContext

445− lenRef <- withJSStringRaw "length" $ \lengthStr -> do

446− liftIO $ jsobjectgetproperty jsContext a lengthStr nullPtr --TODO: Exceptions

447− lenDouble <- fromJSNumberRaw lenRef

448− let len = round lenDouble

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

450− JSRef_JavaScriptCore <$> jsobjectgetpropertyatindex jsContext a i nullPtr --TODO: Exceptions

402+ fromJSArray (JSRef_JavaScriptCore a) = liftJSM $ do

403+ len <- round <$> (valToNumber =<< (a ^. js "length"))

404+ forM [0..len-1] $ \i -> JSRef_JavaScriptCore <$> a !! i

451405 fromJSUint8Array a = do

452406 vals <- fromJSArray a

453407 doubles <- mapM fromJSNumber vals

454408 return $ BS.pack $ map round doubles

455− fromJSNumber (JSRef_JavaScriptCore val) = do

456− jsContext <- askJSContext

457− liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions

458− mkJSFun a = do

459− jsContext <- askJSContext

460− cb <- liftIO $ mkJSObjectCallAsFunctionCallback $ \_ _ _ argc argv _ -> do --TODO: Use the exception pointer to handle haskell exceptions

461− args <- forM [0..fromIntegral (argc-1)] $ \n -> do

462− x <- peekElemOff argv n

463− jsvalueprotect jsContext x

464− return $ JSRef_JavaScriptCore x --TODO: Unprotect eventually

465− unJSRef_JavaScriptCore <$> runWithJSContext (a args) jsContext

466− cbRef <- liftIO $ jsobjectmakefunctionwithcallback jsContext nullPtr cb

467− liftIO $ jsvalueprotect jsContext cbRef

468− return $ JSFun $ JSRef_JavaScriptCore cbRef

469− freeJSFun (JSFun (JSRef_JavaScriptCore f)) = do

470− jsContext <- askJSContext

471− liftIO $ jsvalueunprotect jsContext f

472− setJSProp propName (JSRef_JavaScriptCore valRef) (JSRef_JavaScriptCore objRef) = do

473− withJSStringRaw propName $ \propNameRaw -> do

474− jsContext <- askJSContext

475− liftIO $ jsobjectsetproperty jsContext objRef propNameRaw valRef 0 nullPtr --TODO: property attribute, exceptions

476− getJSProp propName (JSRef_JavaScriptCore objRef) = do

477− withJSStringRaw propName $ \propNameRaw -> do

478− jsContext <- askJSContext

479− liftIO $ JSRef_JavaScriptCore <$> jsobjectgetproperty jsContext objRef propNameRaw nullPtr --TODO: property attribute, exceptions

480− withJSNode = error "withJSNode is only supported in ghcjs"

409+ fromJSNumber (JSRef_JavaScriptCore val) = liftJSM $ valToNumber val

410+ mkJSFun a = liftJSM $ do

411+ ctx <- askJSM

412+ f <- function $ \_ _ args -> liftIO $ void $ runWithJSContext (a $ map JSRef_JavaScriptCore args) ctx

413+ fRef <- toJSVal f

414+ return $ JSFun (JSRef_JavaScriptCore fRef) f

415+ freeJSFun (JSFun _ f) = liftJSM $ freeFunction f

416+ setJSProp propName (JSRef_JavaScriptCore valRef) (JSRef_JavaScriptCore objRef) =

417+ liftJSM $ objRef ^. jss propName valRef

418+ getJSProp propName (JSRef_JavaScriptCore objRef) =

419+ JSRef_JavaScriptCore <$> liftJSM (objRef ^. js propName)

420+ withJSNode n f = f . JSRef_JavaScriptCore =<< liftJSM (toJSVal n)

481421

482422#endif

483423

@@ -559,6 +499,8 @@ instance ToJS x Node where

559499 withJS = withJSNode

560500

561501

502+#ifdef USE_TEMPLATE_HASKELL

503+

562504importJS :: Safety -> String -> String -> Q Type -> Q [Dec]

563505importJS safety body name qt = do

564506 t <- qt

@@ -606,3 +548,5 @@ parseType (ForallT _ [AppT (AppT (ConT monadJs) (VarT _)) (VarT m)] funType)

606548 | m' == m -> ([], result)

607549 _ -> error $ "parseType: can't parse type " <> show t

608550parseType t = error $ "parseType: can't parse type " <> show t

551+

552+#endif

src/Reflex/Dom/Builder/Class.hs → reflex-dom-core/src/Reflex/Dom/Builder/Class.hsrenamed+125

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE ConstraintKinds #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE DefaultSignatures #-}

@@ -12,7 +13,9 @@

1213{-# LANGUAGE RankNTypes #-}

1314{-# LANGUAGE RecursiveDo #-}

1415{-# LANGUAGE ScopedTypeVariables #-}

16+#ifdef USE_TEMPLATE_HASKELL

1517{-# LANGUAGE TemplateHaskell #-}

18+#endif

1619{-# LANGUAGE TypeFamilies #-}

1720{-# LANGUAGE UndecidableInstances #-}

1821module Reflex.Dom.Builder.Class

@@ -152,6 +155,19 @@ data TextNodeConfig t

152155 , _textNodeConfig_setContents :: Event t Text

153156 }

154157

158+#ifndef USE_TEMPLATE_HASKELL

159+textNodeConfig_initialContents :: Lens' (TextNodeConfig t) Text

160+textNodeConfig_initialContents f (TextNodeConfig a b) = (\a' -> TextNodeConfig a' b) <$> f a

161+{-# INLINE textNodeConfig_initialContents #-}

162+textNodeConfig_setContents :: Lens

163+ (TextNodeConfig t1)

164+ (TextNodeConfig t2)

165+ (Event t1 Text)

166+ (Event t2 Text)

167+textNodeConfig_setContents f (TextNodeConfig a b) = (\b' -> TextNodeConfig a b') <$> f b

168+{-# INLINE textNodeConfig_setContents #-}

169+#endif

170+

155171instance (Reflex t) => Default (TextNodeConfig t) where

156172 {-# INLINABLE def #-}

157173 def = TextNodeConfig

@@ -216,6 +232,29 @@ data ElementConfig er t m

216232 , _elementConfig_eventSpec :: EventSpec (DomBuilderSpace m) er

217233 }

218234

235+#ifndef USE_TEMPLATE_HASKELL

236+elementConfig_namespace :: Lens' (ElementConfig er t m) (Maybe Namespace)

237+elementConfig_namespace f (ElementConfig a b c d) = (\a' -> ElementConfig a' b c d) <$> f a

238+{-# INLINE elementConfig_namespace #-}

239+elementConfig_initialAttributes :: Lens' (ElementConfig er t m) (Map AttributeName Text)

240+elementConfig_initialAttributes f (ElementConfig a b c d) = (\b' -> ElementConfig a b' c d) <$> f b

241+{-# INLINE elementConfig_initialAttributes #-}

242+elementConfig_modifyAttributes :: Lens

243+ (ElementConfig er t1 m)

244+ (ElementConfig er t2 m)

245+ (Event t1 (Map AttributeName (Maybe Text)))

246+ (Event t2 (Map AttributeName (Maybe Text)))

247+elementConfig_modifyAttributes f (ElementConfig a b c d) = (\c' -> ElementConfig a b c' d) <$> f c

248+{-# INLINE elementConfig_modifyAttributes #-}

249+elementConfig_eventSpec :: Lens

250+ (ElementConfig er1 t m1)

251+ (ElementConfig er2 t m2)

252+ (EventSpec (DomBuilderSpace m1) er1)

253+ (EventSpec (DomBuilderSpace m2) er2)

254+elementConfig_eventSpec f (ElementConfig a b c d) = (\d' -> ElementConfig a b c d') <$> f d

255+{-# INLINE elementConfig_eventSpec #-}

256+#endif

257+

219258data Element er d t

220259 = Element { _element_events :: EventSelector t (WrapArg er EventName) --TODO: EventSelector should have two arguments

221260 , _element_raw :: RawElement d

@@ -226,6 +265,19 @@ data PlaceholderConfig above t m

226265 , _placeholderConfig_deleteSelf :: Event t ()

227266 }

228267

268+#ifndef USE_TEMPLATE_HASKELL

269+placeholderConfig_insertAbove :: Lens

270+ (PlaceholderConfig above1 t m1)

271+ (PlaceholderConfig above2 t m2)

272+ (Event t (m1 above1))

273+ (Event t (m2 above2))

274+placeholderConfig_insertAbove f (PlaceholderConfig a b) = (\a' -> PlaceholderConfig a' b) <$> f a

275+{-# INLINE placeholderConfig_insertAbove #-}

276+placeholderConfig_deleteSelf :: Lens' (PlaceholderConfig above t m) (Event t ())

277+placeholderConfig_deleteSelf f (PlaceholderConfig a b) = (\b' -> PlaceholderConfig a b') <$> f b

278+{-# INLINE placeholderConfig_deleteSelf #-}

279+#endif

280+

229281instance Reflex t => Default (PlaceholderConfig above t m) where

230282 {-# INLINABLE def #-}

231283 def = PlaceholderConfig

@@ -246,6 +298,28 @@ data InputElementConfig er t m

246298 , _inputElementConfig_elementConfig :: ElementConfig er t m

247299 }

248300

301+#ifndef USE_TEMPLATE_HASKELL

302+inputElementConfig_initialValue :: Lens' (InputElementConfig er t m) Text

303+inputElementConfig_initialValue f (InputElementConfig a b c d e) = (\a' -> InputElementConfig a' b c d e) <$> f a

304+{-# INLINE inputElementConfig_initialValue #-}

305+inputElementConfig_setValue :: Lens' (InputElementConfig er t m) (Event t Text)

306+inputElementConfig_setValue f (InputElementConfig a b c d e) = (\b' -> InputElementConfig a b' c d e) <$> f b

307+{-# INLINE inputElementConfig_setValue #-}

308+inputElementConfig_initialChecked :: Lens' (InputElementConfig er t m) Bool

309+inputElementConfig_initialChecked f (InputElementConfig a b c d e) = (\c' -> InputElementConfig a b c' d e) <$> f c

310+{-# INLINE inputElementConfig_initialChecked #-}

311+inputElementConfig_setChecked :: Lens' (InputElementConfig er t m) (Event t Bool)

312+inputElementConfig_setChecked f (InputElementConfig a b c d e) = (\d' -> InputElementConfig a b c d' e) <$> f d

313+{-# INLINE inputElementConfig_setChecked #-}

314+inputElementConfig_elementConfig :: Lens

315+ (InputElementConfig er1 t m1)

316+ (InputElementConfig er2 t m2)

317+ (ElementConfig er1 t m1)

318+ (ElementConfig er2 t m2)

319+inputElementConfig_elementConfig f (InputElementConfig a b c d e) = (\e' -> InputElementConfig a b c d e') <$> f e

320+{-# INLINE inputElementConfig_elementConfig #-}

321+#endif

322+

249323instance (Reflex t, er ~ EventResult, DomBuilder t m) => Default (InputElementConfig er t m) where

250324 {-# INLINABLE def #-}

251325 def = InputElementConfig

@@ -273,6 +347,22 @@ data TextAreaElementConfig er t m

273347 , _textAreaElementConfig_elementConfig :: ElementConfig er t m

274348 }

275349

350+#ifndef USE_TEMPLATE_HASKELL

351+textAreaElementConfig_initialValue :: Lens' (TextAreaElementConfig er t m) Text

352+textAreaElementConfig_initialValue f (TextAreaElementConfig a b c) = (\a' -> TextAreaElementConfig a' b c) <$> f a

353+{-# INLINE textAreaElementConfig_initialValue #-}

354+textAreaElementConfig_setValue :: Lens' (TextAreaElementConfig er t m) (Event t Text)

355+textAreaElementConfig_setValue f (TextAreaElementConfig a b c) = (\b' -> TextAreaElementConfig a b' c) <$> f b

356+{-# INLINE textAreaElementConfig_setValue #-}

357+textAreaElementConfig_elementConfig :: Lens

358+ (TextAreaElementConfig er1 t m1)

359+ (TextAreaElementConfig er2 t m2)

360+ (ElementConfig er1 t m1)

361+ (ElementConfig er2 t m2)

362+textAreaElementConfig_elementConfig f (TextAreaElementConfig a b c) = (\c' -> TextAreaElementConfig a b c') <$> f c

363+{-# INLINE textAreaElementConfig_elementConfig #-}

364+#endif

365+

276366instance (Reflex t, er ~ EventResult, DomBuilder t m) => Default (TextAreaElementConfig er t m) where

277367 {-# INLINABLE def #-}

278368 def = TextAreaElementConfig

@@ -300,6 +390,23 @@ data RawElementConfig er t m = RawElementConfig

300390 , _rawElementConfig_eventSpec :: EventSpec (DomBuilderSpace m) er

301391 }

302392

393+#ifndef USE_TEMPLATE_HASKELL

394+rawElementConfig_modifyAttributes :: Lens

395+ (RawElementConfig er t1 m)

396+ (RawElementConfig er t2 m)

397+ (Event t1 (Map AttributeName (Maybe Text)))

398+ (Event t2 (Map AttributeName (Maybe Text)))

399+rawElementConfig_modifyAttributes f (RawElementConfig a b) = (\a' -> RawElementConfig a' b) <$> f a

400+{-# INLINE rawElementConfig_modifyAttributes #-}

401+rawElementConfig_eventSpec :: Lens

402+ (RawElementConfig er1 t m1)

403+ (RawElementConfig er2 t m2)

404+ (EventSpec (DomBuilderSpace m1) er1)

405+ (EventSpec (DomBuilderSpace m2) er2)

406+rawElementConfig_eventSpec f (RawElementConfig a b) = (\b' -> RawElementConfig a b') <$> f b

407+{-# INLINE rawElementConfig_eventSpec #-}

408+#endif

409+

303410instance (Reflex t, DomSpace (DomBuilderSpace m)) => Default (RawElementConfig EventResult t m) where

304411 def = RawElementConfig

305412 { _rawElementConfig_modifyAttributes = never

@@ -312,6 +419,22 @@ data SelectElementConfig er t m = SelectElementConfig

312419 , _selectElementConfig_elementConfig :: ElementConfig er t m

313420 }

314421

422+#ifndef USE_TEMPLATE_HASKELL

423+selectElementConfig_initialValue :: Lens' (SelectElementConfig er t m) Text

424+selectElementConfig_initialValue f (SelectElementConfig a b c) = (\a' -> SelectElementConfig a' b c) <$> f a

425+{-# INLINE selectElementConfig_initialValue #-}

426+selectElementConfig_setValue :: Lens' (SelectElementConfig er t m) (Event t Text)

427+selectElementConfig_setValue f (SelectElementConfig a b c) = (\b' -> SelectElementConfig a b' c) <$> f b

428+{-# INLINE selectElementConfig_setValue #-}

429+selectElementConfig_elementConfig :: Lens

430+ (SelectElementConfig er1 t m1)

431+ (SelectElementConfig er2 t m2)

432+ (ElementConfig er1 t m1)

433+ (ElementConfig er2 t m2)

434+selectElementConfig_elementConfig f (SelectElementConfig a b c) = (\c' -> SelectElementConfig a b c') <$> f c

435+{-# INLINE selectElementConfig_elementConfig #-}

436+#endif

437+

315438instance (Reflex t, er ~ EventResult, DomBuilder t m) => Default (SelectElementConfig er t m) where

316439 def = SelectElementConfig

317440 { _selectElementConfig_initialValue = ""

@@ -327,6 +450,7 @@ data SelectElement er d t = SelectElement

327450 , _selectElement_raw :: RawSelectElement d

328451 }

329452

453+#ifdef USE_TEMPLATE_HASKELL

330454concat <$> mapM makeLenses

331455 [ ''TextNodeConfig

332456 , ''ElementConfig

@@ -336,6 +460,7 @@ concat <$> mapM makeLenses

336460 , ''SelectElementConfig

337461 , ''RawElementConfig

338462 ]

463+#endif

339464

340465class CanDeleteSelf t a | a -> t where

341466 deleteSelf :: Lens' a (Event t ())

reflex-dom-core/src/Reflex/Dom/Builder/Class/Events.hsnew file+371

@@ -0,0 +1,371 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DataKinds #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE KindSignatures #-}

5+{-# LANGUAGE PolyKinds #-}

6+#ifdef USE_TEMPLATE_HASKELL

7+{-# LANGUAGE TemplateHaskell #-}

8+#endif

9+{-# LANGUAGE TypeFamilies #-}

10+module Reflex.Dom.Builder.Class.Events where

11+

12+#ifdef USE_TEMPLATE_HASKELL

13+import Data.GADT.Compare.TH

14+#else

15+import Data.GADT.Compare

16+ (GOrdering(..), (:~:)(..), GEq(..), GCompare(..))

17+import Control.Monad (ap)

18+#endif

19+

20+data EventTag

21+ = AbortTag

22+ | BlurTag

23+ | ChangeTag

24+ | ClickTag

25+ | ContextmenuTag

26+ | DblclickTag

27+ | DragTag

28+ | DragendTag

29+ | DragenterTag

30+ | DragleaveTag

31+ | DragoverTag

32+ | DragstartTag

33+ | DropTag

34+ | ErrorTag

35+ | FocusTag

36+ | InputTag

37+ | InvalidTag

38+ | KeydownTag

39+ | KeypressTag

40+ | KeyupTag

41+ | LoadTag

42+ | MousedownTag

43+ | MouseenterTag

44+ | MouseleaveTag

45+ | MousemoveTag

46+ | MouseoutTag

47+ | MouseoverTag

48+ | MouseupTag

49+ | MousewheelTag

50+ | ScrollTag

51+ | SelectTag

52+ | SubmitTag

53+ | WheelTag

54+ | BeforecutTag

55+ | CutTag

56+ | BeforecopyTag

57+ | CopyTag

58+ | BeforepasteTag

59+ | PasteTag

60+ | ResetTag

61+ | SearchTag

62+ | SelectstartTag

63+ | TouchstartTag

64+ | TouchmoveTag

65+ | TouchendTag

66+ | TouchcancelTag

67+

68+data EventName :: EventTag -> * where

69+ Abort :: EventName 'AbortTag

70+ Blur :: EventName 'BlurTag

71+ Change :: EventName 'ChangeTag

72+ Click :: EventName 'ClickTag

73+ Contextmenu :: EventName 'ContextmenuTag

74+ Dblclick :: EventName 'DblclickTag

75+ Drag :: EventName 'DragTag

76+ Dragend :: EventName 'DragendTag

77+ Dragenter :: EventName 'DragenterTag

78+ Dragleave :: EventName 'DragleaveTag

79+ Dragover :: EventName 'DragoverTag

80+ Dragstart :: EventName 'DragstartTag

81+ Drop :: EventName 'DropTag

82+ Error :: EventName 'ErrorTag

83+ Focus :: EventName 'FocusTag

84+ Input :: EventName 'InputTag

85+ Invalid :: EventName 'InvalidTag

86+ Keydown :: EventName 'KeydownTag

87+ Keypress :: EventName 'KeypressTag

88+ Keyup :: EventName 'KeyupTag

89+ Load :: EventName 'LoadTag

90+ Mousedown :: EventName 'MousedownTag

91+ Mouseenter :: EventName 'MouseenterTag

92+ Mouseleave :: EventName 'MouseleaveTag

93+ Mousemove :: EventName 'MousemoveTag

94+ Mouseout :: EventName 'MouseoutTag

95+ Mouseover :: EventName 'MouseoverTag

96+ Mouseup :: EventName 'MouseupTag

97+ Mousewheel :: EventName 'MousewheelTag

98+ Scroll :: EventName 'ScrollTag

99+ Select :: EventName 'SelectTag

100+ Submit :: EventName 'SubmitTag

101+ Wheel :: EventName 'WheelTag

102+ Beforecut :: EventName 'BeforecutTag

103+ Cut :: EventName 'CutTag

104+ Beforecopy :: EventName 'BeforecopyTag

105+ Copy :: EventName 'CopyTag

106+ Beforepaste :: EventName 'BeforepasteTag

107+ Paste :: EventName 'PasteTag

108+ Reset :: EventName 'ResetTag

109+ Search :: EventName 'SearchTag

110+ Selectstart :: EventName 'SelectstartTag

111+ Touchstart :: EventName 'TouchstartTag

112+ Touchmove :: EventName 'TouchmoveTag

113+ Touchend :: EventName 'TouchendTag

114+ Touchcancel :: EventName 'TouchcancelTag

115+

116+newtype EventResult en = EventResult { unEventResult :: EventResultType en }

117+

118+type family EventResultType (en :: EventTag) :: * where

119+ EventResultType 'ClickTag = ()

120+ EventResultType 'DblclickTag = (Int, Int)

121+ EventResultType 'KeypressTag = Int

122+ EventResultType 'KeydownTag = Int

123+ EventResultType 'KeyupTag = Int

124+ EventResultType 'ScrollTag = Int

125+ EventResultType 'MousemoveTag = (Int, Int)

126+ EventResultType 'MousedownTag = (Int, Int)

127+ EventResultType 'MouseupTag = (Int, Int)

128+ EventResultType 'MouseenterTag = ()

129+ EventResultType 'MouseleaveTag = ()

130+ EventResultType 'FocusTag = ()

131+ EventResultType 'BlurTag = ()

132+ EventResultType 'ChangeTag = ()

133+ EventResultType 'DragTag = ()

134+ EventResultType 'DragendTag = ()

135+ EventResultType 'DragenterTag = ()

136+ EventResultType 'DragleaveTag = ()

137+ EventResultType 'DragoverTag = ()

138+ EventResultType 'DragstartTag = ()

139+ EventResultType 'DropTag = ()

140+ EventResultType 'AbortTag = ()

141+ EventResultType 'ContextmenuTag = ()

142+ EventResultType 'ErrorTag = ()

143+ EventResultType 'InputTag = ()

144+ EventResultType 'InvalidTag = ()

145+ EventResultType 'LoadTag = ()

146+ EventResultType 'MouseoutTag = ()

147+ EventResultType 'MouseoverTag = ()

148+ EventResultType 'MousewheelTag = ()

149+ EventResultType 'SelectTag = ()

150+ EventResultType 'SubmitTag = ()

151+ EventResultType 'BeforecutTag = ()

152+ EventResultType 'CutTag = ()

153+ EventResultType 'BeforecopyTag = ()

154+ EventResultType 'CopyTag = ()

155+ EventResultType 'BeforepasteTag = ()

156+ EventResultType 'PasteTag = ()

157+ EventResultType 'ResetTag = ()

158+ EventResultType 'SearchTag = ()

159+ EventResultType 'SelectstartTag = ()

160+ EventResultType 'TouchstartTag = ()

161+ EventResultType 'TouchmoveTag = ()

162+ EventResultType 'TouchendTag = ()

163+ EventResultType 'TouchcancelTag = ()

164+ EventResultType 'WheelTag = ()

165+

166+#ifdef USE_TEMPLATE_HASKELL

167+deriveGEq ''EventName

168+deriveGCompare ''EventName

169+#else

170+instance GEq EventName

171+ where geq Abort Abort = return Refl

172+ geq Blur Blur = return Refl

173+ geq Change Change = return Refl

174+ geq Click Click = return Refl

175+ geq Contextmenu Contextmenu = return Refl

176+ geq Dblclick Dblclick = return Refl

177+ geq Drag Drag = return Refl

178+ geq Dragend Dragend = return Refl

179+ geq Dragenter Dragenter = return Refl

180+ geq Dragleave Dragleave = return Refl

181+ geq Dragover Dragover = return Refl

182+ geq Dragstart Dragstart = return Refl

183+ geq Drop Drop = return Refl

184+ geq Error Error = return Refl

185+ geq Focus Focus = return Refl

186+ geq Input Input = return Refl

187+ geq Invalid Invalid = return Refl

188+ geq Keydown Keydown = return Refl

189+ geq Keypress Keypress = return Refl

190+ geq Keyup Keyup = return Refl

191+ geq Load Load = return Refl

192+ geq Mousedown Mousedown = return Refl

193+ geq Mouseenter Mouseenter = return Refl

194+ geq Mouseleave Mouseleave = return Refl

195+ geq Mousemove Mousemove = return Refl

196+ geq Mouseout Mouseout = return Refl

197+ geq Mouseover Mouseover = return Refl

198+ geq Mouseup Mouseup = return Refl

199+ geq Mousewheel Mousewheel = return Refl

200+ geq Scroll Scroll = return Refl

201+ geq Select Select = return Refl

202+ geq Submit Submit = return Refl

203+ geq Wheel Wheel = return Refl

204+ geq Beforecut Beforecut = return Refl

205+ geq Cut Cut = return Refl

206+ geq Beforecopy Beforecopy = return Refl

207+ geq Copy Copy = return Refl

208+ geq Beforepaste Beforepaste = return Refl

209+ geq Paste Paste = return Refl

210+ geq Reset Reset = return Refl

211+ geq Search Search = return Refl

212+ geq Selectstart Selectstart = return Refl

213+ geq Touchstart Touchstart = return Refl

214+ geq Touchmove Touchmove = return Refl

215+ geq Touchend Touchend = return Refl

216+ geq Touchcancel Touchcancel = return Refl

217+ geq _ _ = Nothing

218+

219+newtype GComparing a b t = GComparing (Either (GOrdering a b) t)

220+

221+instance Functor (GComparing a b) where fmap f (GComparing x) = GComparing (either Left (Right . f) x)

222+instance Monad (GComparing a b) where

223+ return = GComparing . Right

224+ GComparing (Left x) >>= f = GComparing (Left x)

225+ GComparing (Right x) >>= f = f x

226+instance Applicative (GComparing a b) where

227+ pure = return

228+ (<*>) = ap

229+

230+runGComparing (GComparing x) = either id id x

231+

232+instance GCompare EventName

233+ where gcompare Abort Abort = runGComparing $ return GEQ

234+ gcompare Abort _ = GLT

235+ gcompare _ Abort = GGT

236+ gcompare Blur Blur = runGComparing $ return GEQ

237+ gcompare Blur _ = GLT

238+ gcompare _ Blur = GGT

239+ gcompare Change Change = runGComparing $ return GEQ

240+ gcompare Change _ = GLT

241+ gcompare _ Change = GGT

242+ gcompare Click Click = runGComparing $ return GEQ

243+ gcompare Click _ = GLT

244+ gcompare _ Click = GGT

245+ gcompare Contextmenu Contextmenu = runGComparing $ return GEQ

246+ gcompare Contextmenu _ = GLT

247+ gcompare _ Contextmenu = GGT

248+ gcompare Dblclick Dblclick = runGComparing $ return GEQ

249+ gcompare Dblclick _ = GLT

250+ gcompare _ Dblclick = GGT

251+ gcompare Drag Drag = runGComparing $ return GEQ

252+ gcompare Drag _ = GLT

253+ gcompare _ Drag = GGT

254+ gcompare Dragend Dragend = runGComparing $ return GEQ

255+ gcompare Dragend _ = GLT

256+ gcompare _ Dragend = GGT

257+ gcompare Dragenter Dragenter = runGComparing $ return GEQ

258+ gcompare Dragenter _ = GLT

259+ gcompare _ Dragenter = GGT

260+ gcompare Dragleave Dragleave = runGComparing $ return GEQ

261+ gcompare Dragleave _ = GLT

262+ gcompare _ Dragleave = GGT

263+ gcompare Dragover Dragover = runGComparing $ return GEQ

264+ gcompare Dragover _ = GLT

265+ gcompare _ Dragover = GGT

266+ gcompare Dragstart Dragstart = runGComparing $ return GEQ

267+ gcompare Dragstart _ = GLT

268+ gcompare _ Dragstart = GGT

269+ gcompare Drop Drop = runGComparing $ return GEQ

270+ gcompare Drop _ = GLT

271+ gcompare _ Drop = GGT

272+ gcompare Error Error = runGComparing $ return GEQ

273+ gcompare Error _ = GLT

274+ gcompare _ Error = GGT

275+ gcompare Focus Focus = runGComparing $ return GEQ

276+ gcompare Focus _ = GLT

277+ gcompare _ Focus = GGT

278+ gcompare Input Input = runGComparing $ return GEQ

279+ gcompare Input _ = GLT

280+ gcompare _ Input = GGT

281+ gcompare Invalid Invalid = runGComparing $ return GEQ

282+ gcompare Invalid _ = GLT

283+ gcompare _ Invalid = GGT

284+ gcompare Keydown Keydown = runGComparing $ return GEQ

285+ gcompare Keydown _ = GLT

286+ gcompare _ Keydown = GGT

287+ gcompare Keypress Keypress = runGComparing $ return GEQ

288+ gcompare Keypress _ = GLT

289+ gcompare _ Keypress = GGT

290+ gcompare Keyup Keyup = runGComparing $ return GEQ

291+ gcompare Keyup _ = GLT

292+ gcompare _ Keyup = GGT

293+ gcompare Load Load = runGComparing $ return GEQ

294+ gcompare Load _ = GLT

295+ gcompare _ Load = GGT

296+ gcompare Mousedown Mousedown = runGComparing $ return GEQ

297+ gcompare Mousedown _ = GLT

298+ gcompare _ Mousedown = GGT

299+ gcompare Mouseenter Mouseenter = runGComparing $ return GEQ

300+ gcompare Mouseenter _ = GLT

301+ gcompare _ Mouseenter = GGT

302+ gcompare Mouseleave Mouseleave = runGComparing $ return GEQ

303+ gcompare Mouseleave _ = GLT

304+ gcompare _ Mouseleave = GGT

305+ gcompare Mousemove Mousemove = runGComparing $ return GEQ

306+ gcompare Mousemove _ = GLT

307+ gcompare _ Mousemove = GGT

308+ gcompare Mouseout Mouseout = runGComparing $ return GEQ

309+ gcompare Mouseout _ = GLT

310+ gcompare _ Mouseout = GGT

311+ gcompare Mouseover Mouseover = runGComparing $ return GEQ

312+ gcompare Mouseover _ = GLT

313+ gcompare _ Mouseover = GGT

314+ gcompare Mouseup Mouseup = runGComparing $ return GEQ

315+ gcompare Mouseup _ = GLT

316+ gcompare _ Mouseup = GGT

317+ gcompare Mousewheel Mousewheel = runGComparing $ return GEQ

318+ gcompare Mousewheel _ = GLT

319+ gcompare _ Mousewheel = GGT

320+ gcompare Scroll Scroll = runGComparing $ return GEQ

321+ gcompare Scroll _ = GLT

322+ gcompare _ Scroll = GGT

323+ gcompare Select Select = runGComparing $ return GEQ

324+ gcompare Select _ = GLT

325+ gcompare _ Select = GGT

326+ gcompare Submit Submit = runGComparing $ return GEQ

327+ gcompare Submit _ = GLT

328+ gcompare _ Submit = GGT

329+ gcompare Wheel Wheel = runGComparing $ return GEQ

330+ gcompare Wheel _ = GLT

331+ gcompare _ Wheel = GGT

332+ gcompare Beforecut Beforecut = runGComparing $ return GEQ

333+ gcompare Beforecut _ = GLT

334+ gcompare _ Beforecut = GGT

335+ gcompare Cut Cut = runGComparing $ return GEQ

336+ gcompare Cut _ = GLT

337+ gcompare _ Cut = GGT

338+ gcompare Beforecopy Beforecopy = runGComparing $ return GEQ

339+ gcompare Beforecopy _ = GLT

340+ gcompare _ Beforecopy = GGT

341+ gcompare Copy Copy = runGComparing $ return GEQ

342+ gcompare Copy _ = GLT

343+ gcompare _ Copy = GGT

344+ gcompare Beforepaste Beforepaste = runGComparing $ return GEQ

345+ gcompare Beforepaste _ = GLT

346+ gcompare _ Beforepaste = GGT

347+ gcompare Paste Paste = runGComparing $ return GEQ

348+ gcompare Paste _ = GLT

349+ gcompare _ Paste = GGT

350+ gcompare Reset Reset = runGComparing $ return GEQ

351+ gcompare Reset _ = GLT

352+ gcompare _ Reset = GGT

353+ gcompare Search Search = runGComparing $ return GEQ

354+ gcompare Search _ = GLT

355+ gcompare _ Search = GGT

356+ gcompare Selectstart Selectstart = runGComparing $ return GEQ

357+ gcompare Selectstart _ = GLT

358+ gcompare _ Selectstart = GGT

359+ gcompare Touchstart Touchstart = runGComparing $ return GEQ

360+ gcompare Touchstart _ = GLT

361+ gcompare _ Touchstart = GGT

362+ gcompare Touchmove Touchmove = runGComparing $ return GEQ

363+ gcompare Touchmove _ = GLT

364+ gcompare _ Touchmove = GGT

365+ gcompare Touchend Touchend = runGComparing $ return GEQ

366+ gcompare Touchend _ = GLT

367+ gcompare _ Touchend = GGT

368+ gcompare Touchcancel Touchcancel = runGComparing $ return GEQ

369+ gcompare Touchcancel _ = GLT

370+ gcompare _ Touchcancel = GGT

371+#endif

src/Reflex/Dom/Builder/Immediate.hs → reflex-dom-core/src/Reflex/Dom/Builder/Immediate.hsrenamed+220−122

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE ConstraintKinds #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE EmptyDataDecls #-}

@@ -11,7 +12,9 @@

1112{-# LANGUAGE RankNTypes #-}

1213{-# LANGUAGE RecursiveDo #-}

1314{-# LANGUAGE ScopedTypeVariables #-}

15+#ifdef USE_TEMPLATE_HASKELL

1416{-# LANGUAGE TemplateHaskell #-}

17+#endif

1518{-# LANGUAGE TypeFamilies #-}

1619{-# LANGUAGE TypeOperators #-}

1720{-# LANGUAGE UndecidableInstances #-}

@@ -34,6 +37,9 @@ import Control.Monad.Primitive

3437import Control.Monad.Reader

3538import Control.Monad.Ref

3639import Control.Monad.Trans.Control

40+#ifndef USE_TEMPLATE_HASKELL

41+import Data.Functor.Contravariant (phantom)

42+#endif

3743import Data.Bitraversable

3844import Data.Default

3945import Data.Dependent.Map (DMap)

@@ -48,7 +54,7 @@ import Data.Monoid

4854import Data.Some (Some)

4955import qualified Data.Some as Some

5056import Data.Text (Text)

51−import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode)

57+import GHCJS.DOM.Document (Document, createDocumentFragmentUnchecked, createElementUnchecked, createElementNSUnchecked, createTextNodeUnchecked)

5258import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)

5359import qualified GHCJS.DOM.Element as Element

5460import qualified GHCJS.DOM.Event as Event

@@ -59,15 +65,17 @@ import qualified GHCJS.DOM.HTMLInputElement as Input

5965import qualified GHCJS.DOM.HTMLSelectElement as Select

6066import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea

6167import GHCJS.DOM.MouseEvent

62−import GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling, removeChild,

68+import GHCJS.DOM.Node (appendChild_, getOwnerDocumentUnchecked, getParentNodeUnchecked,

6369 setNodeValue, toNode)

64−import qualified GHCJS.DOM.Node as DOM

65−import GHCJS.DOM.Types (FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node, ToDOMString, TouchEvent,

66− WheelEvent, castToHTMLInputElement, castToHTMLSelectElement,

67− castToHTMLTextAreaElement)

70+import qualified GHCJS.DOM.Node as DOM (insertBefore_)

71+import GHCJS.DOM.Types

72+ (liftJSM, askJSM, runJSM, JSM, MonadJSM(..),

73+ FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node,

74+ ToDOMString, TouchEvent, WheelEvent, uncheckedCastTo)

6875import qualified GHCJS.DOM.Types as DOM

6976import GHCJS.DOM.UIEvent

7077import qualified GHCJS.DOM.Window as Window

78+import Language.Javascript.JSaddle (call, eval)

7179

7280import Debug.Trace hiding (traceEvent)

7381

@@ -81,6 +89,11 @@ data ImmediateDomBuilderEnv t

8189

8290newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)

8391

92+#ifndef __GHCJS__

93+instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where

94+ liftJSM' = ImmediateDomBuilderT . liftJSM'

95+#endif

96+

8497instance PrimMonad m => PrimMonad (ImmediateDomBuilderT x m) where

8598 type PrimState (ImmediateDomBuilderT x m) = PrimState m

8699 primitive = lift . primitive

@@ -110,64 +123,81 @@ askEvents :: Monad m => ImmediateDomBuilderT t m (Chan [DSum (TriggerRef t) Trig

110123askEvents = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_events

111124

112125{-# INLINABLE append #-}

113−append :: (IsNode n, MonadIO m) => n -> ImmediateDomBuilderT t m ()

126+append :: (IsNode n, MonadJSM m) => n -> ImmediateDomBuilderT t m ()

114127append n = do

115128 p <- askParent

116− _ <- liftIO $ appendChild p $ Just n

129+ liftJSM $ appendChild_ p $ Just n

117130 return ()

118131

119132{-# INLINABLE textNodeInternal #-}

120−textNodeInternal :: (MonadIO m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Text

133+textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Text

121134textNodeInternal t = do

122135 doc <- askDocument

123− Just n <- liftIO $ createTextNode doc t

136+ n <- liftJSM $ createTextNodeUnchecked doc t

124137 append n

125138 return n

126139

127−-- | s and e must both be children of the same node and s must precede e

140+-- | s and e must both be children of the same node and s must precede e;

141+-- s, e and all nodes between s and e will be removed

128142{-# INLINABLE deleteBetweenInclusive #-}

129−deleteBetweenInclusive :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m ()

130−deleteBetweenInclusive s e = do

131− mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment

132− case mCurrentParent of

133− Nothing -> return () --TODO: Is this the right behavior?

134− Just currentParent -> do

135− deleteUpToGivenParent currentParent s e

136− _ <- removeChild currentParent $ Just e

137− return ()

138−

139−-- | s and e must both be children of the same node and s must precede e

140−deleteBetweenExclusive :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m ()

141−deleteBetweenExclusive s e = do

142− mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment

143− case mCurrentParent of

144− Nothing -> return () --TODO: Is this the right behavior?

145− Just currentParent -> do

146− let go = do

147− Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first

148− when (toNode s /= toNode x) $ do

149− _ <- removeChild currentParent $ Just x

150− go

151− go

152−

153−-- | s and e must both be children of the same node and s must precede e; s and all nodes between s and e will be removed, but e will not be removed

143+deleteBetweenInclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()

144+deleteBetweenInclusive s e = liftJSM $ do

145+ f <- eval ("(function(s,e){ \

146+ p = e.parentNode; \

147+ if(p !== null) { \

148+ for(;;){ \

149+ x = e.previousSibling; \

150+ p.removeChild(x); \

151+ if(s===x) break; \

152+ } \

153+ p.removeChild(e); \

154+ }})" :: Text)

155+ void $ call f f (s, e)

156+

157+-- | s and e must both be children of the same node and s must precede e;

158+-- all nodes between s and e will be removed, but s and e will not be removed

159+deleteBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()

160+deleteBetweenExclusive s e = liftJSM $ do

161+ f <- eval ("(function(s,e){ \

162+ p = e.parentNode; \

163+ if(p !== null) { \

164+ for(;;){ \

165+ x = e.previousSibling; \

166+ if(s===x) break; \

167+ p.removeChild(x); \

168+ } \

169+ }})" :: Text)

170+ void $ call f f (s, e)

171+

172+-- | s and e must both be children of the same node and s must precede e;

173+-- s and all nodes between s and e will be removed, but e will not be removed

154174{-# INLINABLE deleteUpTo #-}

155−deleteUpTo :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m ()

156−deleteUpTo s e = do

157− mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment

158− case mCurrentParent of

159− Nothing -> return () --TODO: Is this the right behavior?

160− Just currentParent -> deleteUpToGivenParent currentParent s e

161−

175+deleteUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()

176+deleteUpTo s e = liftJSM $ do

177+ f <- eval ("(function(s,e){ \

178+ p = e.parentNode; \

179+ if(p !== null) { \

180+ for(;;) { \

181+ x = e.previousSibling; \

182+ p.removeChild(x); \

183+ if(s===x) break; \

184+ } \

185+ }})" :: Text)

186+ void $ call f f (s, e)

187+

188+-- | s and all nodes between s and e will be removed, but e will not be removed

162189{-# INLINABLE deleteUpToGivenParent #-}

163−deleteUpToGivenParent :: (MonadIO m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m ()

164−deleteUpToGivenParent currentParent s e = do

165− fix $ \loop -> do

166− Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first

167− _ <- removeChild currentParent $ Just x

168− when (toNode s /= toNode x) loop

169−

170−type SupportsImmediateDomBuilder t m = (Reflex t, MonadIO m, MonadIO (Performable m), MonadHold t m, MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO, MonadAdjust t m)

190+deleteUpToGivenParent :: (MonadJSM m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m ()

191+deleteUpToGivenParent currentParent s e = liftJSM $ do

192+ f <- eval ("(function(p,s,e){ \

193+ for(;;){ \

194+ x = e.previousSibling; \

195+ p.removeChild(x); \

196+ if(s===x) break; \

197+ }})" :: Text)

198+ void $ call f f (currentParent, s, e)

199+

200+type SupportsImmediateDomBuilder t m = (Reflex t, MonadJSM m, MonadJSM (Performable m), MonadHold t m, MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref JSM, MonadAdjust t m)

171201

172202newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))

173203

@@ -177,35 +207,37 @@ wrap e cfg = do

177207 lift $ performEvent_ $ ffor (cfg ^. modifyAttributes) $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of

178208 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv

179209 Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv

180− eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftIO $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do

181− triggerRef <- newIORef Nothing

210+ eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftJSM $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do

211+ triggerRef <- liftIO $ newIORef Nothing

182212 _ <- elementOnEventName en e $ do

183213 evt <- DOM.event

184− (flags, k) <- liftIO $ f $ GhcjsDomEvent evt

214+ (flags, k) <- liftJSM $ f $ GhcjsDomEvent evt

185215 when (_eventFlags_preventDefault flags) $ withIsEvent en DOM.preventDefault

186216 case _eventFlags_propagation flags of

187217 Propagation_Continue -> return ()

188218 Propagation_Stop -> withIsEvent en DOM.stopPropagation

189219 Propagation_StopImmediate -> withIsEvent en DOM.stopImmediatePropagation

190− mv <- liftIO k --TODO: Only do this when the event is subscribed

220+ mv <- liftJSM k --TODO: Only do this when the event is subscribed

191221 liftIO $ forM_ mv $ \v -> writeChan events [TriggerRef triggerRef :=> TriggerInvocation v (return ())]

192222 return $ en :=> EventFilterTriggerRef triggerRef

193− es <- newFanEventWithTrigger $ \(WrapArg en) t -> do

194− case DMap.lookup en eventTriggerRefs of

195− Just (EventFilterTriggerRef r) -> do

196− writeIORef r $ Just t

197− return $ do

198− writeIORef r Nothing

199− Nothing -> elementOnEventName en e $ do

200− evt <- DOM.event

201− let h = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg

202− mv <- liftIO $ h (en, GhcjsDomEvent evt)

203− case mv of

204− Nothing -> return ()

205− Just v -> liftIO $ do

206− --TODO: I don't think this is quite right: if a new trigger is created between when this is enqueued and when it fires, this may not work quite right

207− ref <- newIORef $ Just t

208− writeChan events [TriggerRef ref :=> TriggerInvocation v (return ())]

223+ es <- do

224+ ctx <- askJSM

225+ newFanEventWithTrigger $ \(WrapArg en) t ->

226+ case DMap.lookup en eventTriggerRefs of

227+ Just (EventFilterTriggerRef r) -> do

228+ writeIORef r $ Just t

229+ return $ do

230+ writeIORef r Nothing

231+ Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do

232+ evt <- DOM.event

233+ let h = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg

234+ mv <- lift $ h (en, GhcjsDomEvent evt)

235+ case mv of

236+ Nothing -> return ()

237+ Just v -> liftIO $ do

238+ --TODO: I don't think this is quite right: if a new trigger is created between when this is enqueued and when it fires, this may not work quite right

239+ ref <- newIORef $ Just t

240+ writeChan events [TriggerRef ref :=> TriggerInvocation v (return ())])

209241 return $ Element es e

210242

211243{-# INLINABLE makeElement #-}

@@ -213,12 +245,12 @@ makeElement :: forall er t m a. SupportsImmediateDomBuilder t m => Text -> Eleme

213245makeElement elementTag cfg child = do

214246 doc <- askDocument

215247 events <- askEvents

216− Just e <- ImmediateDomBuilderT $ fmap DOM.castToElement <$> case cfg ^. namespace of

217− Nothing -> createElement doc (Just elementTag)

218− Just ens -> createElementNS doc (Just ens) (Just elementTag)

248+ e <- liftJSM $ case cfg ^. namespace of

249+ Nothing -> createElementUnchecked doc (Just elementTag)

250+ Just ens -> createElementNSUnchecked doc (Just ens) (Just elementTag)

219251 ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of

220− Nothing -> setAttribute e n v

221− Just ans -> setAttributeNS e (Just ans) n v

252+ Nothing -> lift $ setAttribute e n v

253+ Just ans -> lift $ setAttributeNS e (Just ans) n v

222254 result <- lift $ runImmediateDomBuilderT child $ ImmediateDomBuilderEnv

223255 { _immediateDomBuilderEnv_parent = toNode e

224256 , _immediateDomBuilderEnv_document = doc

@@ -228,9 +260,9 @@ makeElement elementTag cfg child = do

228260 wrapped <- wrap e $ extractRawElementConfig cfg

229261 return ((wrapped, result), e)

230262

231−newtype GhcjsDomHandler a b = GhcjsDomHandler { unGhcjsDomHandler :: a -> IO b }

263+newtype GhcjsDomHandler a b = GhcjsDomHandler { unGhcjsDomHandler :: a -> JSM b }

232264

233−newtype GhcjsDomHandler1 a b = GhcjsDomHandler1 { unGhcjsDomHandler1 :: forall (x :: EventTag). a x -> IO (b x) }

265+newtype GhcjsDomHandler1 a b = GhcjsDomHandler1 { unGhcjsDomHandler1 :: forall (x :: EventTag). a x -> JSM (b x) }

234266

235267newtype GhcjsDomEvent en = GhcjsDomEvent { unGhcjsDomEvent :: EventType en }

236268

@@ -258,7 +290,7 @@ instance DomSpace GhcjsDomSpace where

258290 in DMap.alter f' en $ _ghcjsEventSpec_filters es

259291 }

260292

261−newtype GhcjsEventFilter er en = GhcjsEventFilter (GhcjsDomEvent en -> IO (EventFlags, IO (Maybe (er en))))

293+newtype GhcjsEventFilter er en = GhcjsEventFilter (GhcjsDomEvent en -> JSM (EventFlags, JSM (Maybe (er en))))

262294

263295data Pair1 (f :: k -> *) (g :: k -> *) (a :: k) = Pair1 (f a) (g a)

264296

@@ -266,15 +298,29 @@ data Maybe1 f a = Nothing1 | Just1 (f a)

266298

267299data GhcjsEventSpec er = GhcjsEventSpec

268300 { _ghcjsEventSpec_filters :: DMap EventName (GhcjsEventFilter er)

269− , _ghcjsEventSpec_handler :: forall en. (EventName en, GhcjsDomEvent en) -> IO (Maybe (er en))

301+ , _ghcjsEventSpec_handler :: forall en. (EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en))

270302 }

271303

304+#ifndef USE_TEMPLATE_HASKELL

305+phantom2 :: (Functor f, Contravariant f) => f a -> f b

306+phantom2 = phantom

307+{-# INLINE phantom2 #-}

308+

309+ghcjsEventSpec_filters :: forall er . Lens' (GhcjsEventSpec er) (DMap EventName (GhcjsEventFilter er))

310+ghcjsEventSpec_filters f (GhcjsEventSpec a b) = (\a' -> GhcjsEventSpec a' b) <$> f a

311+{-# INLINE ghcjsEventSpec_filters #-}

312+ghcjsEventSpec_handler :: forall er en . Getter (GhcjsEventSpec er) ((EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)))

313+ghcjsEventSpec_handler f (GhcjsEventSpec _ b) = phantom2 (f b)

314+{-# INLINE ghcjsEventSpec_handler #-}

315+#endif

316+

272317instance er ~ EventResult => Default (GhcjsEventSpec er) where

273318 def = GhcjsEventSpec

274319 { _ghcjsEventSpec_filters = mempty

275320 , _ghcjsEventSpec_handler = \(en, GhcjsDomEvent evt) -> do

276− Just t <- withIsEvent en $ Event.getTarget evt --TODO: Rework this; defaultDomEventHandler shouldn't need to take this as an argument

277− runReaderT (defaultDomEventHandler (Element.castToElement t) en) evt

321+ t :: DOM.EventTarget <- withIsEvent en $ Event.getTargetUnchecked evt --TODO: Rework this; defaultDomEventHandler shouldn't need to take this as an argument

322+ let e = uncheckedCastTo DOM.Element t

323+ runReaderT (defaultDomEventHandler e en) evt

278324 }

279325

280326instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t m) where

@@ -300,9 +346,9 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

300346 {-# INLINABLE inputElement #-}

301347 inputElement cfg = do

302348 ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()

303− let domInputElement = castToHTMLInputElement domElement

349+ let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement

304350 Input.setValue domInputElement $ Just (cfg ^. inputElementConfig_initialValue)

305− Just v0 <- Input.getValue domInputElement

351+ v0 <- Input.getValueUnchecked domInputElement

306352 let getMyValue = fromMaybe "" <$> Input.getValue domInputElement

307353 valueChangedByUI <- performEvent $ getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)

308354 valueChangedBySetValue <- performEvent $ ffor (cfg ^. inputElementConfig_setValue) $ \v' -> do

@@ -317,10 +363,10 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

317363 Input.getChecked domInputElement

318364 checkedChangedBySetChecked <- performEvent $ ffor (_inputElementConfig_setChecked cfg) $ \newChecked -> do

319365 oldChecked <- Input.getChecked domInputElement

320− if newChecked /= oldChecked

321− then do Input.setChecked domInputElement newChecked

322− return $ Just newChecked

323− else return Nothing

366+ Input.setChecked domInputElement newChecked

367+ return $ if newChecked /= oldChecked

368+ then Just newChecked

369+ else Nothing

324370 c <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost

325371 [ fmapMaybe id checkedChangedBySetChecked

326372 , checkedChangedByUI

@@ -347,9 +393,9 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

347393 {-# INLINABLE textAreaElement #-}

348394 textAreaElement cfg = do --TODO

349395 ((e, _), domElement) <- makeElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()

350− let domTextAreaElement = castToHTMLTextAreaElement domElement

396+ let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement

351397 TextArea.setValue domTextAreaElement $ Just (cfg ^. textAreaElementConfig_initialValue)

352− Just v0 <- TextArea.getValue domTextAreaElement

398+ v0 <- TextArea.getValueUnchecked domTextAreaElement

353399 let getMyValue = fromMaybe "" <$> TextArea.getValue domTextAreaElement

354400 valueChangedByUI <- performEvent $ getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)

355401 valueChangedBySetValue <- performEvent $ ffor (cfg ^. textAreaElementConfig_setValue) $ \v' -> do

@@ -370,7 +416,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

370416 {-# INLINABLE selectElement #-}

371417 selectElement cfg child = do

372418 ((e, result), domElement) <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child

373− let domSelectElement = castToHTMLSelectElement domElement

419+ let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement

374420 Select.setValue domSelectElement $ Just (cfg ^. selectElementConfig_initialValue)

375421 Just v0 <- Select.getValue domSelectElement

376422 let getMyValue = fromMaybe "" <$> Select.getValue domSelectElement

@@ -394,18 +440,18 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t

394440 placeRawElement = append

395441 wrapRawElement = wrap

396442

397−instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, PerformEvent t m, MonadIO (Performable m)) => MonadAdjust t (ImmediateDomBuilderT t m) where

443+instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m)) => MonadAdjust t (ImmediateDomBuilderT t m) where

398444 runWithReplace a0 a' = do

399445 initialEnv <- ImmediateDomBuilderT ask

400446 before <- textNodeInternal ("" :: Text)

401447 -- We draw 'after' in this roundabout way to avoid using MonadFix

402− Just after <- createTextNode (_immediateDomBuilderEnv_document initialEnv) ("" :: Text)

448+ after <- createTextNodeUnchecked (_immediateDomBuilderEnv_document initialEnv) ("" :: Text)

403449 let drawInitialChild = do

404450 result <- a0

405451 append after

406452 return result

407453 (result0, result') <- lift $ runWithReplace (runImmediateDomBuilderT drawInitialChild initialEnv) $ ffor a' $ \child -> do

408− Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv

454+ df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv

409455 result <- runImmediateDomBuilderT child $ initialEnv

410456 { _immediateDomBuilderEnv_parent = toNode df

411457 }

@@ -419,7 +465,7 @@ instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, PerformEvent t m,

419465 drawChildInitial child = runImmediateDomBuilderT ((,,) <$> pure (error "sequenceDMapWithAdjust{ImmediateDomBuilderT}: drawChildInitial: DocumentFragment evaluated") <*> textNodeInternal ("" :: Text) <*> child) initialEnv --TODO: Don't return a DocumentFragment at all here; this will require that sequenceDMapWithAdjust accept differently-typed values for the constant and Event arguments.

420466 drawChildUpdate :: ImmediateDomBuilderT t m a -> m (DOM.DocumentFragment, DOM.Text, a)

421467 drawChildUpdate child = do

422− Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv

468+ df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv

423469 runImmediateDomBuilderT ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child) $ initialEnv

424470 { _immediateDomBuilderEnv_parent = toNode df

425471 }

@@ -454,12 +500,12 @@ mkHasFocus e = do

454500 ]

455501

456502{-# INLINABLE insertImmediateAbove #-}

457−insertImmediateAbove :: (IsNode placeholder, PerformEvent t m, MonadIO (Performable m)) => placeholder -> Event t (ImmediateDomBuilderT t (Performable m) a) -> ImmediateDomBuilderT t m (Event t a)

503+insertImmediateAbove :: (IsNode placeholder, PerformEvent t m, MonadJSM (Performable m)) => placeholder -> Event t (ImmediateDomBuilderT t (Performable m) a) -> ImmediateDomBuilderT t m (Event t a)

458504insertImmediateAbove n toInsertAbove = do

459505 events <- askEvents

460506 lift $ performEvent $ ffor toInsertAbove $ \new -> do

461− Just doc <- getOwnerDocument n

462− Just df <- createDocumentFragment doc

507+ doc <- getOwnerDocumentUnchecked n

508+ df <- createDocumentFragmentUnchecked doc

463509 result <- runImmediateDomBuilderT new $ ImmediateDomBuilderEnv

464510 { _immediateDomBuilderEnv_parent = toNode df

465511 , _immediateDomBuilderEnv_document = doc

@@ -468,12 +514,10 @@ insertImmediateAbove n toInsertAbove = do

468514 df `insertBefore` n

469515 return result

470516

471−insertBefore :: (MonadIO m, IsNode new, IsNode existing) => new -> existing -> m ()

517+insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()

472518insertBefore new existing = do

473− mp <- getParentNode existing

474− case mp of

475− Nothing -> trace "ImmediateDomBuilderT: placeholder: Warning: (getParentNode n) returned Nothing" $ return ()

476− Just p -> void $ DOM.insertBefore p (Just new) (Just existing) -- If there's no parent, that means we've been removed from the DOM; this should not happen if the we're removing ourselves from the performEvent properly

519+ p <- getParentNodeUnchecked existing

520+ DOM.insertBefore_ p (Just new) (Just existing) -- If there's no parent, that means we've been removed from the DOM; this should not happen if the we're removing ourselves from the performEvent properly

477521

478522instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where

479523 type Performable (ImmediateDomBuilderT t m) = Performable m

@@ -501,17 +545,17 @@ instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) =>

501545 newTriggerEventWithOnComplete = do

502546 events <- askEvents

503547 (eResult, reResultTrigger) <- lift newEventWithTriggerRef

504− return $ (,) eResult $ \a cb -> writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a cb]

548+ return $ (,) eResult $ \a cb -> writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a (liftIO cb)]

505549 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}

506550 newEventWithLazyTriggerWithOnComplete f = do

507551 events <- askEvents

508552 lift $ newEventWithTrigger $ \t -> f $ \a cb -> do

509553 reResultTrigger <- newIORef $ Just t

510− writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a cb]

554+ writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a (liftIO cb)]

511555

512−instance HasWebView m => HasWebView (ImmediateDomBuilderT t m) where

513− type WebViewPhantom (ImmediateDomBuilderT t m) = WebViewPhantom m

514− askWebView = lift askWebView

556+instance HasJSContext m => HasJSContext (ImmediateDomBuilderT t m) where

557+ type JSContextPhantom (ImmediateDomBuilderT t m) = JSContextPhantom m

558+ askJSContext = lift askJSContext

515559

516560instance MonadRef m => MonadRef (ImmediateDomBuilderT t m) where

517561 type Ref (ImmediateDomBuilderT t m) = Ref m

@@ -527,7 +571,7 @@ instance MonadAtomicRef m => MonadAtomicRef (ImmediateDomBuilderT t m) where

527571 atomicModifyRef r = lift . atomicModifyRef r

528572

529573instance (HasJS x m, ReflexHost t) => HasJS x (ImmediateDomBuilderT t m) where

530− type JSM (ImmediateDomBuilderT t m) = JSM m

574+ type JSX (ImmediateDomBuilderT t m) = JSX m

531575 liftJS = lift . liftJS

532576

533577type family EventType en where

@@ -728,8 +772,57 @@ withIsEvent en r = case en of

728772 Mousewheel -> r

729773 Wheel -> r

730774

775+showEventName :: EventName en -> String

776+showEventName en = case en of

777+ Abort -> "Abort"

778+ Blur -> "Blur"

779+ Change -> "Change"

780+ Click -> "Click"

781+ Contextmenu -> "Contextmenu"

782+ Dblclick -> "Dblclick"

783+ Drag -> "Drag"

784+ Dragend -> "Dragend"

785+ Dragenter -> "Dragenter"

786+ Dragleave -> "Dragleave"

787+ Dragover -> "Dragover"

788+ Dragstart -> "Dragstart"

789+ Drop -> "Drop"

790+ Error -> "Error"

791+ Focus -> "Focus"

792+ Input -> "Input"

793+ Invalid -> "Invalid"

794+ Keydown -> "Keydown"

795+ Keypress -> "Keypress"

796+ Keyup -> "Keyup"

797+ Load -> "Load"

798+ Mousedown -> "Mousedown"

799+ Mouseenter -> "Mouseenter"

800+ Mouseleave -> "Mouseleave"

801+ Mousemove -> "Mousemove"

802+ Mouseout -> "Mouseout"

803+ Mouseover -> "Mouseover"

804+ Mouseup -> "Mouseup"

805+ Mousewheel -> "Mousewheel"

806+ Scroll -> "Scroll"

807+ Select -> "Select"

808+ Submit -> "Submit"

809+ Wheel -> "Wheel"

810+ Beforecut -> "Beforecut"

811+ Cut -> "Cut"

812+ Beforecopy -> "Beforecopy"

813+ Copy -> "Copy"

814+ Beforepaste -> "Beforepaste"

815+ Paste -> "Paste"

816+ Reset -> "Reset"

817+ Search -> "Search"

818+ Selectstart -> "Selectstart"

819+ Touchstart -> "Touchstart"

820+ Touchmove -> "Touchmove"

821+ Touchend -> "Touchend"

822+ Touchcancel -> "Touchcancel"

823+

731824{-# INLINABLE elementOnEventName #-}

732−elementOnEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> IO (IO ())

825+elementOnEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> JSM (JSM ())

733826elementOnEventName en e = case en of

734827 Abort -> on e Element.abort

735828 Blur -> on e Element.blurEvent

@@ -779,7 +872,7 @@ elementOnEventName en e = case en of

779872 Touchcancel -> on e Element.touchCancel

780873

781874{-# INLINABLE windowOnEventName #-}

782−windowOnEventName :: EventName en -> DOM.Window -> EventM DOM.Window (EventType en) () -> IO (IO ())

875+windowOnEventName :: EventName en -> DOM.Window -> EventM DOM.Window (EventType en) () -> JSM (JSM ())

783876windowOnEventName en e = case en of

784877 Abort -> on e Window.abort

785878 Blur -> on e Window.blurEvent

@@ -829,15 +922,15 @@ windowOnEventName en e = case en of

829922 Touchcancel -> on e Window.touchCancel

830923

831924{-# INLINABLE wrapDomEvent #-}

832−wrapDomEvent :: TriggerEvent t m => e -> (e -> EventM e event () -> IO (IO ())) -> EventM e event a -> m (Event t a)

925+wrapDomEvent :: (TriggerEvent t m, MonadJSM m) => e -> (e -> EventM e event () -> JSM (JSM ())) -> EventM e event a -> m (Event t a)

833926wrapDomEvent el elementOnevent getValue = wrapDomEventMaybe el elementOnevent $ fmap Just getValue

834927

835928{-# INLINABLE subscribeDomEvent #-}

836−subscribeDomEvent :: (EventM e event () -> IO (IO ()))

929+subscribeDomEvent :: (EventM e event () -> JSM (JSM ()))

837930 -> EventM e event (Maybe a)

838931 -> Chan [DSum (TriggerRef t) TriggerInvocation]

839932 -> EventTrigger t a

840− -> IO (IO ())

933+ -> JSM (JSM ())

841934subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do

842935 mv <- getValue

843936 forM_ mv $ \v -> liftIO $ do

@@ -846,25 +939,28 @@ subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do

846939 writeChan eventChan [TriggerRef etr :=> TriggerInvocation v (return ())]

847940

848941{-# INLINABLE wrapDomEventMaybe #-}

849−wrapDomEventMaybe :: TriggerEvent t m

942+wrapDomEventMaybe :: (TriggerEvent t m, MonadJSM m)

850943 => e

851− -> (e -> EventM e event () -> IO (IO ()))

944+ -> (e -> EventM e event () -> JSM (JSM ()))

852945 -> EventM e event (Maybe a)

853946 -> m (Event t a)

854947wrapDomEventMaybe el elementOnevent getValue = do

855− newEventWithLazyTriggerWithOnComplete $ \trigger -> elementOnevent el $ do

948+ ctx <- askJSM

949+ newEventWithLazyTriggerWithOnComplete $ \trigger -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnevent el $ do

856950 mv <- getValue

857− forM_ mv $ \v -> liftIO $ trigger v $ return ()

951+ forM_ mv $ \v -> liftIO $ trigger v $ return ())

858952

859953{-# INLINABLE wrapDomEventsMaybe #-}

860−wrapDomEventsMaybe :: (MonadIO m, MonadReflexCreateTrigger t m)

954+wrapDomEventsMaybe :: (MonadJSM m, MonadReflexCreateTrigger t m)

861955 => e

862956 -> (forall en. IsEvent (EventType en) => EventName en -> EventM e (EventType en) (Maybe (f en)))

863− -> (forall en. EventName en -> e -> EventM e (EventType en) () -> IO (IO ()))

957+ -> (forall en. EventName en -> e -> EventM e (EventType en) () -> JSM (JSM ()))

864958 -> ImmediateDomBuilderT t m (EventSelector t (WrapArg f EventName))

865959wrapDomEventsMaybe target handlers onEventName = do

960+ ctx <- askJSM

866961 eventChan <- askEvents

867− e <- lift $ newFanEventWithTrigger $ \(WrapArg en) -> withIsEvent en $ subscribeDomEvent (onEventName en target) (handlers en) eventChan

962+ e <- lift $ newFanEventWithTrigger $ \(WrapArg en) -> withIsEvent en

963+ (((`runJSM` ctx) <$>) . (`runJSM` ctx) . subscribeDomEvent (onEventName en target) (handlers en) eventChan)

868964 return $! e

869965

870966{-# INLINABLE getKeyEvent #-}

@@ -905,7 +1001,7 @@ data Window t = Window

9051001 , _window_raw :: DOM.Window

9061002 }

9071003

908−wrapWindow :: (MonadIO m, MonadReflexCreateTrigger t m) => DOM.Window -> WindowConfig t -> ImmediateDomBuilderT t m (Window t)

1004+wrapWindow :: (MonadJSM m, MonadReflexCreateTrigger t m) => DOM.Window -> WindowConfig t -> ImmediateDomBuilderT t m (Window t)

9091005wrapWindow wv _ = do

9101006 events <- wrapDomEventsMaybe wv (defaultDomWindowEventHandler wv) windowOnEventName

9111007 return $ Window

@@ -913,4 +1009,6 @@ wrapWindow wv _ = do

9131009 , _window_raw = wv

9141010 }

9151011

1012+#ifdef USE_TEMPLATE_HASKELL

9161013makeLenses ''GhcjsEventSpec

1014+#endif

src/Reflex/Dom/Builder/InputDisabled.hs → reflex-dom-core/src/Reflex/Dom/Builder/InputDisabled.hsrenamed+4−4

@@ -84,10 +84,10 @@ instance DomBuilder t m => DomBuilder t (InputDisabledT m) where

8484 }

8585 lift $ selectElement cfg' $ runInputDisabledT child

8686

87−instance HasWebView m => HasWebView (InputDisabledT m) where

88− type WebViewPhantom (InputDisabledT m) = WebViewPhantom m

89− askWebView = lift askWebView

87+instance HasJSContext m => HasJSContext (InputDisabledT m) where

88+ type JSContextPhantom (InputDisabledT m) = JSContextPhantom m

89+ askJSContext = lift askJSContext

9090

9191instance HasJS js m => HasJS js (InputDisabledT m) where

92− type JSM (InputDisabledT m) = JSM m

92+ type JSX (InputDisabledT m) = JSX m

9393 liftJS = lift . liftJS

src/Reflex/Dom/Builder/Static.hs → reflex-dom-core/src/Reflex/Dom/Builder/Static.hsrenamed

The content is the same.

src/Reflex/Dom/Class.hs → reflex-dom-core/src/Reflex/Dom/Class.hsrenamed

The content is the same.

src/Reflex/Dom.hs → reflex-dom-core/src/Reflex/Dom/Core.hsrenamed+2−2

@@ -1,4 +1,4 @@

1−module Reflex.Dom (module X) where

1+module Reflex.Dom.Core (module X) where

33import Reflex as X hiding (askEvents)

44import Reflex.Dom.Builder.Class as X

@@ -6,8 +6,8 @@ import Reflex.Dom.Builder.Immediate as X

66import Reflex.Dom.Builder.InputDisabled as X

77import Reflex.Dom.Builder.Static as X

88import Reflex.Dom.Class as X

9−import Reflex.Dom.Internal as X

109import Reflex.Dom.Location as X

10+import Reflex.Dom.Main as X

1111import Reflex.Dom.Old as X

1212import Reflex.Dom.Time as X

1313import Reflex.Dom.WebSocket as X

reflex-dom-core/src/Reflex/Dom/Location.hsnew file+13

@@ -0,0 +1,13 @@

1+module Reflex.Dom.Location (getLocationHost, getLocationProtocol) where

3+import Data.Text (Text)

4+import GHCJS.DOM.Types (MonadJSM)

5+import GHCJS.DOM (currentWindowUnchecked)

6+import GHCJS.DOM.Window (getLocationUnchecked)

7+import GHCJS.DOM.Location (getProtocol, getHost)

9+getLocationHost :: (MonadJSM m) => m Text

10+getLocationHost = currentWindowUnchecked >>= getLocationUnchecked >>= getHost

11+

12+getLocationProtocol :: (MonadJSM m) => m Text

13+getLocationProtocol = currentWindowUnchecked >>= getLocationUnchecked >>= getProtocol

src/Reflex/Dom/Internal.hs → reflex-dom-core/src/Reflex/Dom/Main.hsrenamed+77−54

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE ConstraintKinds #-}

23{-# LANGUAGE FlexibleContexts #-}

34{-# LANGUAGE FlexibleInstances #-}

@@ -11,14 +12,14 @@

1112{-# LANGUAGE TypeFamilies #-}

1213{-# LANGUAGE TypeOperators #-}

1314{-# LANGUAGE UndecidableInstances #-}

14−module Reflex.Dom.Internal where

15+{-# LANGUAGE PatternSynonyms #-}

16+module Reflex.Dom.Main where

1517

1618import Prelude hiding (concat, mapM, mapM_, sequence, sequence_)

1719

1820import qualified Reflex as R

1921import Reflex.Dom.Builder.Immediate

2022import Reflex.Dom.Class

21−import Reflex.Dom.Internal.Foreign

2223import Reflex.Host.Class

2324import Reflex.PerformEvent.Base

2425import Reflex.PostBuild.Base

@@ -38,74 +39,91 @@ import Data.Monoid ((<>))

3839import Data.Text (Text)

3940import qualified Data.Text as T

4041import Data.Text.Encoding

41−import GHCJS.DOM hiding (runWebGUI)

42+import GHCJS.DOM

4243import GHCJS.DOM.Document

4344import GHCJS.DOM.Element

4445import GHCJS.DOM.Node

4546import qualified GHCJS.DOM.Types as DOM

47+import GHCJS.DOM.Types (MonadJSM(..), JSM)

4648

4749{-# INLINABLE mainWidget #-}

48−mainWidget :: (forall x. Widget x ()) -> IO ()

49−mainWidget w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do

50− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView

51− Just body <- getBody doc

52− attachWidget body webViewSing w

50+mainWidget :: (forall x. Widget x ()) -> JSM ()

51+mainWidget w = withJSContextSingleton $ \jsSing -> do

52+ doc <- currentDocumentUnchecked

53+ body <- getBodyUnchecked doc

54+ attachWidget body jsSing w

55+ forever $ do

56+ liftIO $ threadDelay 100000

57+ syncPoint

5358

5459--TODO: The x's should be unified here

5560{-# INLINABLE mainWidgetWithHead #-}

56−mainWidgetWithHead :: (forall x. Widget x ()) -> (forall x. Widget x ()) -> IO ()

57−mainWidgetWithHead h b = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do

58− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView

59− Just headElement <- fmap DOM.castToHTMLElement <$> getHead doc

60− attachWidget headElement webViewSing h

61− Just body <- getBody doc

62− attachWidget body webViewSing b

61+mainWidgetWithHead :: (forall x. Widget x ()) -> (forall x. Widget x ()) -> JSM ()

62+mainWidgetWithHead h b = withJSContextSingleton $ \jsSing -> do

63+ doc <- currentDocumentUnchecked

64+ headElement <- getHeadUnchecked doc

65+ attachWidget headElement jsSing h

66+ body <- getBodyUnchecked doc

67+ attachWidget body jsSing b

68+ forever $ do

69+ liftIO $ threadDelay 100000

70+ syncPoint

6371

6472{-# INLINABLE mainWidgetWithCss #-}

65−mainWidgetWithCss :: ByteString -> (forall x. Widget x ()) -> IO ()

66−mainWidgetWithCss css w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do

67− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView

68− Just headElement <- fmap DOM.castToHTMLElement <$> getHead doc

73+mainWidgetWithCss :: ByteString -> (forall x. Widget x ()) -> JSM ()

74+mainWidgetWithCss css w = withJSContextSingleton $ \jsSing -> do

75+ doc <- currentDocumentUnchecked

76+ headElement <- getHeadUnchecked doc

6977 setInnerHTML headElement . Just $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this

70− Just body <- getBody doc

71− attachWidget body webViewSing w

78+ body <- getBodyUnchecked doc

79+ attachWidget body jsSing w

80+ forever $ do

81+ liftIO $ threadDelay 100000

82+ syncPoint

7283

73−type Widget x = PostBuildT Spider (ImmediateDomBuilderT Spider (WithWebView x (PerformEventT Spider (SpiderHost Global)))) --TODO: Make this more abstract --TODO: Put the WithWebView underneath PerformEventT - I think this would perform better

84+type Widget x = PostBuildT Spider (ImmediateDomBuilderT Spider (WithJSContextSingleton x (PerformEventT Spider (SpiderHost Global)))) --TODO: Make this more abstract --TODO: Put the WithJSContext underneath PerformEventT - I think this would perform better

7485

75−{-# INLINABLE attachWidget #-}

76−attachWidget :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO a

77−attachWidget rootElement wv w = fst <$> attachWidget' rootElement wv w

86+#ifndef __GHCJS__

87+instance MonadJSM m => MonadJSM (PostBuildT t m) where

88+ liftJSM' = PostBuildT . liftJSM'

89+#endif

7890

79−mainWidgetWithHead' :: (forall x. (a -> Widget x b, b -> Widget x a)) -> IO ()

80−mainWidgetWithHead' widgets = runWebGUI $ \webView -> withWebViewSingleton webView $ \wv -> fmap fst $ attachWidget'' $ \events -> do

91+{-# INLINABLE attachWidget #-}

92+attachWidget :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> JSM a

93+attachWidget rootElement wv w = liftIO $ fst <$> attachWidget' rootElement wv w

94+

95+mainWidgetWithHead' :: (forall x. (a -> Widget x b, b -> Widget x a)) -> JSM ()

96+mainWidgetWithHead' widgets = withJSContextSingleton $ \jsSing -> do

97+ doc <- currentDocumentUnchecked

98+ headElement <- getHeadUnchecked doc

99+ bodyElement <- getBodyUnchecked doc

100+-- runWebGUI $ \webView -> withWebViewSingleton webView $ \wv ->

101+ liftIO $ fmap fst $ attachWidget'' $ \events -> do

81102 let (headWidget, bodyWidget) = widgets

82− Just doc <- liftIO $ fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView

83− Just headElement <- getHead doc

84− Just bodyElement <- getBody doc

85103 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

86− rec b <- unsafeReplaceElementContentsWithWidget events postBuild headElement wv $ headWidget a

87− a <- unsafeReplaceElementContentsWithWidget events postBuild bodyElement wv $ bodyWidget b

104+ rec b <- unsafeReplaceElementContentsWithWidget events postBuild headElement jsSing $ headWidget a

105+ a <- unsafeReplaceElementContentsWithWidget events postBuild bodyElement jsSing $ bodyWidget b

88106 return ((), postBuildTriggerRef)

89107

90−unsafeReplaceElementContentsWithWidget :: DOM.IsElement e => EventChannel -> R.Event Spider () -> e -> WebViewSingleton x -> Widget x a -> PerformEventT Spider (SpiderHost Global) a

91−unsafeReplaceElementContentsWithWidget events postBuild rootElement wv w = do

92− Just doc <- getOwnerDocument rootElement

93− Just df <- createDocumentFragment doc

108+unsafeReplaceElementContentsWithWidget :: DOM.IsElement e => EventChannel -> R.Event Spider () -> e -> JSContextSingleton x -> Widget x a -> PerformEventT Spider (SpiderHost Global) a

109+unsafeReplaceElementContentsWithWidget events postBuild rootElement jsSing w = (`runWithJSContextSingleton` jsSing) $ do

110+ doc <- getOwnerDocumentUnchecked rootElement

111+ df <- createDocumentFragmentUnchecked doc

94112 let builderEnv = ImmediateDomBuilderEnv

95113 { _immediateDomBuilderEnv_document = doc

96114 , _immediateDomBuilderEnv_parent = toNode df

97115 , _immediateDomBuilderEnv_events = events

98116 }

99− result <- runWithWebView (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) wv

117+ result <- runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv

100118 setInnerHTML rootElement $ Just ("" :: String)

101− _ <- appendChild rootElement $ Just df

119+ _ <- appendChildUnchecked rootElement $ Just df

102120 return result

103121

104122{-# INLINABLE attachWidget' #-}

105−attachWidget' :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO (a, FireCommand Spider (SpiderHost Global))

106−attachWidget' rootElement wv w = attachWidget'' $ \events -> do

123+attachWidget' :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> IO (a, FireCommand Spider (SpiderHost Global))

124+attachWidget' rootElement jsSing w = attachWidget'' $ \events -> do

107125 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef

108− result <- unsafeReplaceElementContentsWithWidget events postBuild rootElement wv w

126+ result <- unsafeReplaceElementContentsWithWidget events postBuild rootElement jsSing w

109127 return (result, postBuildTriggerRef)

110128

111129type EventChannel = Chan [DSum (TriggerRef Spider) TriggerInvocation]

@@ -121,7 +139,7 @@ attachWidget'' w = do

121139 return (result, fc)

122140 void $ forkIO $ forever $ do

123141 ers <- readChan events

124− _ <- postGUISync $ runSpiderHost $ do

142+ _ <- runSpiderHost $ do

125143 mes <- liftIO $ forM ers $ \(TriggerRef er :=> TriggerInvocation a _) -> do

126144 me <- readIORef er

127145 return $ fmap (\e -> e :=> Identity a) me

@@ -131,11 +149,14 @@ attachWidget'' w = do

131149 return (result, fc)

132150

133151-- | Run a reflex-dom application inside of an existing DOM element with the given ID

134−mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> IO ()

135−mainWidgetInElementById eid w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do

136− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView

137− Just root <- getElementById doc eid

138− attachWidget root webViewSing w

152+mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> JSM ()

153+mainWidgetInElementById eid w = withJSContextSingleton $ \jsSing -> do

154+ doc <- currentDocumentUnchecked

155+ root <- getElementByIdUnchecked doc eid

156+ attachWidget root jsSing w

157+ forever $ do

158+ liftIO $ threadDelay 100000

159+ syncPoint

139160

140161data AppInput t = AppInput

141162 { _appInput_window :: Window t

@@ -145,14 +166,16 @@ data AppOutput t = AppOutput --TODO: Add quit event

145166 { _appOutput_windowConfig :: WindowConfig t

146167 }

147168

148−runApp' :: (t ~ Spider) => (forall x. AppInput t -> Widget x (AppOutput t)) -> IO ()

149−runApp' app = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do

150− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView

151− Just body <- getBody doc

152− Just win <- getDefaultView doc

153− rec o <- attachWidget body webViewSing $ do

169+runApp' :: (t ~ Spider) => (forall x. AppInput t -> Widget x (AppOutput t)) -> JSM ()

170+runApp' app = withJSContextSingleton $ \jsSing -> do

171+ doc <- currentDocumentUnchecked

172+ body <- getBodyUnchecked doc

173+ win <- getDefaultViewUnchecked doc

174+ rec o <- attachWidget body jsSing $ do

154175 w <- lift $ wrapWindow win $ _appOutput_windowConfig o

155176 app $ AppInput

156177 { _appInput_window = w

157178 }

158− return ()

179+ forever $ do

180+ liftIO $ threadDelay 100000

181+ syncPoint

src/Reflex/Dom/Old.hs → reflex-dom-core/src/Reflex/Dom/Old.hsrenamed+36−20

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE ConstraintKinds #-}

23{-# LANGUAGE ExplicitForAll #-}

34{-# LANGUAGE FlexibleContexts #-}

@@ -5,9 +6,12 @@

56{-# LANGUAGE MultiParamTypeClasses #-}

67{-# LANGUAGE Rank2Types #-}

78{-# LANGUAGE ScopedTypeVariables #-}

8−{-# LANGUAGE TemplateHaskell #-}

99{-# LANGUAGE TypeFamilies #-}

1010{-# LANGUAGE UndecidableInstances #-}

11+{-# LANGUAGE LambdaCase #-}

12+#ifdef USE_TEMPLATE_HASKELL

13+{-# LANGUAGE TemplateHaskell #-}

14+#endif

1115module Reflex.Dom.Old

1216 ( MonadWidget

1317 , El

@@ -31,7 +35,6 @@ module Reflex.Dom.Old

3135 , elWith'

3236 , emptyElWith

3337 , emptyElWith'

34− , getQuitWidget

3538 , namedNodeMapGetNames

3639 , nodeClear

3740 , onEventName

@@ -43,7 +46,11 @@ module Reflex.Dom.Old

4346 ) where

4447

4548import Control.Arrow (first)

49+#ifdef USE_TEMPLATE_HASKELL

4650import Control.Lens (makeLenses, (%~), (&), (.~), (^.))

51+#else

52+import Control.Lens (Lens, Lens', (%~), (&), (.~), (^.))

53+#endif

4754import Control.Monad

4855import Control.Monad.Fix

4956import Control.Monad.IO.Class

@@ -62,13 +69,13 @@ import Foreign.JavaScript.TH

6269import qualified GHCJS.DOM.Element as Element

6370import GHCJS.DOM.EventM (EventM)

6471import GHCJS.DOM.NamedNodeMap as NNM

65−import GHCJS.DOM.Node (getFirstChild, getNodeName, removeChild)

66−import GHCJS.DOM.Types (IsElement, IsNode)

72+import GHCJS.DOM.Node (getFirstChild, getNodeName, getParentNode, getPreviousSibling, removeChildUnchecked)

73+import GHCJS.DOM.Types

74+ (MonadJSM, strictEqual, liftJSM, JSM, IsElement, IsNode)

6775import qualified GHCJS.DOM.Types as DOM

6876import Reflex.Class

6977import Reflex.Dom.Builder.Class

7078import Reflex.Dom.Builder.Immediate

71−import Reflex.Dom.Internal.Foreign

7279import Reflex.Dom.Widget.Basic

7380import Reflex.Host.Class

7481import Reflex.PerformEvent.Class

@@ -86,7 +93,16 @@ instance attrs ~ Map Text Text => Default (ElConfig attrs) where

8693 , _elConfig_attributes = mempty

8794 }

8895

96+#ifdef USE_TEMPLATE_HASKELL

8997makeLenses ''ElConfig

98+#else

99+elConfig_namespace :: Lens' (ElConfig attrs1) (Maybe Text)

100+elConfig_namespace f (ElConfig a b) = (\a' -> ElConfig a' b) <$> f a

101+{-# INLINE elConfig_namespace #-}

102+elConfig_attributes :: Lens (ElConfig attrs1) (ElConfig attrs2) attrs1 attrs2

103+elConfig_attributes f (ElConfig a b) = (\b' -> ElConfig a b') <$> f b

104+{-# INLINE elConfig_attributes #-}

105+#endif

90106

91107--TODO: HasDocument is still not accounted for

92108type MonadWidgetConstraints t m =

@@ -100,9 +116,13 @@ type MonadWidgetConstraints t m =

100116 , PerformEvent t m

101117 , MonadIO m

102118 , MonadIO (Performable m)

119+#ifndef ghcjs_HOST_OS

120+ , MonadJSM m

121+ , MonadJSM (Performable m)

122+#endif

103123 , TriggerEvent t m

104− , HasWebView m

105− , HasWebView (Performable m)

124+ , HasJSContext m

125+ , HasJSContext (Performable m)

106126 , MonadRef m

107127 , Ref m ~ Ref IO

108128 , MonadRef (Performable m)

@@ -159,7 +179,8 @@ addDynamicAttributes attrs cfg = do

159179buildElementCommon :: MonadWidget t m => Text -> m a -> ElementConfig er t m -> m (Element er (DomBuilderSpace m) t, a)

160180buildElementCommon elementTag child cfg = element elementTag cfg child

161181

162−onEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> IO (IO ())

182+

183+onEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> JSM (JSM ())

163184onEventName = elementOnEventName

164185

165186schedulePostBuild :: (PostBuild t m, PerformEvent t m) => WidgetHost m () -> m ()

@@ -211,7 +232,7 @@ _el_scrolled = domEvent Scroll

211232

212233wrapElement :: forall t m. MonadWidget t m => (forall en. DOM.Element -> EventName en -> EventM DOM.Element (EventType en) (Maybe (EventResult en))) -> DOM.Element -> m (El t)

213234wrapElement eh e = do

214− let h :: (EventName en, GhcjsDomEvent en) -> IO (Maybe (EventResult en))

235+ let h :: (EventName en, GhcjsDomEvent en) -> JSM (Maybe (EventResult en))

215236 h (en, GhcjsDomEvent evt) = runReaderT (eh e en) evt

216237 wrapRawElement e $ (def :: RawElementConfig EventResult t m)

217238 { _rawElementConfig_eventSpec = def

@@ -224,28 +245,23 @@ unsafePlaceElement e = do

224245 placeRawElement e

225246 wrapRawElement e def

226247

227−namedNodeMapGetNames :: DOM.NamedNodeMap -> IO (Set Text)

248+namedNodeMapGetNames :: DOM.NamedNodeMap -> JSM (Set Text)

228249namedNodeMapGetNames self = do

229250 l <- NNM.getLength self

230251 let locations = if l == 0 then [] else [0..l-1] -- Can't use 0..l-1 if l is 0 because l is unsigned and will wrap around

231252 fmap (Set.fromList . catMaybes) $ forM locations $ \i -> do

232− Just n <- NNM.item self i

253+ n <- NNM.itemUnchecked self i

233254 getNodeName n

234255

235−nodeClear :: IsNode self => self -> IO ()

256+nodeClear :: IsNode self => self -> JSM ()

236257nodeClear n = do

237258 mfc <- getFirstChild n

238259 case mfc of

239260 Nothing -> return ()

240261 Just fc -> do

241− _ <- removeChild n $ Just fc

262+ removeChildUnchecked n $ Just fc

242263 nodeClear n

243264

244−getQuitWidget :: MonadWidget t m => m (WidgetHost m ())

245−getQuitWidget = return $ do

246− WebViewSingleton wv <- askWebView

247− liftIO $ quitWebView wv

248−

249265elStopPropagationNS :: forall t m en a. (MonadWidget t m) => Maybe Text -> Text -> EventName en -> m a -> m a

250266elStopPropagationNS ns elementTag en child = do

251267 let f = GhcjsEventFilter $ \_ -> do

@@ -255,12 +271,12 @@ elStopPropagationNS ns elementTag en child = do

255271 & elementConfig_eventSpec . ghcjsEventSpec_filters %~ DMap.insert en f

256272 snd <$> element elementTag cfg child

257273

258−elDynHtmlAttr' :: MonadWidget t m => Text -> Map Text Text -> Dynamic t Text -> m (Element EventResult GhcjsDomSpace t)

274+elDynHtmlAttr' :: (DOM.MonadJSM m, MonadWidget t m) => Text -> Map Text Text -> Dynamic t Text -> m (Element EventResult GhcjsDomSpace t)

259275elDynHtmlAttr' elementTag attrs html = do

260276 let cfg = def & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs

261277 (e, _) <- element elementTag cfg $ return ()

262278 postBuild <- getPostBuild

263− performEvent_ $ Element.setInnerHTML (_element_raw e) . Just <$> leftmost [updated html, tag (current html) postBuild]

279+ performEvent_ $ liftJSM . Element.setInnerHTML (_element_raw e) . Just <$> leftmost [updated html, tag (current html) postBuild]

264280 return e

265281

266282elDynHtml' :: MonadWidget t m => Text -> Dynamic t Text -> m (Element EventResult GhcjsDomSpace t)

src/Reflex/Dom/Storage.hs → reflex-dom-core/src/Reflex/Dom/Storage.hsrenamed

The content is the same.

src/Reflex/Dom/Time.hs → reflex-dom-core/src/Reflex/Dom/Time.hsrenamed

The content is the same.

src/Reflex/Dom/WebSocket.hs → reflex-dom-core/src/Reflex/Dom/WebSocket.hsrenamed+39−19

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE AllowAmbiguousTypes #-}

23{-# LANGUAGE ConstraintKinds #-}

34{-# LANGUAGE DeriveDataTypeable #-}

@@ -15,7 +16,9 @@

1516{-# LANGUAGE RecursiveDo #-}

1617{-# LANGUAGE ScopedTypeVariables #-}

1718{-# LANGUAGE StandaloneDeriving #-}

19+#ifdef USE_TEMPLATE_HASKELL

1820{-# LANGUAGE TemplateHaskell #-}

21+#endif

1922{-# LANGUAGE TypeFamilies #-}

2023{-# LANGUAGE UndecidableInstances #-}

2124

@@ -32,7 +35,7 @@ import Reflex.TriggerEvent.Class

3235

3336import Control.Concurrent

3437import Control.Concurrent.STM

35−import Control.Exception (SomeException, catch)

38+import Control.Exception (SomeException)

3639import Control.Lens

3740import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)

3841import Control.Monad.IO.Class

@@ -42,6 +45,8 @@ import Data.Default

4245import Data.IORef

4346import Data.Maybe (isJust)

4447import Data.Text

48+import GHCJS.DOM.Types (runJSM, askJSM, MonadJSM, liftJSM, JSM)

49+import qualified Language.Javascript.JSaddle.Monad as JS (catch)

4550

4651data WebSocketConfig t a

4752 = WebSocketConfig { _webSocketConfig_send :: Event t [a]

@@ -72,12 +77,12 @@ instance (IsWebSocketMessage a, IsWebSocketMessage b) => IsWebSocketMessage (Eit

7277 webSocketSend jws (Right a) = webSocketSend jws a

7378

7479

75−webSocket :: (MonadIO m, MonadIO (Performable m), HasWebView m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> m (WebSocket t)

80+webSocket :: (MonadJSM m, MonadJSM (Performable m), HasJSContext m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> m (WebSocket t)

7681webSocket url config = webSocket' url config onBSMessage

7782

78−webSocket' :: (MonadIO m, MonadIO (Performable m), HasWebView m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> (Either ByteString JSVal -> b) -> m (RawWebSocket t b)

83+webSocket' :: (MonadJSM m, MonadJSM (Performable m), HasJSContext m, PerformEvent t m, TriggerEvent t m, PostBuild t m, IsWebSocketMessage a) => Text -> WebSocketConfig t a -> (Either ByteString JSVal -> JSM b) -> m (RawWebSocket t b)

7984webSocket' url config onRawMessage = do

80− wv <- fmap unWebViewSingleton askWebView

85+ wv <- fmap unJSContextSingleton askJSContext

8186 (eRecv, onMessage) <- newTriggerEvent

8287 currentSocketRef <- liftIO $ newIORef Nothing

8388 (eOpen, triggerEOpen) <- newTriggerEventWithOnComplete

@@ -88,27 +93,26 @@ webSocket' url config onRawMessage = do

8893 let onOpen = triggerEOpen () $ liftIO $ void $ atomically $ tryPutTMVar isOpen ()

8994 onError = triggerEError ()

9095 onClose args = do

91− triggerEClose args

92− --TODO: Is the fork necessary, or do event handlers run in their own threads automatically?

93− void $ forkIO $ do

94− _ <- liftIO $ atomically $ tryTakeTMVar isOpen

95− liftIO $ writeIORef currentSocketRef Nothing

96− when (_webSocketConfig_reconnect config) $ do

97− liftIO $ threadDelay 1000000

98− start

96+ liftIO $ triggerEClose args

97+ _ <- liftIO $ atomically $ tryTakeTMVar isOpen

98+ liftIO $ writeIORef currentSocketRef Nothing

99+ when (_webSocketConfig_reconnect config) $ do

100+ liftIO $ threadDelay 1000000

101+ start

99102 start = do

100− ws <- liftIO $ newWebSocket wv url (onMessage . onRawMessage) onOpen onError onClose

103+ ws <- newWebSocket wv url (onRawMessage >=> liftIO . onMessage) (liftIO onOpen) (liftIO onError) onClose

101104 liftIO $ writeIORef currentSocketRef $ Just ws

102105 return ()

103− performEvent_ . (liftIO start <$) =<< getPostBuild

106+ performEvent_ . (liftJSM start <$) =<< getPostBuild

104107 performEvent_ $ ffor (_webSocketConfig_send config) $ \payloads -> forM_ payloads $ \payload ->

105108 liftIO $ atomically $ writeTQueue payloadQueue payload

106− performEvent_ $ ffor (_webSocketConfig_close config) $ \(code,reason) -> liftIO $ do

107− mws <- readIORef currentSocketRef

109+ performEvent_ $ ffor (_webSocketConfig_close config) $ \(code,reason) -> liftJSM $ do

110+ mws <- liftIO $ readIORef currentSocketRef

108111 case mws of

109112 Nothing -> return ()

110113 Just ws -> closeWebSocket ws (fromIntegral code) reason

111114

115+ ctx <- askJSM

112116 _ <- liftIO $ forkIO $ forever $ do

113117 payload <- atomically $ do

114118 pl <- readTQueue payloadQueue

@@ -118,10 +122,26 @@ webSocket' url config onRawMessage = do

118122 mws <- liftIO $ readIORef currentSocketRef

119123 success <- case mws of

120124 Nothing -> return False

121− Just ws -> liftIO ((webSocketSend ws payload >> return True)

122− `catch`

123− (\(_ :: SomeException) -> return False))

125+ Just ws -> runJSM ((webSocketSend ws payload >> return True)

126+ `JS.catch`

127+ (\(_ :: SomeException) -> return False)) ctx

124128 unless success $ atomically $ unGetTQueue payloadQueue payload

125129 return $ RawWebSocket eRecv eOpen eError eClose

126130

131+#ifdef USE_TEMPLATE_HASKELL

127132makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig

133+#else

134+

135+webSocketConfig_send :: Lens' (WebSocketConfig t a) (Event t [a])

136+webSocketConfig_send f (WebSocketConfig x1 x2 x3) = (\y -> WebSocketConfig y x2 x3) <$> f x1

137+{-# INLINE webSocketConfig_send #-}

138+

139+webSocketConfig_close :: Lens' (WebSocketConfig t a) (Event t (Word, Text))

140+webSocketConfig_close f (WebSocketConfig x1 x2 x3) = (\y -> WebSocketConfig x1 y x3) <$> f x2

141+{-# INLINE webSocketConfig_close #-}

142+

143+webSocketConfig_reconnect :: Lens' (WebSocketConfig t a) Bool

144+webSocketConfig_reconnect f (WebSocketConfig x1 x2 x3) = (\y -> WebSocketConfig x1 x2 y) <$> f x3

145+{-# INLINE webSocketConfig_reconnect #-}

146+

147+#endif

src-ghcjs/Reflex/Dom/WebSocket/Foreign.hs → reflex-dom-core/src/Reflex/Dom/WebSocket/Foreign.hsrenamed+37−29

@@ -1,5 +1,9 @@

1+{-# LANGUAGE CPP #-}

2+#ifdef ghcjs_HOST_OS

13{-# LANGUAGE ForeignFunctionInterface #-}

24{-# LANGUAGE JavaScriptFFI #-}

5+#endif

6+{-# LANGUAGE LambdaCase #-}

48module Reflex.Dom.WebSocket.Foreign

59 ( module Reflex.Dom.WebSocket.Foreign

@@ -8,7 +12,6 @@ module Reflex.Dom.WebSocket.Foreign

812

913import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)

1014

11−import Control.Monad.IO.Class

1215import Control.Monad.Reader

1316import Data.ByteString (ByteString)

1417import qualified Data.ByteString as BS

@@ -18,72 +21,77 @@ import Data.Text.Encoding

1821import GHCJS.Buffer

1922import GHCJS.DOM.CloseEvent

2023import GHCJS.DOM.EventM (on)

21−import GHCJS.DOM.EventTargetClosures (EventName, unsafeEventName)

2224import GHCJS.DOM.MessageEvent

2325import GHCJS.DOM.Types hiding (Text)

2426import qualified GHCJS.DOM.WebSocket as GD

25−import GHCJS.Foreign.Internal

26−import GHCJS.Marshal.Pure

27+import GHCJS.Foreign (JSType(..), jsTypeOf)

2728import GHCJS.Types

2829import JavaScript.TypedArray.ArrayBuffer as JS

30+import Language.Javascript.JSaddle.Helper (mutableArrayBufferFromJSVal)

31+import Language.Javascript.JSaddle.Types (ghcjsPure)

32+#ifndef ghcjs_HOST_OS

33+import Language.Javascript.JSaddle.Object (new, jsg)

34+#endif

2935

3036data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }

3137

3238class IsWebSocketMessage a where

33− webSocketSend :: JSWebSocket -> a -> IO ()

39+ webSocketSend :: JSWebSocket -> a -> JSM ()

3440

3541-- Use binary websocket communication for ByteString

3642-- Note: Binary websockets may not work correctly in IE 11 and below

3743instance IsWebSocketMessage ByteString where

3844 webSocketSend (JSWebSocket ws) bs = do

39− let (b, off, len) = fromByteString bs

45+ (b, off, len) <- ghcjsPure $ fromByteString bs

4046 ab <- ArrayBuffer <$> if BS.length bs == 0 --TODO: remove this logic when https://github.com/ghcjs/ghcjs-base/issues/49 is fixed

41− then jsval . getArrayBuffer <$> create 0

42− else return $ js_dataView off len $ jsval $ getArrayBuffer b

47+ then create 0 >>= ghcjsPure . getArrayBuffer >>= ghcjsPure . jsval

48+ else do

49+ ref <- ghcjsPure (getArrayBuffer b) >>= ghcjsPure . jsval

50+ js_dataView off len ref -- new (jsg "DataView") (ref, off, len)

4351 GD.send ws $ Just ab

4452

4553-- Use plaintext websocket communication for Text, and String

4654instance IsWebSocketMessage Text where

4755 webSocketSend (JSWebSocket ws) = GD.sendString ws . T.unpack

4856

49−closeWebSocket :: JSWebSocket -> Word -> Text -> IO ()

57+closeWebSocket :: JSWebSocket -> Word -> Text -> JSM ()

5058closeWebSocket (JSWebSocket ws) = GD.close ws

5159

52−-- TODO: remove after upgrade to ghcjs-dom >= 0.3

53−-- in ghcjs-dom 0.2 this has type Event, we want CloseEvent

54−closeEvent :: EventName WebSocket CloseEvent

55−closeEvent = unsafeEventName (toJSString "close")

56−

5760newWebSocket

5861 :: a

5962 -> Text -- url

60− -> (Either ByteString JSVal -> IO ()) -- onmessage

61− -> IO () -- onopen

62− -> IO () -- onerror

63− -> ((Bool, Word, Text) -> IO ()) -- onclose

64− -> IO JSWebSocket

63+ -> (Either ByteString JSVal -> JSM ()) -- onmessage

64+ -> JSM () -- onopen

65+ -> JSM () -- onerror

66+ -> ((Bool, Word, Text) -> JSM ()) -- onclose

67+ -> JSM JSWebSocket

6568newWebSocket _ url onMessage onOpen onError onClose = do

6669 ws <- GD.newWebSocket url (Just [] :: Maybe [Text])

6770 GD.setBinaryType ws "arraybuffer"

68− _ <- on ws GD.open $ liftIO onOpen

69− _ <- on ws GD.error $ liftIO onError

70− _ <- on ws closeEvent $ do

71+ _ <- on ws GD.open $ liftJSM onOpen

72+ _ <- on ws GD.error $ liftJSM onError

73+ _ <- on ws GD.closeEvent $ do

7174 e <- ask

7275 wasClean <- getWasClean e

7376 code <- getCode e

7477 reason <- getReason e

75− liftIO $ onClose (wasClean, code, reason)

78+ liftJSM $ onClose (wasClean, code, reason)

7679 _ <- on ws GD.message $ do

7780 e <- ask

7881 d <- getData e

79− liftIO $ case jsTypeOf d of

82+ liftJSM $ ghcjsPure (jsTypeOf d) >>= \case

8083 String -> onMessage $ Right d

8184 _ -> do

82− ab <- unsafeFreeze $ pFromJSVal d

83− onMessage $ Left $ toByteString 0 Nothing $ createFromArrayBuffer ab

85+ ab <- mutableArrayBufferFromJSVal d >>= unsafeFreeze

86+ ghcjsPure (createFromArrayBuffer ab) >>= ghcjsPure . toByteString 0 Nothing >>= onMessage . Left

8487 return $ JSWebSocket ws

8588

86−foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal

89+#ifdef ghcjs_HOST_OS

90+foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> IO JSVal

91+#else

92+js_dataView :: Int -> Int -> JSVal -> JSM JSVal

93+js_dataView off len ref = new (jsg "DataView") (ref, off, len)

94+#endif

8795

88−onBSMessage :: Either ByteString JSVal -> ByteString

89−onBSMessage = either id (encodeUtf8 . pFromJSVal)

96+onBSMessage :: Either ByteString JSVal -> JSM ByteString

97+onBSMessage = either return (\v -> encodeUtf8 <$> fromJSValUnchecked v)

src/Reflex/Dom/Widget.hs → reflex-dom-core/src/Reflex/Dom/Widget.hsrenamed

The content is the same.

src/Reflex/Dom/Widget/Basic.hs → reflex-dom-core/src/Reflex/Dom/Widget/Basic.hsrenamed−1

@@ -82,7 +82,6 @@ module Reflex.Dom.Widget.Basic

8282import Reflex.Class

8383import Reflex.Dom.Builder.Class

8484import Reflex.Dom.Class

85−import Reflex.Dom.Internal.Foreign ()

8685import Reflex.Dynamic

8786import Reflex.PostBuild.Class

8887

src/Reflex/Dom/Widget/Input.hs → reflex-dom-core/src/Reflex/Dom/Widget/Input.hsrenamed+145−8

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

12{-# LANGUAGE ConstraintKinds #-}

23{-# LANGUAGE DataKinds #-}

34{-# LANGUAGE FlexibleContexts #-}

@@ -8,7 +9,9 @@

89{-# LANGUAGE PolyKinds #-}

910{-# LANGUAGE RecursiveDo #-}

1011{-# LANGUAGE ScopedTypeVariables #-}

12+#ifdef USE_TEMPLATE_HASKELL

1113{-# LANGUAGE TemplateHaskell #-}

14+#endif

1215{-# LANGUAGE TypeFamilies #-}

1316{-# LANGUAGE UndecidableInstances #-}

1417module Reflex.Dom.Widget.Input (module Reflex.Dom.Widget.Input, def, (&), (.~)) where

@@ -30,13 +33,13 @@ import Data.Maybe

3033import Data.Semigroup

3134import Data.Text (Text)

3235import qualified Data.Text as T

33−import GHCJS.DOM.Element (castToElement)

3436import qualified GHCJS.DOM.Element as Element

3537import GHCJS.DOM.EventM (on)

3638import qualified GHCJS.DOM.FileList as FileList

3739import GHCJS.DOM.HTMLInputElement (HTMLInputElement)

3840import GHCJS.DOM.HTMLTextAreaElement (HTMLTextAreaElement)

39−import GHCJS.DOM.Types (File)

41+import GHCJS.DOM.Types (MonadJSM, File, uncheckedCastTo)

42+import qualified GHCJS.DOM.Types as DOM (Element(..), EventTarget(..))

4043import Reflex.Class

4144import Reflex.Dom.Builder.Class

4245import Reflex.Dom.Builder.Immediate

@@ -284,8 +287,8 @@ checkboxView dAttrs dValue = do

284287 postBuild <- getPostBuild

285288 let filters :: DMap EventName (GhcjsEventFilter CheckboxViewEventResult)

286289 filters = DMap.singleton Click $ GhcjsEventFilter $ \(GhcjsDomEvent evt) -> do

287− Just t <- Event.getTarget evt

288− b <- Input.getChecked $ Input.castToHTMLInputElement t

290+ t <- Event.getTargetUnchecked evt

291+ b <- Input.getChecked $ uncheckedCastTo Input.HTMLInputElement t

289292 return $ (,) preventDefault $ return $ Just $ CheckboxViewEventResult b

290293 elementConfig :: ElementConfig CheckboxViewEventResult t m

291294 elementConfig = (def :: ElementConfig EventResult t m)

@@ -296,8 +299,9 @@ checkboxView dAttrs dValue = do

296299 , _ghcjsEventSpec_handler = \(en, GhcjsDomEvent evt) -> case en of

297300 Click -> error "impossible"

298301 _ -> do

299− Just e <- withIsEvent en $ Event.getTarget evt

300− mr <- runReaderT (defaultDomEventHandler (castToElement e) en) evt

302+ e :: DOM.EventTarget <- withIsEvent en $ Event.getTargetUnchecked evt

303+ let element = uncheckedCastTo DOM.Element e

304+ mr <- runReaderT (defaultDomEventHandler element en) evt

301305 return $ ffor mr $ \(EventResult r) -> CheckboxViewEventResult $ regularToCheckboxViewEventType en r

302306 }

303307 }

@@ -321,7 +325,7 @@ instance Reflex t => Default (FileInputConfig t) where

321325 def = FileInputConfig { _fileInputConfig_attributes = constDyn mempty

322326 }

323327

324−fileInput :: forall t m. (MonadIO m, MonadFix m, MonadHold t m, TriggerEvent t m, DomBuilder t m, PostBuild t m, DomBuilderSpace m ~ GhcjsDomSpace)

328+fileInput :: forall t m. (MonadIO m, MonadJSM m, MonadFix m, MonadHold t m, TriggerEvent t m, DomBuilder t m, PostBuild t m, DomBuilderSpace m ~ GhcjsDomSpace)

325329 => FileInputConfig t -> m (FileInput (DomBuilderSpace m) t)

326330fileInput config = do

327331 let insertType = Map.insert "type" "file"

@@ -336,7 +340,7 @@ fileInput config = do

336340 eRaw <- inputElement cfg

337341 let e = _inputElement_raw eRaw

338342 eChange <- wrapDomEvent e (`on` Element.change) $ do

339− Just files <- Input.getFiles e

343+ files <- Input.getFilesUnchecked e

340344 len <- FileList.getLength files

341345 mapM (fmap (fromMaybe (error "fileInput: fileList.item returned null")) . FileList.item files) [0 .. len-1]

342346 dValue <- holdDyn [] eChange

@@ -443,6 +447,7 @@ dropdown k0 options (DropdownConfig setK attrs) = do

443447 dValue <- fmap (zipDynWith readKey ixKeys) $ holdDyn (Just k0) $ leftmost [eChange, fmap Just setK]

444448 return $ Dropdown dValue (attachPromptlyDynWith readKey ixKeys eChange)

445449

450+#ifdef USE_TEMPLATE_HASKELL

446451concat <$> mapM makeLenses

447452 [ ''TextAreaConfig

448453 , ''TextArea

@@ -457,6 +462,138 @@ concat <$> mapM makeLenses

457462 , ''CheckboxConfig

458463 , ''Checkbox

459464 ]

465+#else

466+textAreaConfig_attributes :: Lens' (TextAreaConfig t) (Dynamic t (Map Text Text))

467+textAreaConfig_attributes f (TextAreaConfig x1 x2 x3) = (\y -> TextAreaConfig x1 x2 y) <$> f x3

468+{-# INLINE textAreaConfig_attributes #-}

469+textAreaConfig_initialValue :: Lens' (TextAreaConfig t) Text

470+textAreaConfig_initialValue f (TextAreaConfig x1 x2 x3) = (\y -> TextAreaConfig y x2 x3) <$> f x1

471+{-# INLINE textAreaConfig_initialValue #-}

472+textAreaConfig_setValue :: Lens' (TextAreaConfig t) (Event t Text)

473+textAreaConfig_setValue f (TextAreaConfig x1 x2 x3) = (\y -> TextAreaConfig x1 y x3) <$> f x2

474+{-# INLINE textAreaConfig_setValue #-}

475+textArea_element :: Lens' (TextArea t) HTMLTextAreaElement

476+textArea_element f (TextArea x1 x2 x3 x4 x5) = (\y -> TextArea x1 x2 x3 x4 y) <$> f x5

477+{-# INLINE textArea_element #-}

478+textArea_hasFocus :: Lens' (TextArea t) (Dynamic t Bool)

479+textArea_hasFocus f (TextArea x1 x2 x3 x4 x5) = (\y -> TextArea x1 x2 y x4 x5) <$> f x3

480+{-# INLINE textArea_hasFocus #-}

481+textArea_input :: Lens' (TextArea t) (Event t Text)

482+textArea_input f (TextArea x1 x2 x3 x4 x5) = (\y -> TextArea x1 y x3 x4 x5) <$> f x2

483+{-# INLINE textArea_input #-}

484+textArea_keypress :: Lens' (TextArea t) (Event t Int)

485+textArea_keypress f (TextArea x1 x2 x3 x4 x5) = (\y -> TextArea x1 x2 x3 y x5) <$> f x4

486+{-# INLINE textArea_keypress #-}

487+textArea_value :: Lens' (TextArea t) (Dynamic t Text)

488+textArea_value f (TextArea x1 x2 x3 x4 x5) = (\y -> TextArea y x2 x3 x4 x5) <$> f x1

489+{-# INLINE textArea_value #-}

490+textInputConfig_attributes :: Lens' (TextInputConfig t) (Dynamic t (Map Text Text))

491+textInputConfig_attributes f (TextInputConfig x1 x2 x3 x4) = (\y -> TextInputConfig x1 x2 x3 y) <$> f x4

492+{-# INLINE textInputConfig_attributes #-}

493+textInputConfig_initialValue :: Lens' (TextInputConfig t) Text

494+textInputConfig_initialValue f (TextInputConfig x1 x2 x3 x4) = (\y -> TextInputConfig x1 y x3 x4) <$> f x2

495+{-# INLINE textInputConfig_initialValue #-}

496+textInputConfig_inputType :: Lens' (TextInputConfig t) Text

497+textInputConfig_inputType f (TextInputConfig x1 x2 x3 x4) = (\y -> TextInputConfig y x2 x3 x4) <$> f x1

498+{-# INLINE textInputConfig_inputType #-}

499+textInputConfig_setValue :: Lens' (TextInputConfig t) (Event t Text)

500+textInputConfig_setValue f (TextInputConfig x1 x2 x3 x4) = (\y -> TextInputConfig x1 x2 y x4) <$> f x3

501+{-# INLINE textInputConfig_setValue #-}

502+textInput_builderElement :: Lens' (TextInput t) (InputElement EventResult GhcjsDomSpace t)

503+textInput_builderElement f (TextInput x1 x2 x3 x4 x5 x6 x7) = (\y -> TextInput x1 x2 x3 x4 x5 x6 y) <$> f x7

504+{-# INLINE textInput_builderElement #-}

505+textInput_hasFocus :: Lens' (TextInput t) (Dynamic t Bool)

506+textInput_hasFocus f (TextInput x1 x2 x3 x4 x5 x6 x7) = (\y -> TextInput x1 x2 x3 x4 x5 y x7) <$> f x6

507+{-# INLINE textInput_hasFocus #-}

508+textInput_input :: Lens' (TextInput t) (Event t Text)

509+textInput_input f (TextInput x1 x2 x3 x4 x5 x6 x7) = (\y -> TextInput x1 y x3 x4 x5 x6 x7) <$> f x2

510+{-# INLINE textInput_input #-}

511+textInput_keydown :: Lens' (TextInput t) (Event t Int)

512+textInput_keydown f (TextInput x1 x2 x3 x4 x5 x6 x7) = (\y -> TextInput x1 x2 x3 y x5 x6 x7) <$> f x4

513+{-# INLINE textInput_keydown #-}

514+textInput_keypress :: Lens' (TextInput t) (Event t Int)

515+textInput_keypress f (TextInput x1 x2 x3 x4 x5 x6 x7) = (\y -> TextInput x1 x2 y x4 x5 x6 x7) <$> f x3

516+{-# INLINE textInput_keypress #-}

517+textInput_keyup :: Lens' (TextInput t) (Event t Int)

518+textInput_keyup f (TextInput x1 x2 x3 x4 x5 x6 x7) = (\y -> TextInput x1 x2 x3 x4 y x6 x7) <$> f x5

519+{-# INLINE textInput_keyup #-}

520+textInput_value :: Lens' (TextInput t) (Dynamic t Text)

521+textInput_value f (TextInput x1 x2 x3 x4 x5 x6 x7) = (\y -> TextInput y x2 x3 x4 x5 x6 x7) <$> f x1

522+{-# INLINE textInput_value #-}

523+rangeInputConfig_attributes :: Lens' (RangeInputConfig t) (Dynamic t (Map Text Text))

524+rangeInputConfig_attributes f (RangeInputConfig x1 x2 x3) = (\y -> RangeInputConfig x1 x2 y) <$> f x3

525+{-# INLINE rangeInputConfig_attributes #-}

526+rangeInputConfig_initialValue :: Lens' (RangeInputConfig t) Float

527+rangeInputConfig_initialValue f (RangeInputConfig x1 x2 x3) = (\y -> RangeInputConfig y x2 x3) <$> f x1

528+{-# INLINE rangeInputConfig_initialValue #-}

529+rangeInputConfig_setValue :: Lens' (RangeInputConfig t) (Event t Float)

530+rangeInputConfig_setValue f (RangeInputConfig x1 x2 x3) = (\y -> RangeInputConfig x1 y x3) <$> f x2

531+{-# INLINE rangeInputConfig_setValue #-}

532+rangeInput_element :: Lens' (RangeInput t) HTMLInputElement

533+rangeInput_element f (RangeInput x1 x2 x3 x4 x5) = (\y -> RangeInput x1 x2 x3 x4 y) <$> f x5

534+{-# INLINE rangeInput_element #-}

535+rangeInput_hasFocus :: Lens' (RangeInput t) (Dynamic t Bool)

536+rangeInput_hasFocus f (RangeInput x1 x2 x3 x4 x5) = (\y -> RangeInput x1 x2 x3 y x5) <$> f x4

537+{-# INLINE rangeInput_hasFocus #-}

538+rangeInput_input :: Lens' (RangeInput t) (Event t Float)

539+rangeInput_input f (RangeInput x1 x2 x3 x4 x5) = (\y -> RangeInput x1 y x3 x4 x5) <$> f x2

540+{-# INLINE rangeInput_input #-}

541+rangeInput_mouseup :: Lens' (RangeInput t) (Event t (Int, Int))

542+rangeInput_mouseup f (RangeInput x1 x2 x3 x4 x5) = (\y -> RangeInput x1 x2 y x4 x5) <$> f x3

543+{-# INLINE rangeInput_mouseup #-}

544+rangeInput_value :: Lens' (RangeInput t) (Dynamic t Float)

545+rangeInput_value f (RangeInput x1 x2 x3 x4 x5) = (\y -> RangeInput y x2 x3 x4 x5) <$> f x1

546+{-# INLINE rangeInput_value #-}

547+fileInputConfig_attributes :: Iso

548+ (FileInputConfig t1)

549+ (FileInputConfig t2)

550+ (Dynamic t1 (Map Text Text))

551+ (Dynamic t2 (Map Text Text))

552+fileInputConfig_attributes = iso (\(FileInputConfig x) -> x) FileInputConfig

553+{-# INLINE fileInputConfig_attributes #-}

554+fileInput_element :: Lens

555+ (FileInput d1 t)

556+ (FileInput d2 t)

557+ (RawInputElement d1)

558+ (RawInputElement d2)

559+fileInput_element f (FileInput x1 x2) = (\y -> FileInput x1 y) <$> f x2

560+{-# INLINE fileInput_element #-}

561+fileInput_value :: Lens

562+ (FileInput d t1)

563+ (FileInput d t2)

564+ (Dynamic t1 [File])

565+ (Dynamic t2 [File])

566+fileInput_value f (FileInput x1 x2) = (\y -> FileInput y x2) <$> f x1

567+{-# INLINE fileInput_value #-}

568+dropdownConfig_attributes :: Lens' (DropdownConfig t k) (Dynamic t (Map Text Text))

569+dropdownConfig_attributes f (DropdownConfig x1 x2) = (\y -> DropdownConfig x1 y) <$> f x2

570+{-# INLINE dropdownConfig_attributes #-}

571+dropdownConfig_setValue :: Lens

572+ (DropdownConfig t k1)

573+ (DropdownConfig t k2)

574+ (Event t k1)

575+ (Event t k2)

576+dropdownConfig_setValue f (DropdownConfig x1 x2) = (\y -> DropdownConfig y x2) <$> f x1

577+{-# INLINE dropdownConfig_setValue #-}

578+dropdown_change :: Lens' (Dropdown t k) (Event t k)

579+dropdown_change f (Dropdown x1 x2) = (\y -> Dropdown x1 y) <$> f x2

580+{-# INLINE dropdown_change #-}

581+dropdown_value :: Lens' (Dropdown t k) (Dynamic t k)

582+dropdown_value f (Dropdown x1 x2) = (\y -> Dropdown y x2) <$> f x1

583+{-# INLINE dropdown_value #-}

584+checkboxConfig_attributes :: Lens' (CheckboxConfig t) (Dynamic t (Map Text Text))

585+checkboxConfig_attributes f (CheckboxConfig x1 x2) = (\y -> CheckboxConfig x1 y) <$> f x2

586+{-# INLINE checkboxConfig_attributes #-}

587+checkboxConfig_setValue :: Lens' (CheckboxConfig t) (Event t Bool)

588+checkboxConfig_setValue f (CheckboxConfig x1 x2) = (\y -> CheckboxConfig y x2) <$> f x1

589+{-# INLINE checkboxConfig_setValue #-}

590+checkbox_change :: Lens' (Checkbox t) (Event t Bool)

591+checkbox_change f (Checkbox x1 x2) = (\y -> Checkbox x1 y) <$> f x2

592+{-# INLINE checkbox_change #-}

593+checkbox_value :: Lens' (Checkbox t) (Dynamic t Bool)

594+checkbox_value f (Checkbox x1 x2) = (\y -> Checkbox y x2) <$> f x1

595+{-# INLINE checkbox_value #-}

596+#endif

460597

461598instance HasAttributes (TextAreaConfig t) where

462599 type Attrs (TextAreaConfig t) = Dynamic t (Map Text Text)

src/Reflex/Dom/Widget/Lazy.hs → reflex-dom-core/src/Reflex/Dom/Widget/Lazy.hsrenamed+8−8

@@ -16,7 +16,6 @@ import Reflex.PerformEvent.Class

1616import Reflex.PostBuild.Class

1717

1818import Control.Monad.Fix

19−import Control.Monad.IO.Class

2019import Data.Fixed

2120import Data.Map (Map)

2221import qualified Data.Map as Map

@@ -24,9 +23,10 @@ import Data.Monoid

2423import Data.Text (Text)

2524import qualified Data.Text as T

2625import GHCJS.DOM.Element

26+import GHCJS.DOM.Types (MonadJSM)

2727

2828-- |A list view for long lists. Creates a scrollable element and only renders child row elements near the current scroll position.

29−virtualListWithSelection :: forall t m k v. (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, MonadIO (Performable m), DomBuilderSpace m ~ GhcjsDomSpace, MonadFix m, Ord k)

29+virtualListWithSelection :: forall t m k v. (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m), DomBuilderSpace m ~ GhcjsDomSpace, MonadFix m, Ord k)

3030 => Dynamic t Int -- ^ The height of the visible region in pixels

3131 -> Int -- ^ The height of each row in pixels

3232 -> Dynamic t Int -- ^ The total number of items

@@ -58,8 +58,8 @@ virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTa

5858 let window = zipDynWith (findWindow rowPx) heightPx scrollPosition

5959 itemsInWindow = zipDynWith (\(_,(idx,num)) is -> Map.fromList $ map (\i -> let ix = indexToKey i in (ix, Map.lookup ix is)) [idx .. idx + num]) window items

6060 postBuild <- getPostBuild

61− performEvent_ $ ffor (leftmost [setI, i0 <$ postBuild]) $ \i -> do

62− liftIO $ setScrollTop (_element_raw container) (i * rowPx)

61+ performEvent_ $ ffor (leftmost [setI, i0 <$ postBuild]) $ \i ->

62+ setScrollTop (_element_raw container) (i * rowPx)

6363 let indexAndLength = fmap snd window

6464 return (indexAndLength, sel)

6565 where

@@ -80,7 +80,7 @@ virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTa

8080 preItems = min startingIndex numItems

8181 in (topPx - preItems * sizeIncrement, (startingIndex - preItems, preItems + numItems * 2))

8282

83−virtualList :: forall t m k v a. (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, MonadIO (Performable m), DomBuilderSpace m ~ GhcjsDomSpace, MonadFix m, Ord k)

83+virtualList :: forall t m k v a. (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m), DomBuilderSpace m ~ GhcjsDomSpace, MonadFix m, Ord k)

8484 => Dynamic t Int -- ^ A 'Dynamic' of the visible region's height in pixels

8585 -> Int -- ^ The fixed height of each row in pixels

8686 -> Dynamic t Int -- ^ A 'Dynamic' of the total number of items

@@ -102,8 +102,8 @@ virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBu

102102 , fmap (const (i0 * rowPx)) pb

103103 ]

104104 let window = zipDynWith (findWindow rowPx) heightPx scrollPosition

105− performEvent_ $ ffor (leftmost [setI, i0 <$ pb]) $ \i -> do

106− liftIO $ setScrollTop (_element_raw viewport) (i * rowPx)

105+ performEvent_ $ ffor (leftmost [setI, i0 <$ pb]) $ \i ->

106+ setScrollTop (_element_raw viewport) (i * rowPx)

107107 return (uniqDyn window, result)

108108 where

109109 toStyleAttr m = "style" =: Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m

@@ -124,7 +124,7 @@ virtualList heightPx rowPx maxIndex i0 setI keyToIndex items0 itemsUpdate itemBu

124124 in (startingIndex, numItems)

125125

126126virtualListBuffered

127− :: (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, MonadIO (Performable m), DomBuilderSpace m ~ GhcjsDomSpace, MonadFix m, Ord k)

127+ :: (DomBuilder t m, PostBuild t m, MonadHold t m, PerformEvent t m, MonadJSM (Performable m), DomBuilderSpace m ~ GhcjsDomSpace, MonadFix m, Ord k)

128128 => Int

129129 -> Dynamic t Int

130130 -> Int

src/Reflex/Dom/Widget/Resize.hs → reflex-dom-core/src/Reflex/Dom/Widget/Resize.hsrenamed+7−5

@@ -1,3 +1,4 @@

1+{-# LANGUAGE ScopedTypeVariables #-}

12{-# LANGUAGE FlexibleContexts #-}

23{-# LANGUAGE MultiParamTypeClasses #-}

34{-# LANGUAGE OverloadedStrings #-}

@@ -24,19 +25,20 @@ import Data.Text (Text)

2425import qualified Data.Text as T

2526import GHCJS.DOM.Element hiding (reset)

2627import GHCJS.DOM.EventM (on)

28+import GHCJS.DOM.Types (liftJSM, MonadJSM)

2729

2830-- | A widget that wraps the given widget in a div and fires an event when resized.

2931-- Adapted from github.com/marcj/css-element-queries

30−resizeDetector :: (DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadIO (Performable m), MonadFix m) => m a -> m (Event t (), a)

32+resizeDetector :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m) => m a -> m (Event t (), a)

3133resizeDetector = resizeDetectorWithStyle ""

3234

33−resizeDetectorWithStyle :: (DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadIO (Performable m), MonadFix m)

35+resizeDetectorWithStyle :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m)

3436 => Text -- ^ A css style string. Warning: It should not contain the "position" style attribute.

3537 -> m a -- ^ The embedded widget

3638 -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget

3739resizeDetectorWithStyle styleString = resizeDetectorWithAttrs ("style" =: styleString)

3840

39−resizeDetectorWithAttrs :: (DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadIO (Performable m), MonadFix m)

41+resizeDetectorWithAttrs :: (MonadJSM m, DomBuilder t m, PostBuild t m, TriggerEvent t m, PerformEvent t m, MonadHold t m, DomBuilderSpace m ~ GhcjsDomSpace, MonadJSM (Performable m), MonadFix m)

4042 => Map Text Text -- ^ A map of attributes. Warning: It should not modify the "position" style attribute.

4143 -> m a -- ^ The embedded widget

4244 -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget

@@ -77,7 +79,7 @@ resizeDetectorWithAttrs attrs w = do

7779 pb <- getPostBuild

7880 expandScroll <- wrapDomEvent (_element_raw expand) (`on` scroll) $ return ()

7981 shrinkScroll <- wrapDomEvent (_element_raw shrink) (`on` scroll) $ return ()

80− size0 <- performEvent $ fmap (const $ liftIO reset) pb

81− rec resize <- performEventAsync $ fmap (\d cb -> liftIO $ cb =<< resetIfChanged d) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]

82+ size0 <- performEvent $ fmap (const $ liftJSM reset) pb

83+ rec resize <- performEventAsync $ fmap (\d cb -> (liftIO . cb) =<< liftJSM (resetIfChanged d)) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]

8284 dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]

8385 return (fmapMaybe void resize, w')

src/Reflex/Dom/Xhr.hs → reflex-dom-core/src/Reflex/Dom/Xhr.hsrenamed+94−25

@@ -5,7 +5,9 @@

55{-# LANGUAGE GADTs #-}

66{-# LANGUAGE MultiParamTypeClasses #-}

77{-# LANGUAGE OverloadedStrings #-}

8+#ifdef USE_TEMPLATE_HASKELL

89{-# LANGUAGE TemplateHaskell #-}

10+#endif

911module Reflex.Dom.Xhr

1012 ( XMLHttpRequest

1113 , XhrRequest (..)

@@ -61,11 +63,11 @@ where

6163

6264import Reflex.Class

6365import Reflex.Dom.Class

66+import Reflex.PerformEvent.Class

67+import Reflex.TriggerEvent.Class

6468import Reflex.Dom.Xhr.Exception

6569import Reflex.Dom.Xhr.Foreign

6670import Reflex.Dom.Xhr.ResponseType

67−import Reflex.PerformEvent.Class

68−import Reflex.TriggerEvent.Class

6971

7072import Control.Concurrent

7173import Control.Exception (handle)

@@ -93,6 +95,8 @@ import qualified Data.Text.Lazy.Builder as B

9395import Data.Traversable

9496import Data.Typeable

9597

98+import Language.Javascript.JSaddle.Monad (JSM, askJSM, runJSM, MonadJSM, liftJSM)

99+

96100data XhrRequest a

97101 = XhrRequest { _xhrRequest_method :: Text

98102 , _xhrRequest_url :: Text

@@ -155,18 +159,19 @@ xhrRequest = XhrRequest

155159-- the XHR connection), and will pass an exception ('XhrException') to the

156160-- continuation if the connection cannot be made (or is aborted).

157161newXMLHttpRequestWithError

158− :: (HasWebView m, MonadIO m, IsXhrPayload a)

162+ :: (HasJSContext m, MonadJSM m, IsXhrPayload a)

159163 => XhrRequest a

160164 -- ^ The request to make.

161− -> (Either XhrException XhrResponse -> IO ())

165+ -> (Either XhrException XhrResponse -> JSM ())

162166 -- ^ A continuation to be called once a response comes back, or in

163167 -- case of error.

164168 -> m XMLHttpRequest

165169 -- ^ The XHR request, which could for example be aborted.

166170newXMLHttpRequestWithError req cb = do

167− wv <- askWebView

168− xhr <- liftIO $ xmlHttpRequestNew $ unWebViewSingleton wv

169− void $ liftIO $ forkIO $ handle (cb . Left) $ void $ do

171+ wv <- askJSContext

172+ xhr <- xmlHttpRequestNew

173+ ctx <- askJSM

174+ void $ liftIO $ forkIO $ handle ((`runJSM` ctx) . cb . Left) $ void . (`runJSM` ctx) $ do

170175 let c = _xhrRequest_config req

171176 rt = _xhrRequestConfig_responseType c

172177 creds = _xhrRequestConfig_withCredentials c

@@ -181,20 +186,20 @@ newXMLHttpRequestWithError req cb = do

181186 maybe (return ()) (xmlHttpRequestSetResponseType xhr . fromResponseType) rt

182187 xmlHttpRequestSetWithCredentials xhr creds

183188 _ <- xmlHttpRequestOnreadystatechange xhr $ do

184− readyState <- liftIO $ xmlHttpRequestGetReadyState xhr

185− status <- liftIO $ xmlHttpRequestGetStatus xhr

186− statusText <- liftIO $ xmlHttpRequestGetStatusText xhr

189+ readyState <- xmlHttpRequestGetReadyState xhr

190+ status <- xmlHttpRequestGetStatus xhr

191+ statusText <- xmlHttpRequestGetStatusText xhr

187192 when (readyState == 4) $ do

188193 t <- if rt == Just XhrResponseType_Text || isNothing rt

189− then liftIO $ xmlHttpRequestGetResponseText xhr

194+ then xmlHttpRequestGetResponseText xhr

190195 else return Nothing

191− r <- liftIO $ xmlHttpRequestGetResponse xhr

196+ r <- xmlHttpRequestGetResponse xhr

192197 h <- case _xhrRequestConfig_responseHeaders c of

193− AllHeaders -> liftIO $ parseAllHeadersString <$>

198+ AllHeaders -> parseAllHeadersString <$>

194199 xmlHttpRequestGetAllResponseHeaders xhr

195− OnlyHeaders xs -> liftIO $ traverse (xmlHttpRequestGetResponseHeader xhr)

200+ OnlyHeaders xs -> traverse (xmlHttpRequestGetResponseHeader xhr)

196201 (Map.fromSet id xs)

197− _ <- liftIO $ cb $ Right

202+ _ <- liftJSM $ cb $ Right

198203 XhrResponse { _xhrResponse_status = status

199204 , _xhrResponse_statusText = statusText

200205 , _xhrResponse_response = r

@@ -211,7 +216,7 @@ parseAllHeadersString s = Map.fromList $ fmap (stripBoth . T.span (/=':')) $

211216 L.dropWhileEnd T.null $ T.splitOn (T.pack "\r\n") s

212217 where stripBoth (txt1, txt2) = (T.strip txt1, T.strip $ T.drop 1 txt2)

213218

214−newXMLHttpRequest :: (HasWebView m, MonadIO m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> IO ()) -> m XMLHttpRequest

219+newXMLHttpRequest :: (HasJSContext m, MonadJSM m, IsXhrPayload a) => XhrRequest a -> (XhrResponse -> JSM ()) -> m XMLHttpRequest

215220newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb

216221

217222-- | Given Event of requests, issue them when the Event fires.

@@ -220,20 +225,20 @@ newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb

220225-- The request is processed asynchronously, therefore handling does

221226-- not block or cause a delay while creating the connection.

222227performRequestAsyncWithError

223− :: (MonadIO (Performable m), HasWebView (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a)

228+ :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a)

224229 => Event t (XhrRequest a)

225230 -> m (Event t (Either XhrException XhrResponse))

226231performRequestAsyncWithError = performRequestAsync' newXMLHttpRequestWithError . fmap return

227232

228233-- | Given Event of request, issue them when the Event fires. Returns Event of corresponding response.

229−performRequestAsync :: (MonadIO (Performable m), HasWebView (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a) => Event t (XhrRequest a) -> m (Event t XhrResponse)

234+performRequestAsync :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a) => Event t (XhrRequest a) -> m (Event t XhrResponse)

230235performRequestAsync = performRequestAsync' newXMLHttpRequest . fmap return

231236

232237-- | Given Event with an action that creates a request, build and issue the request when the Event fires. Returns Event of corresponding response.

233−performMkRequestAsync :: (MonadIO (Performable m), HasWebView (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a) => Event t (Performable m (XhrRequest a)) -> m (Event t XhrResponse)

238+performMkRequestAsync :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, IsXhrPayload a) => Event t (Performable m (XhrRequest a)) -> m (Event t XhrResponse)

234239performMkRequestAsync = performRequestAsync' newXMLHttpRequest

235240

236−performRequestAsync' :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m) => (XhrRequest p -> (a -> IO ()) -> Performable m XMLHttpRequest) -> Event t (Performable m (XhrRequest p)) -> m (Event t a)

241+performRequestAsync' :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m) => (XhrRequest p -> (a -> JSM ()) -> Performable m XMLHttpRequest) -> Event t (Performable m (XhrRequest p)) -> m (Event t a)

237242performRequestAsync' newXhr req = performEventAsync $ ffor req $ \hr cb -> do

238243 r <- hr

239244 _ <- newXhr r $ liftIO . cb

@@ -249,19 +254,19 @@ performRequestAsync' newXhr req = performEventAsync $ ffor req $ \hr cb -> do

249254-- Order of request execution and completion is not guaranteed, but

250255-- order of creation and the collection result is preserved.

251256performRequestsAsyncWithError

252− :: (MonadIO (Performable m), HasWebView (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a)

257+ :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a)

253258 => Event t (f (XhrRequest a)) -> m (Event t (f (Either XhrException XhrResponse)))

254259performRequestsAsyncWithError = performRequestsAsync' newXMLHttpRequestWithError . fmap return

255260

256261-- | Issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.

257−performRequestsAsync :: (MonadIO (Performable m), HasWebView (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a) => Event t (f (XhrRequest a)) -> m (Event t (f XhrResponse))

262+performRequestsAsync :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a) => Event t (f (XhrRequest a)) -> m (Event t (f XhrResponse))

258263performRequestsAsync = performRequestsAsync' newXMLHttpRequest . fmap return

259264

260265-- | Builds and issues a collection of requests when the supplied Event fires. When ALL requests from a given firing complete, the results are collected and returned via the return Event.

261−performMkRequestsAsync :: (MonadIO (Performable m), HasWebView (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a) => Event t (Performable m (f (XhrRequest a))) -> m (Event t (f XhrResponse))

266+performMkRequestsAsync :: (MonadJSM (Performable m), HasJSContext (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, IsXhrPayload a) => Event t (Performable m (f (XhrRequest a))) -> m (Event t (f XhrResponse))

262267performMkRequestsAsync = performRequestsAsync' newXMLHttpRequest

263268

264−performRequestsAsync' :: (MonadIO (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f) => (XhrRequest b -> (a -> IO ()) -> Performable m XMLHttpRequest) -> Event t (Performable m (f (XhrRequest b))) -> m (Event t (f a))

269+performRequestsAsync' :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f) => (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest) -> Event t (Performable m (f (XhrRequest b))) -> m (Event t (f a))

265270performRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do

266271 rs <- hrs

267272 resps <- forM rs $ \r -> do

@@ -272,7 +277,7 @@ performRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do

272277 return ()

273278

274279-- | Simplified interface to "GET" URLs and return decoded results.

275−getAndDecode :: (MonadIO m, MonadIO (Performable m), PerformEvent t m, HasWebView (Performable m), TriggerEvent t m, FromJSON a) => Event t Text -> m (Event t (Maybe a))

280+getAndDecode :: (MonadIO m, MonadJSM (Performable m), PerformEvent t m, HasJSContext (Performable m), TriggerEvent t m, FromJSON a) => Event t Text -> m (Event t (Maybe a))

276281getAndDecode url = do

277282 r <- performRequestAsync $ fmap (\x -> XhrRequest "GET" x def) url

278283 return $ fmap decodeXhrResponse r

@@ -298,8 +303,72 @@ decodeText = decode . BL.fromStrict . encodeUtf8

298303decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a

299304decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText

300305

306+#ifdef USE_TEMPLATE_HASKELL

301307concat <$> mapM makeLenses

302308 [ ''XhrRequest

303309 , ''XhrRequestConfig

304310 , ''XhrResponse

305311 ]

312+#else

313+

314+xhrRequest_method :: Lens' (XhrRequest a) Text

315+xhrRequest_method f (XhrRequest x1 x2 x3) = (\y -> XhrRequest y x2 x3) <$> f x1

316+{-# INLINE xhrRequest_method #-}

317+

318+xhrRequest_url :: Lens' (XhrRequest a) Text

319+xhrRequest_url f (XhrRequest x1 x2 x3) = (\y -> XhrRequest x1 y x3) <$> f x2

320+{-# INLINE xhrRequest_url #-}

321+

322+xhrRequest_config :: Lens' (XhrRequest a) (XhrRequestConfig a)

323+xhrRequest_config f (XhrRequest x1 x2 x3) = (\y -> XhrRequest x1 x2 y) <$> f x3

324+{-# INLINE xhrRequest_config #-}

325+

326+xhrRequestConfig_headers :: Lens' (XhrRequestConfig a) (Map Text Text)

327+xhrRequestConfig_headers f (XhrRequestConfig x1 x2 x3 x4 x5 x6 x7) = (\y -> XhrRequestConfig y x2 x3 x4 x5 x6 x7) <$> f x1

328+{-# INLINE xhrRequestConfig_headers #-}

329+

330+xhrRequestConfig_user :: Lens' (XhrRequestConfig a) (Maybe Text)

331+xhrRequestConfig_user f (XhrRequestConfig x1 x2 x3 x4 x5 x6 x7) = (\y -> XhrRequestConfig x1 y x3 x4 x5 x6 x7) <$> f x2

332+{-# INLINE xhrRequestConfig_user #-}

333+

334+xhrRequestConfig_password :: Lens' (XhrRequestConfig a) (Maybe Text)

335+xhrRequestConfig_password f (XhrRequestConfig x1 x2 x3 x4 x5 x6 x7) = (\y -> XhrRequestConfig x1 x2 y x4 x5 x6 x7) <$> f x3

336+{-# INLINE xhrRequestConfig_password #-}

337+

338+xhrRequestConfig_responseType :: Lens' (XhrRequestConfig a) (Maybe XhrResponseType)

339+xhrRequestConfig_responseType f (XhrRequestConfig x1 x2 x3 x4 x5 x6 x7) = (\y -> XhrRequestConfig x1 x2 x3 y x5 x6 x7) <$> f x4

340+{-# INLINE xhrRequestConfig_responseType #-}

341+

342+xhrRequestConfig_sendData :: Lens' (XhrRequestConfig a) a

343+xhrRequestConfig_sendData f (XhrRequestConfig x1 x2 x3 x4 x5 x6 x7) = (\y -> XhrRequestConfig x1 x2 x3 x4 y x6 x7) <$> f x5

344+{-# INLINE xhrRequestConfig_sendData #-}

345+

346+xhrRequestConfig_withCredentials :: Lens' (XhrRequestConfig a) Bool

347+xhrRequestConfig_withCredentials f (XhrRequestConfig x1 x2 x3 x4 x5 x6 x7) = (\y -> XhrRequestConfig x1 x2 x3 x4 x5 y x7) <$> f x6

348+{-# INLINE xhrRequestConfig_withCredentials #-}

349+

350+xhrRequestConfig_responseHeaders :: Lens' (XhrRequestConfig a) XhrResponseHeaders

351+xhrRequestConfig_responseHeaders f (XhrRequestConfig x1 x2 x3 x4 x5 x6 x7) = (\y -> XhrRequestConfig x1 x2 x3 x4 x5 x6 y) <$> f x7

352+{-# INLINE xhrRequestConfig_responseHeaders #-}

353+

354+xhrResponse_status :: Lens' XhrResponse Word

355+xhrResponse_status f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse y x2 x3 x4 x5) <$> f x1

356+{-# INLINE xhrResponse_status #-}

357+

358+xhrResponse_statusText :: Lens' XhrResponse Text

359+xhrResponse_statusText f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 y x3 x4 x5) <$> f x2

360+{-# INLINE xhrResponse_statusText #-}

361+

362+xhrResponse_response :: Lens' XhrResponse (Maybe XhrResponseBody)

363+xhrResponse_response f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 y x4 x5) <$> f x3

364+{-# INLINE xhrResponse_response #-}

365+

366+xhrResponse_responseText :: Lens' XhrResponse (Maybe Text)

367+xhrResponse_responseText f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 x3 y x5) <$> f x4

368+{-# INLINE xhrResponse_responseText #-}

369+

370+xhrResponse_headers :: Lens' XhrResponse (Map Text Text)

371+xhrResponse_headers f (XhrResponse x1 x2 x3 x4 x5) = (\y -> XhrResponse x1 x2 x3 x4 y) <$> f x5

372+{-# INLINE xhrResponse_headers #-}

373+

374+#endif

src/Reflex/Dom/Xhr/Exception.hs → reflex-dom-core/src/Reflex/Dom/Xhr/Exception.hsrenamed

The content is the same.

src-ghcjs/Reflex/Dom/Xhr/Foreign.hs → reflex-dom-core/src/Reflex/Dom/Xhr/Foreign.hsrenamed+53−44

@@ -10,29 +10,35 @@ module Reflex.Dom.Xhr.Foreign (

1010) where

1111

1212import Control.Exception (catch, throwIO)

13+import Control.Monad (join)

14+import Control.Monad.IO.Class (MonadIO(..))

1315import Data.Maybe (fromMaybe)

1416import Data.Text (Text)

17+import Data.ByteString (ByteString)

18+import GHCJS.Marshal (fromJSValUnchecked)

1519import GHCJS.DOM

1620import GHCJS.DOM.Enums

1721import GHCJS.DOM.EventM (EventM, on)

1822import GHCJS.DOM.EventTarget (dispatchEvent)

1923import GHCJS.DOM.Types hiding (Text)

2024import GHCJS.DOM.XMLHttpRequest

21−import GHCJS.Types

25+-- import GHCJS.Types

2226import Prelude hiding (error)

23−import Reflex.Dom.Internal.Foreign

2427import Reflex.Dom.Xhr.Exception

2528import Reflex.Dom.Xhr.ResponseType

29+import Language.Javascript.JSaddle.Types (ghcjsPure)

30+import qualified Language.Javascript.JSaddle.Monad as JS (catch)

31+import qualified GHCJS.Buffer as JS

32+ (createFromArrayBuffer, toByteString)

33+import qualified JavaScript.TypedArray.ArrayBuffer as JS

34+ (unsafeFreeze, MutableArrayBuffer)

2635

27−prepareWebView :: WebView -> IO ()

28−prepareWebView _ = return ()

29−

30−xmlHttpRequestNew :: a -> IO XMLHttpRequest

31−xmlHttpRequestNew _ = newXMLHttpRequest

36+xmlHttpRequestNew :: MonadJSM m => m XMLHttpRequest

37+xmlHttpRequestNew = newXMLHttpRequest

3238

3339xmlHttpRequestOpen ::

34− (ToJSString method, ToJSString url, ToJSString user, ToJSString password) =>

35− XMLHttpRequest -> method -> url -> Bool -> user -> password -> IO ()

40+ (ToJSString method, ToJSString url, ToJSString user, ToJSString password, MonadJSM m) =>

41+ XMLHttpRequest -> method -> url -> Bool -> user -> password -> m ()

3642xmlHttpRequestOpen = open

3743

3844convertException :: XHRError -> XhrException

@@ -41,7 +47,7 @@ convertException e = case e of

4147 XHRAborted -> XhrException_Aborted

4248

4349class IsXhrPayload a where

44− sendXhrPayload :: XMLHttpRequest -> a -> IO ()

50+ sendXhrPayload :: MonadJSM m => XMLHttpRequest -> a -> m ()

4551

4652instance IsXhrPayload () where

4753 sendXhrPayload xhr _ = send xhr

@@ -64,79 +70,79 @@ instance IsXhrPayload Blob where

6470newtype XhrPayload = XhrPayload { unXhrPayload :: JSVal }

6571

6672-- This used to be a non blocking call, but now it uses an interruptible ffi

67−xmlHttpRequestSend :: IsXhrPayload payload => XMLHttpRequest -> payload -> IO ()

68−xmlHttpRequestSend self p = sendXhrPayload self p `catch` (throwIO . convertException)

73+xmlHttpRequestSend :: IsXhrPayload payload => XMLHttpRequest -> payload -> JSM ()

74+xmlHttpRequestSend self p = sendXhrPayload self p `JS.catch` (liftIO . throwIO . convertException)

6975

7076

71−xmlHttpRequestSetRequestHeader :: (ToJSString header, ToJSString value)

72− => XMLHttpRequest -> header -> value -> IO ()

77+xmlHttpRequestSetRequestHeader :: (ToJSString header, ToJSString value, MonadJSM m)

78+ => XMLHttpRequest -> header -> value -> m ()

7379xmlHttpRequestSetRequestHeader = setRequestHeader

7480

75−xmlHttpRequestAbort :: XMLHttpRequest -> IO ()

81+xmlHttpRequestAbort :: MonadJSM m => XMLHttpRequest -> m ()

7682xmlHttpRequestAbort = abort

7783

78−xmlHttpRequestGetAllResponseHeaders :: XMLHttpRequest -> IO Text

84+xmlHttpRequestGetAllResponseHeaders :: MonadJSM m => XMLHttpRequest -> m Text

7985xmlHttpRequestGetAllResponseHeaders self = fromMaybe "" <$> getAllResponseHeaders self

8086

81−xmlHttpRequestGetResponseHeader :: (ToJSString header)

82− => XMLHttpRequest -> header -> IO Text

87+xmlHttpRequestGetResponseHeader :: (ToJSString header, MonadJSM m)

88+ => XMLHttpRequest -> header -> m Text

8389xmlHttpRequestGetResponseHeader self header = fromMaybe "" <$> getResponseHeader self header

8490

85−xmlHttpRequestOverrideMimeType :: ToJSString override => XMLHttpRequest -> override -> IO ()

91+xmlHttpRequestOverrideMimeType :: (ToJSString override, MonadJSM m) => XMLHttpRequest -> override -> m ()

8692xmlHttpRequestOverrideMimeType = overrideMimeType

8793

88−xmlHttpRequestDispatchEvent :: IsEvent evt => XMLHttpRequest -> Maybe evt -> IO Bool

94+xmlHttpRequestDispatchEvent :: (IsEvent evt, MonadJSM m) => XMLHttpRequest -> Maybe evt -> m Bool

8995xmlHttpRequestDispatchEvent = dispatchEvent

9096

91−xmlHttpRequestOnabort :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())

97+xmlHttpRequestOnabort :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> JSM (JSM ())

9298xmlHttpRequestOnabort = (`on` abortEvent)

9399

94−xmlHttpRequestOnerror :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())

100+xmlHttpRequestOnerror :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> JSM (JSM ())

95101xmlHttpRequestOnerror = (`on` error)

96102

97−xmlHttpRequestOnload :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())

103+xmlHttpRequestOnload :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> JSM (JSM ())

98104xmlHttpRequestOnload = (`on` load)

99105

100−xmlHttpRequestOnloadend :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())

106+xmlHttpRequestOnloadend :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> JSM (JSM ())

101107xmlHttpRequestOnloadend = (`on` loadEnd)

102108

103−xmlHttpRequestOnloadstart :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())

109+xmlHttpRequestOnloadstart :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> JSM (JSM ())

104110xmlHttpRequestOnloadstart = (`on` loadStart)

105111

106−xmlHttpRequestOnprogress :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())

112+xmlHttpRequestOnprogress :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> JSM (JSM ())

107113xmlHttpRequestOnprogress = (`on` progress)

108114

109−xmlHttpRequestOntimeout :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())

115+xmlHttpRequestOntimeout :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> JSM (JSM ())

110116xmlHttpRequestOntimeout = (`on` timeout)

111117

112−xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> EventM XMLHttpRequest Event () -> IO (IO ())

118+xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> EventM XMLHttpRequest Event () -> JSM (JSM ())

113119xmlHttpRequestOnreadystatechange = (`on` readyStateChange)

114120

115−xmlHttpRequestSetTimeout :: XMLHttpRequest -> Word -> IO ()

121+xmlHttpRequestSetTimeout :: MonadJSM m => XMLHttpRequest -> Word -> m ()

116122xmlHttpRequestSetTimeout = setTimeout

117123

118−xmlHttpRequestGetTimeout :: XMLHttpRequest -> IO Word

124+xmlHttpRequestGetTimeout :: MonadJSM m => XMLHttpRequest -> m Word

119125xmlHttpRequestGetTimeout = getTimeout

120126

121−xmlHttpRequestGetReadyState :: XMLHttpRequest -> IO Word

127+xmlHttpRequestGetReadyState :: MonadJSM m => XMLHttpRequest -> m Word

122128xmlHttpRequestGetReadyState = getReadyState

123129

124−xmlHttpRequestSetWithCredentials :: XMLHttpRequest -> Bool -> IO ()

130+xmlHttpRequestSetWithCredentials :: MonadJSM m => XMLHttpRequest -> Bool -> m ()

125131xmlHttpRequestSetWithCredentials = setWithCredentials

126132

127−xmlHttpRequestGetWithCredentials :: XMLHttpRequest -> IO Bool

133+xmlHttpRequestGetWithCredentials :: MonadJSM m => XMLHttpRequest -> m Bool

128134xmlHttpRequestGetWithCredentials = getWithCredentials

129135

130−xmlHttpRequestGetUpload :: XMLHttpRequest -> IO (Maybe XMLHttpRequestUpload)

136+xmlHttpRequestGetUpload :: MonadJSM m => XMLHttpRequest -> m (Maybe XMLHttpRequestUpload)

131137xmlHttpRequestGetUpload = getUpload

132138

133−xmlHttpRequestGetResponseText :: FromJSString result => XMLHttpRequest -> IO (Maybe result)

139+xmlHttpRequestGetResponseText :: (FromJSString result, MonadJSM m) => XMLHttpRequest -> m (Maybe result)

134140xmlHttpRequestGetResponseText = getResponseText

135141

136−xmlHttpRequestGetResponseXML :: XMLHttpRequest -> IO (Maybe Document)

142+xmlHttpRequestGetResponseXML :: MonadJSM m => XMLHttpRequest -> m (Maybe Document)

137143xmlHttpRequestGetResponseXML = getResponseXML

138144

139−xmlHttpRequestSetResponseType :: XMLHttpRequest -> XMLHttpRequestResponseType -> IO ()

145+xmlHttpRequestSetResponseType :: MonadJSM m => XMLHttpRequest -> XMLHttpRequestResponseType -> m ()

140146xmlHttpRequestSetResponseType = setResponseType

141147

142148fromResponseType :: XhrResponseType -> XMLHttpRequestResponseType

@@ -152,28 +158,31 @@ toResponseType XMLHttpRequestResponseTypeBlob = Just XhrResponseType_Blob

152158toResponseType XMLHttpRequestResponseTypeText = Just XhrResponseType_Text

153159toResponseType _ = Nothing

154160

155−xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO (Maybe XhrResponseType)

161+xmlHttpRequestGetResponseType :: MonadJSM m => XMLHttpRequest -> m (Maybe XhrResponseType)

156162xmlHttpRequestGetResponseType = fmap toResponseType . getResponseType

157163

158−xmlHttpRequestGetStatus :: XMLHttpRequest -> IO Word

164+xmlHttpRequestGetStatus :: MonadJSM m => XMLHttpRequest -> m Word

159165xmlHttpRequestGetStatus = getStatus

160166

161−xmlHttpRequestGetStatusText :: FromJSString result => XMLHttpRequest -> IO result

167+xmlHttpRequestGetStatusText :: MonadJSM m => FromJSString result => XMLHttpRequest -> m result

162168xmlHttpRequestGetStatusText = getStatusText

163169

164−xmlHttpRequestGetResponseURL :: FromJSString result => XMLHttpRequest -> IO result

170+xmlHttpRequestGetResponseURL :: (FromJSString result, MonadJSM m) => XMLHttpRequest -> m result

165171xmlHttpRequestGetResponseURL = getResponseURL

166172

167−xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)

173+xmlHttpRequestGetResponse :: MonadJSM m => XMLHttpRequest -> m (Maybe XhrResponseBody)

168174xmlHttpRequestGetResponse xhr = do

169175 mr <- getResponse xhr

170176 rt <- xmlHttpRequestGetResponseType xhr

171177 case rt of

172− Just XhrResponseType_Blob -> return $ XhrResponseBody_Blob . castToBlob <$> mr

178+ Just XhrResponseType_Blob -> fmap XhrResponseBody_Blob . join <$> mapM (castTo Blob) mr

173179 Just XhrResponseType_Text -> Just . XhrResponseBody_Text <$> xmlHttpRequestGetStatusText xhr

174180 Just XhrResponseType_Default -> Just . XhrResponseBody_Text <$> xmlHttpRequestGetStatusText xhr

175181 Just XhrResponseType_ArrayBuffer -> case fmap unGObject mr of

176182 Nothing -> return Nothing

177− Just ptr -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer ptr ptr

183+ Just ptr -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer (pFromJSVal ptr)

178184 _ -> return Nothing

179185

186+bsFromArrayBuffer :: MonadJSM m => JS.MutableArrayBuffer -> m ByteString

187+bsFromArrayBuffer ab = liftJSM $ JS.unsafeFreeze ab >>=

188+ ghcjsPure . JS.createFromArrayBuffer >>= ghcjsPure . JS.toByteString 0 Nothing

src/Reflex/Dom/Xhr/ResponseType.hs → reflex-dom-core/src/Reflex/Dom/Xhr/ResponseType.hsrenamed+1−1

@@ -17,5 +17,5 @@ data XhrResponseBody = XhrResponseBody_Default Text

1717 | XhrResponseBody_Text Text

1818 | XhrResponseBody_Blob Blob

1919 | XhrResponseBody_ArrayBuffer ByteString

20− deriving (Eq)

20+-- deriving (Eq)

2121

test/BrokenHaltSpec.hs → reflex-dom-core/test/BrokenHaltSpec.hsrenamed

The content is the same.

test/HaltSpec.hs → reflex-dom-core/test/HaltSpec.hsrenamed

The content is the same.

test/hlint.hs → reflex-dom-core/test/hlint.hsrenamed

The content is the same.

reflex-dom/LICENSEnew file+12

@@ -0,0 +1,12 @@

4+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:

6+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.

8+2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.

10+3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.

11+

12+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

reflex-dom/Setup.hsnew file+2

@@ -0,0 +1,2 @@

1+import Distribution.Simple

2+main = defaultMain

reflex-dom/reflex-dom.cabalnew file+71

@@ -0,0 +1,71 @@

1+Name: reflex-dom

2+Version: 0.4

3+Synopsis: Functional Reactive Web Apps with Reflex

4+Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine

5+License: BSD3

6+License-file: LICENSE

7+Author: Ryan Trinkle

8+Maintainer: ryan.trinkle@gmail.com

9+Stability: Experimental

10+Category: FRP, Web, GUI, HTML, Javascript, Reactive, Reactivity, User Interfaces, User-interface

11+Build-type: Simple

12+cabal-version: >=1.24

13+-- Deal with https://github.com/haskell/cabal/issues/2544 / https://github.com/haskell/cabal/issues/367

14+extra-source-files: src/Reflex/Dom/Xhr/Foreign.hs

15+ src/Reflex/Dom/WebSocket/Foreign.hs

16+ src/Reflex/Dom/Xhr/ResponseType.hs

17+ src/Reflex/Dom/Xhr/Exception.hs

18+

19+flag webkit2gtk

20+ description: Use WebKit2 version of WebKitGTK.

21+ default: True

22+

23+library

24+ hs-source-dirs: src

25+ build-depends:

26+ base >= 4.7 && < 4.10,

27+ bytestring == 0.10.*,

28+ reflex == 0.5.*,

29+ reflex-dom-core >=0.4 && <0.5,

30+ text == 1.2.*

31+ if os(osx) || os(ios)

32+ build-depends:

33+ jsaddle-wkwebview

34+ else

35+ if flag(webkit2gtk)

36+ build-depends:

37+ jsaddle-webkit2gtk

38+ else

39+ build-depends:

40+ jsaddle-webkitgtk

41+

42+ exposed-modules:

43+ Reflex.Dom

44+ Reflex.Dom.Internal

45+ reexported-modules:

46+ Foreign.JavaScript.TH

47+ , Reflex.Dom.Builder.Class

48+ , Reflex.Dom.Builder.Class.Events

49+ , Reflex.Dom.Builder.Immediate

50+ , Reflex.Dom.Builder.InputDisabled

51+ , Reflex.Dom.Builder.Static

52+ , Reflex.Dom.Class

53+ , Reflex.Dom.Core

54+ , Reflex.Dom.Location

55+ , Reflex.Dom.Main

56+ , Reflex.Dom.Old

57+ , Reflex.Dom.Time

58+ , Reflex.Dom.WebSocket

59+ , Reflex.Dom.Widget

60+ , Reflex.Dom.Widget.Basic

61+ , Reflex.Dom.Widget.Input

62+ , Reflex.Dom.Widget.Lazy

63+ , Reflex.Dom.Widget.Resize

64+ , Reflex.Dom.Xhr

65+

66+ ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans

67+

68+source-repository head

69+ type: git

70+ location: https://github.com/reflex-frp/reflex-dom

71+ subdir: reflex-dom

reflex-dom/src/Reflex/Dom.hsnew file+7

@@ -0,0 +1,7 @@

1+module Reflex.Dom (module X) where

3+import Reflex.Dom.Core as X hiding

4+ (mainWidget, mainWidgetWithHead, mainWidgetWithCss,

5+ mainWidgetWithHead', mainWidgetInElementById, runApp')

6+import Reflex.Dom.Internal as X

reflex-dom/src/Reflex/Dom/Internal.hsnew file+46

@@ -0,0 +1,46 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE RankNTypes #-}

3+{-# LANGUAGE TypeFamilies #-}

4+module Reflex.Dom.Internal

5+ (module Main, mainWidget, mainWidgetWithHead, mainWidgetWithCss,

6+ mainWidgetWithHead', mainWidgetInElementById, runApp') where

8+import Data.ByteString (ByteString)

9+import Data.Text (Text)

10+import Reflex.Spider (Spider)

11+import Reflex.Dom.Core (Widget)

12+import Reflex.Dom.Main as Main hiding

13+ (mainWidget, mainWidgetWithHead, mainWidgetWithCss,

14+ mainWidgetWithHead', mainWidgetInElementById, runApp')

15+import qualified Reflex.Dom.Main as Main

16+ (mainWidget, mainWidgetWithHead, mainWidgetWithCss,

17+ mainWidgetWithHead', mainWidgetInElementById, runApp')

18+#ifdef darwin_HOST_OS

19+import Language.Javascript.JSaddle.WKWebView (run)

20+#else

21+import Language.Javascript.JSaddle.WebKitGTK (run)

22+#endif

23+

24+mainWidget :: (forall x. Widget x ()) -> IO ()

25+mainWidget w = run $ Main.mainWidget w

26+{-# INLINE mainWidget #-}

27+

28+mainWidgetWithHead :: (forall x. Widget x ()) -> (forall x. Widget x ()) -> IO ()

29+mainWidgetWithHead h b = run $ Main.mainWidgetWithHead h b

30+{-# INLINE mainWidgetWithHead #-}

31+

32+mainWidgetWithCss :: ByteString -> (forall x. Widget x ()) -> IO ()

33+mainWidgetWithCss css w = run $ Main.mainWidgetWithCss css w

34+{-# INLINE mainWidgetWithCss #-}

35+

36+mainWidgetWithHead' :: (forall x. (a -> Widget x b, b -> Widget x a)) -> IO ()

37+mainWidgetWithHead' w = run $ Main.mainWidgetWithHead' w

38+{-# INLINE mainWidgetWithHead' #-}

39+

40+mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> IO ()

41+mainWidgetInElementById eid w = run $ Main.mainWidgetInElementById eid w

42+{-# INLINE mainWidgetInElementById #-}

43+

44+runApp' :: (t ~ Spider) => (forall x. AppInput t -> Widget x (AppOutput t)) -> IO ()

45+runApp' app = run $ Main.runApp' app

46+{-# INLINE runApp' #-}

src-ghc/Reflex/Dom/Internal/Foreign.hsdeleted−180

@@ -1,180 +0,0 @@

1−{-# LANGUAGE CPP #-}

2−{-# LANGUAGE ForeignFunctionInterface #-}

3−{-# LANGUAGE LambdaCase #-}

4−{-# LANGUAGE OverloadedStrings #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6−module Reflex.Dom.Internal.Foreign where

7−

8−import Control.Concurrent

9−import Control.Exception (bracket)

10−import Control.Lens hiding (set)

11−import Control.Monad

12−import Control.Monad.State.Strict hiding (forM, forM_, get, mapM, mapM_, sequence, sequence_)

13−import Data.ByteString (ByteString)

14−import qualified Data.ByteString as BS

15−import Data.Maybe

16−import Data.Monoid

17−import Data.Text (Text)

18−import qualified Data.Text as T

19−import Foreign.Marshal hiding (void)

20−import Foreign.Ptr

21−import GHCJS.DOM hiding (runWebGUI)

22−import GHCJS.DOM.Navigator

23−import GHCJS.DOM.Window

24−import Graphics.UI.Gtk hiding (Widget)

25−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

26−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef

27−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

28−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

29−import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame

30−import Graphics.UI.Gtk.WebKit.Types hiding (Event, Text, Widget)

31−import Graphics.UI.Gtk.WebKit.WebFrame

32−import Graphics.UI.Gtk.WebKit.WebInspector

33−import Graphics.UI.Gtk.WebKit.WebSettings

34−import Graphics.UI.Gtk.WebKit.WebView

35−import System.Directory

36−import System.Glib.FFI hiding (void)

37−

38−#ifndef mingw32_HOST_OS

39−import System.Posix.Signals

40−#endif

41−

42−quitWebView :: WebView -> IO ()

43−quitWebView wv = postGUIAsync $ do w <- widgetGetToplevel wv --TODO: Shouldn't this be postGUISync?

44− widgetDestroy w

45−

46−installQuitHandler :: WebView -> IO ()

47−#ifdef mingw32_HOST_OS

48−installQuitHandler wv = return () -- TODO: Maybe figure something out here for Windows users.

49−#else

50−installQuitHandler wv = void $ installHandler keyboardSignal (Catch (quitWebView wv)) Nothing

51−#endif

52−

53−makeDefaultWebView :: Text -> (WebView -> IO ()) -> IO ()

54−makeDefaultWebView userAgentKey main = do

55− _ <- initGUI

56− window <- windowNew

57− _ <- timeoutAddFull (yield >> return True) priorityHigh 10

58− windowSetDefaultSize window 900 600

59− windowSetPosition window WinPosCenter

60− scrollWin <- scrolledWindowNew Nothing Nothing

61− webView <- webViewNew

62− settings <- webViewGetWebSettings webView

63− userAgent <- settings `get` webSettingsUserAgent

64− settings `set` [ webSettingsUserAgent := userAgent <> " " <> userAgentKey

65− , webSettingsEnableUniversalAccessFromFileUris := True

66− , webSettingsEnableDeveloperExtras := True

67− ]

68− webViewSetWebSettings webView settings

69− window `containerAdd` scrollWin

70− scrollWin `containerAdd` webView

71− _ <- on window objectDestroy . liftIO $ mainQuit

72− widgetShowAll window

73− _ <- webView `on` loadFinished $ \_ -> do

74− main webView --TODO: Should probably only do this once

75− inspector <- webViewGetInspector webView

76− _ <- inspector `on` inspectWebView $ \_ -> do

77− inspectorWindow <- windowNew

78− windowSetDefaultSize inspectorWindow 900 600

79− inspectorScrollWin <- scrolledWindowNew Nothing Nothing

80− inspectorWebView <- webViewNew

81− inspectorWindow `containerAdd` inspectorScrollWin

82− inspectorScrollWin `containerAdd` inspectorWebView

83− widgetShowAll inspectorWindow

84− return inspectorWebView

85− wf <- webViewGetMainFrame webView

86− pwd <- getCurrentDirectory

87− webFrameLoadString wf "" Nothing $ "file://" <> pwd <> "/"

88− installQuitHandler webView

89− mainGUI

90−

91−runWebGUI :: (WebView -> IO ()) -> IO ()

92−runWebGUI = runWebGUI' "GHCJS"

93−

94−runWebGUI' :: Text -> (WebView -> IO ()) -> IO ()

95−runWebGUI' userAgentKey main = do

96− -- Are we in a java script inside some kind of browser

97− mbWindow <- currentWindow

98− case mbWindow of

99− Just window -> do

100− -- Check if we are running in javascript inside the the native version

101− Just n <- getNavigator window

102− agent <- getUserAgent n

103− unless ((" " <> userAgentKey) `T.isSuffixOf` agent) $ main (castToWebView window)

104− Nothing -> do

105− makeDefaultWebView userAgentKey main

106−

107−foreign import ccall "wrapper"

108− wrapper :: JSObjectCallAsFunctionCallback' -> IO JSObjectCallAsFunctionCallback

109−

110−toJSObject :: JSContextRef -> [Ptr OpaqueJSValue] -> IO JSObjectRef

111−toJSObject ctx args = do

112− o <- jsobjectmake ctx nullPtr nullPtr

113− iforM_ args $ \n a -> do

114− prop <- jsstringcreatewithutf8cstring $ show n

115− jsobjectsetproperty ctx o prop a 1 nullPtr

116− return o

117−

118−fromJSStringMaybe :: JSContextRef -> JSValueRef -> IO (Maybe Text)

119−fromJSStringMaybe c t = do

120− isNull <- jsvalueisnull c t

121− if isNull then return Nothing else do

122− j <- jsvaluetostringcopy c t nullPtr

123− l <- jsstringgetmaximumutf8cstringsize j

124− s <- allocaBytes (fromIntegral l) $ \ps -> do

125− _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)

126− peekCString ps

127− return $ Just $ T.pack s

128−

129−fromJSBoolMaybe :: JSContextRef -> JSValueRef -> IO (Maybe Bool)

130−fromJSBoolMaybe c t = do

131− isBool <- jsvalueisboolean c t

132− if not isBool then return Nothing else

133− Just <$> jsvaluetoboolean c t

134−

135−fromJSNumMaybe :: JSContextRef -> JSValueRef -> IO (Maybe Double)

136−fromJSNumMaybe c t = do

137− isNum <- jsvalueisnumber c t

138− if not isNum then return Nothing else

139− Just <$> jsvaluetonumber c t nullPtr

140−

141−getLocationHost :: WebView -> IO Text

142−getLocationHost wv = withWebViewContext wv $ \c -> do

143− script <- jsstringcreatewithutf8cstring "location.host"

144− lh <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

145− lh' <- fromJSStringMaybe c lh

146− return $ fromMaybe "" lh'

147−

148−getLocationProtocol :: WebView -> IO Text

149−getLocationProtocol wv = withWebViewContext wv $ \c -> do

150− script <- jsstringcreatewithutf8cstring "location.protocol"

151− lp <- jsevaluatescript c script nullPtr nullPtr 1 nullPtr

152− lp' <- fromJSStringMaybe c lp

153− return $ fromMaybe "" lp'

154−

155−bsToArrayBuffer :: JSContextRef -> ByteString -> IO JSValueRef

156−bsToArrayBuffer c bs = do

157− elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x

158− let numElems = length elems

159− bracket (mallocArray numElems) free $ \elemsArr -> do

160− pokeArray elemsArr elems

161− a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr

162− newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"

163− jsevaluatescript c newUint8Array a nullPtr 1 nullPtr

164−

165−bsFromArrayBuffer :: JSContextRef -> JSValueRef -> IO ByteString

166−bsFromArrayBuffer c a = do

167− let getIntegral = fmap round . (\x -> jsvaluetonumber c x nullPtr)

168− getByteLength <- jsstringcreatewithutf8cstring "this.byteLength"

169− byteLength <- getIntegral =<< jsevaluatescript c getByteLength a nullPtr 1 nullPtr

170− toUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"

171− uint8Array <- jsevaluatescript c toUint8Array a nullPtr 1 nullPtr

172− getIx <- jsstringcreatewithutf8cstring "this[0][this[1]]"

173− let arrayLookup i = do

174− i' <- jsvaluemakenumber c (fromIntegral i)

175− args <- toJSObject c [uint8Array, i']

176− getIntegral =<< jsevaluatescript c getIx args nullPtr 1 nullPtr

177− BS.pack <$> forM [0..byteLength-1] arrayLookup

178−

179−withWebViewContext :: WebView -> (JSContextRef -> IO a) -> IO a

180−withWebViewContext wv f = f =<< webFrameGetGlobalContext =<< webViewGetMainFrame wv

src-ghc/Reflex/Dom/WebSocket/Foreign.hsdeleted−130

@@ -1,130 +0,0 @@

1−{-# LANGUAGE AllowAmbiguousTypes #-}

2−{-# LANGUAGE ConstraintKinds #-}

3−{-# LANGUAGE FlexibleContexts #-}

4−{-# LANGUAGE FlexibleInstances #-}

5−{-# LANGUAGE GADTs #-}

6−{-# LANGUAGE JavaScriptFFI #-}

7−{-# LANGUAGE MultiParamTypeClasses #-}

8−{-# LANGUAGE NoMonomorphismRestriction #-}

9−{-# LANGUAGE PolyKinds #-}

10−{-# LANGUAGE RankNTypes #-}

11−{-# LANGUAGE ScopedTypeVariables #-}

12−{-# LANGUAGE TemplateHaskell #-}

13−{-# LANGUAGE TypeFamilies #-}

14−{-# LANGUAGE UndecidableInstances #-}

15−

16−module Reflex.Dom.WebSocket.Foreign where

17−

18−import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)

19−

20−import Control.Exception

21−import Control.Monad.State

22−import Data.ByteString (ByteString)

23−import qualified Data.ByteString as BS

24−import Data.Maybe (fromMaybe)

25−import Data.Text (Text)

26−import qualified Data.Text as T

27−import Data.Text.Encoding

28−import Foreign.Marshal hiding (void)

29−import Foreign.Ptr

30−import Foreign.Storable

31−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

32−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef

33−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

34−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

35−import Graphics.UI.Gtk.WebKit.WebView

36−

37−import Foreign.JavaScript.TH

38−import Reflex.Dom.Internal.Foreign

39−

40−data JSWebSocket = JSWebSocket { wsValue :: JSValueRef

41− , wsContext :: JSContextRef

42− }

43−

44−importJS Unsafe "this[0]['send'](this[1])" "_sendWSTextData" [t| forall x m. MonadJS x m => JSRef x -> String -> m () |]

45−

46−sendWSTextData :: JSWebSocket -> String -> IO ()

47−sendWSTextData (JSWebSocket ws c) str = runWithJSContext (_sendWSTextData (JSRef_JavaScriptCore ws) str) c

48−

49−class IsWebSocketMessage a where

50− webSocketSend :: JSWebSocket -> a -> IO ()

51−

52−-- Use binary websocket communication for ByteString

53−instance IsWebSocketMessage ByteString where

54− webSocketSend (JSWebSocket ws c) bs = do

55− elems <- forM (BS.unpack bs) $ \x -> jsvaluemakenumber c $ fromIntegral x

56− let numElems = length elems

57− bs' <- bracket (mallocArray numElems) free $ \elemsArr -> do

58− pokeArray elemsArr elems

59− a <- jsobjectmakearray c (fromIntegral numElems) elemsArr nullPtr

60− newUint8Array <- jsstringcreatewithutf8cstring "new Uint8Array(this)"

61− jsevaluatescript c newUint8Array a nullPtr 1 nullPtr

62− send <- jsstringcreatewithutf8cstring ""

63− sendArgs <- toJSObject c [ws, bs']

64− _ <- jsevaluatescript c send sendArgs nullPtr 1 nullPtr

65− return ()

66−

67−-- Use plaintext websocket communication for Text

68−instance IsWebSocketMessage Text where

69− webSocketSend jws t = sendWSTextData jws (T.unpack t)

70−

71−importJS Unsafe "this[0]['close'](this[1], this[2])" "_closeWS" [t| forall x m. MonadJS x m => JSRef x -> Double -> String -> m () |]

72−

73−closeWebSocket :: JSWebSocket -> Double -> Text -> IO ()

74−closeWebSocket (JSWebSocket ws c) code reason = do

75− runWithJSContext (_closeWS (JSRef_JavaScriptCore ws) code (T.unpack reason)) c

76−

77−newWebSocket

78− :: WebView

79− -> Text -- url

80− -> (Either ByteString a -> IO ()) -- onmessage

81− -> IO () -- onopen

82− -> IO () -- onerror

83− -> ((Bool, Word, Text) -> IO ()) -- onclose

84− -> IO JSWebSocket

85−newWebSocket wv url onMessage onOpen onError onClose = withWebViewContext wv $ \c -> do

86− url' <- jsvaluemakestring c =<< jsstringcreatewithutf8cstring (T.unpack url)

87− newWSArgs <- toJSObject c [url']

88− newWS <- jsstringcreatewithutf8cstring "(function(that) { var ws = new WebSocket(that[0]); ws['binaryType'] = 'arraybuffer'; return ws; })(this)"

89− ws <- jsevaluatescript c newWS newWSArgs nullPtr 1 nullPtr

90− onMessage' <- wrapper $ \_ _ _ _ args _ -> do

91− e <- peekElemOff args 0

92− dataProp <- jsstringcreatewithutf8cstring "data"

93− msg <- jsobjectgetproperty c e dataProp nullPtr

94− msg' <- fromJSStringMaybe c msg

95− case msg' of

96− Nothing -> return ()

97− Just m -> onMessage $ Left $ encodeUtf8 m

98− jsvaluemakeundefined c

99− onMessageCb <- jsobjectmakefunctionwithcallback c nullPtr onMessage'

100− onOpen' <- wrapper $ \_ _ _ _ _ _ -> do

101− onOpen

102− jsvaluemakeundefined c

103− onOpenCb <- jsobjectmakefunctionwithcallback c nullPtr onOpen'

104− onError' <- wrapper $ \_ _ _ _ _ _ -> do

105− onError

106− jsvaluemakeundefined c

107− onErrorCb <- jsobjectmakefunctionwithcallback c nullPtr onError'

108− onClose' <- wrapper $ \_ _ _ _ args _ -> do

109− e <- peekElemOff args 0

110− propWasClean <- jsstringcreatewithutf8cstring "wasClean"

111− propCode <- jsstringcreatewithutf8cstring "code"

112− propReason <- jsstringcreatewithutf8cstring "reason"

113− wasClean <- fmap (fromMaybe False) $ fromJSBoolMaybe c

114− =<< jsobjectgetproperty c e propWasClean nullPtr

115− code <- fmap (fromMaybe 1000) $ fromJSNumMaybe c

116− =<< jsobjectgetproperty c e propCode nullPtr

117− reason <- fmap (fromMaybe mempty) $ fromJSStringMaybe c

118− =<< jsobjectgetproperty c e propReason nullPtr

119− onClose (wasClean, truncate code, reason)

120− jsvaluemakeundefined c

121− onCloseCb <- jsobjectmakefunctionwithcallback c nullPtr onClose'

122− o <- toJSObject c [ws, onMessageCb, onOpenCb, onErrorCb, onCloseCb]

123− addCbs <- jsstringcreatewithutf8cstring "this[0]['onmessage'] = this[1]; this[0]['onopen'] = this[2]; this[0]['onerror'] = this[3]; this[0]['onclose'] = this[4];"

124− _ <- jsevaluatescript c addCbs o nullPtr 1 nullPtr

125− return $ JSWebSocket ws c

126−

127−onBSMessage :: Either ByteString b -> ByteString

128−onBSMessage = either id (error "onBSMessage: ghc env expects ByteString.")

129−

130−type JSVal = ()

src-ghc/Reflex/Dom/Xhr/Foreign.hsdeleted−248

@@ -1,248 +0,0 @@

1−{-# LANGUAGE FlexibleInstances #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−{-# LANGUAGE QuasiQuotes #-}

4−{-# LANGUAGE TypeSynonymInstances #-}

5−module Reflex.Dom.Xhr.Foreign ( module Reflex.Dom.Xhr.Foreign

6− , XhrResponseType

7− ) where

8−

9−import Control.Concurrent.MVar

10−import Control.Exception.Base

11−import Control.Monad

12−import Data.Text (Text)

13−import qualified Data.Text as T

14−import GHCJS.DOM.File

15−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase

16−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef

17−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef

18−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef

19−import Graphics.UI.Gtk.WebKit.Types hiding (Text)

20−import Reflex.Dom.Xhr.Exception

21−import Reflex.Dom.Xhr.ResponseType

22−import System.Glib.FFI

23−

24−import Reflex.Dom.Internal.Foreign

25−

26−import Text.RawString.QQ

27−

28−data XMLHttpRequest

29− = XMLHttpRequest { xhrValue :: JSValueRef

30− , xhrContext :: JSContextRef --TODO: Get rid of this

31− }

32− deriving (Eq, Ord)

33−

34−class IsXhrPayload a where

35− xmlHttpRequestSend :: XMLHttpRequest -> a -> IO ()

36−

37−instance IsXhrPayload () where

38− xmlHttpRequestSend xhr _ = xmlHttpRequestSendPayload xhr Nothing

39−

40−instance IsXhrPayload Text where

41− xmlHttpRequestSend xhr = xmlHttpRequestSendPayload xhr . Just

42−

43−instance IsXhrPayload String where

44− xmlHttpRequestSend xhr = xmlHttpRequestSendPayload xhr . Just . T.pack

45−

46−instance IsXhrPayload File where

47− xmlHttpRequestSend = error "xmlHttpRequestSend{File}: not implemented"

48−

49−stringToJSValue :: JSContextRef -> Text -> IO JSValueRef

50−stringToJSValue ctx s = jsvaluemakestring ctx =<< jsstringcreatewithutf8cstring (T.unpack s)

51−

52−fromResponseType :: XhrResponseType -> Text

53−fromResponseType XhrResponseType_Default = ""

54−fromResponseType XhrResponseType_ArrayBuffer = "arraybuffer"

55−fromResponseType XhrResponseType_Blob = "blob"

56−fromResponseType XhrResponseType_Text = "text"

57−

58−toResponseType :: Text -> Maybe XhrResponseType

59−toResponseType "" = Just XhrResponseType_Default

60−toResponseType "arraybuffer" = Just XhrResponseType_ArrayBuffer

61−toResponseType "blob" = Just XhrResponseType_Blob

62−toResponseType "text" = Just XhrResponseType_Text

63−toResponseType _ = Nothing

64−

65−xmlHttpRequestNew :: WebView -> IO XMLHttpRequest

66−xmlHttpRequestNew wv = withWebViewContext wv $ \jsContext -> do

67− xhrScript <- jsstringcreatewithutf8cstring "new XMLHttpRequest()"

68− xhr' <- jsevaluatescript jsContext xhrScript nullPtr nullPtr 1 nullPtr

69− jsvalueprotect jsContext xhr'

70− return $ XMLHttpRequest xhr' jsContext

71−

72−xmlHttpRequestOpen :: XMLHttpRequest -> Text -> Text -> Bool -> Text -> Text -> IO ()

73−xmlHttpRequestOpen xhr method url async user password = do

74− let c = xhrContext xhr

75− method' <- stringToJSValue c method

76− url' <- stringToJSValue c url

77− async' <- jsvaluemakeboolean (xhrContext xhr) async

78− user' <- stringToJSValue c user

79− password' <- stringToJSValue c password

80− o <- toJSObject c [xhrValue xhr, method', url', async', user', password']

81− script <- jsstringcreatewithutf8cstring "this[0].open(this[1], this[2], this[3], this[4], this[5])"

82− _ <- jsevaluatescript c script o nullPtr 1 nullPtr

83− return ()

84−

85−xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> IO () -> IO ()

86−xmlHttpRequestOnreadystatechange xhr userCallback = do

87− let c = xhrContext xhr

88− fp <- wrapper $ \_ _ _ _ _ _ -> do

89− userCallback

90− jsvaluemakeundefined c

91− cb <- jsobjectmakefunctionwithcallback c nullPtr fp

92− o <- toJSObject c [xhrValue xhr, cb]

93− script <- jsstringcreatewithutf8cstring "this[0].onreadystatechange=this[1]"

94− _ <- jsevaluatescript c script o nullPtr 1 nullPtr

95− return ()

96−

97−xmlHttpRequestGetReadyState :: XMLHttpRequest -> IO Word

98−xmlHttpRequestGetReadyState xhr = do

99− let c = xhrContext xhr

100− script <- jsstringcreatewithutf8cstring "this.readyState"

101− rs <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr

102− d <- jsvaluetonumber c rs nullPtr

103− return $ truncate d

104−

105−xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO (Maybe XhrResponseType)

106−xmlHttpRequestGetResponseType xhr = do

107− script <- jsstringcreatewithutf8cstring "this.responseType"

108− rt <- jsevaluatescript (xhrContext xhr) script (xhrValue xhr) nullPtr 1 nullPtr

109− ms <- fromJSStringMaybe (xhrContext xhr) rt

110− return $ join $ fmap toResponseType ms

111−

112−xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)

113−xmlHttpRequestGetResponse xhr = do

114− let c = xhrContext xhr

115− mrt <- xmlHttpRequestGetResponseType xhr

116− script <- jsstringcreatewithutf8cstring "this.response"

117− t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr

118− isNull <- jsvalueisnull c t

119− if isNull then return Nothing else case mrt of

120− Just XhrResponseType_ArrayBuffer -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer c t

121− Just XhrResponseType_Blob -> Just . XhrResponseBody_Blob . Blob . castForeignPtr <$> newForeignPtr_ t

122− Just XhrResponseType_Default -> fmap XhrResponseBody_Default <$> fromJSStringMaybe c t

123− Just XhrResponseType_Text -> fmap XhrResponseBody_Text <$> fromJSStringMaybe c t

124− _ -> return Nothing

125−

126−xmlHttpRequestGetResponseText :: XMLHttpRequest -> IO (Maybe Text)

127−xmlHttpRequestGetResponseText xhr = do

128− let c = xhrContext xhr

129− script <- jsstringcreatewithutf8cstring "this.responseText"

130− t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr

131− fromJSStringMaybe c t

132−

133−xmlHttpRequestSendPayload :: XMLHttpRequest -> Maybe Text -> IO ()

134−xmlHttpRequestSendPayload xhr payload = do

135− let c = xhrContext xhr

136− result <- newEmptyMVar

137− let wrapper' x = wrapper $ \_ _ _ _ _ _ -> putMVar result x >> jsvaluemakeundefined c

138− bracket (wrapper' $ Just XhrException_Aborted) freeHaskellFunPtr $ \a -> do

139− onAbort <- jsobjectmakefunctionwithcallback c nullPtr a

140− bracket (wrapper' $ Just XhrException_Error) freeHaskellFunPtr $ \e -> do

141− onError <- jsobjectmakefunctionwithcallback c nullPtr e

142− bracket (wrapper' Nothing) freeHaskellFunPtr $ \l -> do

143− onLoad <- jsobjectmakefunctionwithcallback c nullPtr l

144− d <- case payload of

145− Nothing -> jsvaluemakeundefined c

146− Just payload' -> stringToJSValue c payload'

147− o <- toJSObject c [xhrValue xhr, d, onError, onAbort, onLoad]

148− s <- jsstringcreatewithutf8cstring send

149− _ <- jsevaluatescript c s o nullPtr 1 nullPtr

150− takeMVar result >>= mapM_ throwIO

151− where

152− send = [r|

153− (function (xhr, d, onError, onAbort, onLoad) {

154− var clear;

155− var error = function () {

156− clear(); onError();

157− };

158− var abort = function () {

159− clear(); onAbort();

160− };

161− var load = function () {

162− clear(); onLoad();

163− };

164− clear = function () {

165− xhr.removeEventListener('error', error);

166− xhr.removeEventListener('abort', abort);

167− xhr.removeEventListener('load', load);

168− }

169− xhr.addEventListener('error', error);

170− xhr.addEventListener('abort', abort);

171− xhr.addEventListener('load', load);

172− if(d) {

173− xhr.send(d);

174− } else {

175− xhr.send();

176− }

177− })(this[0], this[1], this[2], this[3], this[4])

178− |]

179−

180−xmlHttpRequestSetRequestHeader :: XMLHttpRequest -> Text -> Text -> IO ()

181−xmlHttpRequestSetRequestHeader xhr header value = do

182− let c = xhrContext xhr

183− header' <- stringToJSValue c header

184− value' <- stringToJSValue c value

185− o <- toJSObject c [xhrValue xhr, header', value']

186− script <- jsstringcreatewithutf8cstring "this[0].setRequestHeader(this[1], this[2])"

187− _ <- jsevaluatescript c script o nullPtr 1 nullPtr

188− return ()

189−

190−xmlHttpRequestSetResponseType :: XMLHttpRequest -> Text -> IO ()

191−xmlHttpRequestSetResponseType xhr t = do

192− let c = xhrContext xhr

193− t' <- stringToJSValue c t

194− o <- toJSObject c [xhrValue xhr, t']

195− script <- jsstringcreatewithutf8cstring "this[0].responseType = this[1]"

196− _ <- jsevaluatescript c script o nullPtr 1 nullPtr

197− return ()

198−

199−xmlHttpRequestGetStatus :: XMLHttpRequest -> IO Word

200−xmlHttpRequestGetStatus xhr = do

201− let c = xhrContext xhr

202− script <- jsstringcreatewithutf8cstring "this.status"

203− s <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr

204− d <- jsvaluetonumber c s nullPtr

205− return $ truncate d

206−

207−xmlHttpRequestGetStatusText :: XMLHttpRequest -> IO Text

208−xmlHttpRequestGetStatusText xhr =

209− xmlAuxHttpRequestGetWithJS xhr "this.statusText"

210−

211−xmlHttpRequestSetWithCredentials :: XMLHttpRequest -> Bool -> IO ()

212−xmlHttpRequestSetWithCredentials xhr b = do

213− let c = xhrContext xhr

214− b' <- jsvaluemakeboolean c b

215− o <- toJSObject c [xhrValue xhr, b']

216− script <- jsstringcreatewithutf8cstring "this[0].withCredentials = this[1]"

217− _ <- jsevaluatescript c script o nullPtr 1 nullPtr

218− return ()

219−

220−xmlHttpRequestGetAllResponseHeaders :: XMLHttpRequest -> IO Text

221−xmlHttpRequestGetAllResponseHeaders xhr =

222− xmlAuxHttpRequestGetWithJS xhr "this.getAllResponseHeaders()"

223−

224−xmlHttpRequestGetResponseHeader :: XMLHttpRequest -> Text -> IO Text

225−xmlHttpRequestGetResponseHeader xhr hdr = do

226− let c = xhrContext xhr

227− t' <- stringToJSValue c hdr

228− o <- toJSObject c [xhrValue xhr, t']

229− script <- jsstringcreatewithutf8cstring "this[0].getResponseHeader(this[1])"

230− t <- jsevaluatescript c script o nullPtr 1 nullPtr

231− xmlAuxJsGetString c t

232−

233−xmlAuxHttpRequestGetWithJS :: XMLHttpRequest -> String -> IO Text

234−xmlAuxHttpRequestGetWithJS xhr jsScript = do

235− let c = xhrContext xhr

236− script <- jsstringcreatewithutf8cstring jsScript

237− t <- jsevaluatescript c script (xhrValue xhr) nullPtr 1 nullPtr

238− xmlAuxJsGetString c t

239−

240−xmlAuxJsGetString :: JSContextRef -> JSValueRef -> IO Text

241−xmlAuxJsGetString c t = do

242− j <- jsvaluetostringcopy c t nullPtr

243− l <- jsstringgetmaximumutf8cstringsize j

244− s <- allocaBytes (fromIntegral l) $ \ps -> do

245− _ <- jsstringgetutf8cstring'_ j ps (fromIntegral l)

246− peekCString ps

247− return $ T.pack s

248−

src-ghcjs/Reflex/Dom/Internal/Foreign.hsdeleted−43

@@ -1,43 +0,0 @@

1−{-# LANGUAGE ForeignFunctionInterface #-}

2−{-# LANGUAGE JavaScriptFFI #-}

3−module Reflex.Dom.Internal.Foreign ( module Reflex.Dom.Internal.Foreign

4− , runWebGUI

5− ) where

6−

7−import Data.ByteString (ByteString)

8−import qualified Data.ByteString as BS

9−import Foreign

10−import Foreign.C

11−import qualified GHCJS.Buffer as JS

12−import GHCJS.DOM

13−import GHCJS.DOM.Types

14−import qualified GHCJS.Marshal.Pure as JS

15−import GHCJS.Types

16−import JavaScript.TypedArray.ArrayBuffer as JS

17−

18−quitWebView :: WebView -> IO ()

19−quitWebView = error "quitWebView: unimplemented in GHCJS"

20−

21−foreign import javascript unsafe "location['host']" getLocationHost_ :: IO JSString

22−

23−getLocationHost :: FromJSString r => a -> IO r

24−getLocationHost _ = fmap fromJSString getLocationHost_

25−

26−foreign import javascript unsafe "location['protocol']" getLocationProtocol_ :: IO JSString

27−

28−getLocationProtocol :: FromJSString r => a -> IO r

29−getLocationProtocol _ = fmap fromJSString getLocationProtocol_

30−

31−withWebViewContext :: a -> (a -> IO b) -> IO b

32−withWebViewContext a f = f a

33−

34−foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal

35−

36−foreign import javascript unsafe "new Uint8Array($1_1['buf'], $1_2, $2)['buffer']" extractByteArray :: Ptr CChar -> Int -> IO JSVal

37−

38−bsToArrayBuffer :: a -> ByteString -> IO JSVal

39−bsToArrayBuffer _ bs = BS.useAsCString bs $ \cStr -> do

40− extractByteArray cStr $ BS.length bs

41−

42−bsFromArrayBuffer :: a -> JSVal -> IO ByteString

43−bsFromArrayBuffer _ ab = fmap (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JS.unsafeFreeze $ JS.pFromJSVal ab

src/Reflex/Dom/Builder/Class/Events.hsdeleted−158

@@ -1,158 +0,0 @@

1−{-# LANGUAGE DataKinds #-}

2−{-# LANGUAGE GADTs #-}

3−{-# LANGUAGE KindSignatures #-}

4−{-# LANGUAGE PolyKinds #-}

5−{-# LANGUAGE TemplateHaskell #-}

6−{-# LANGUAGE TypeFamilies #-}

7−module Reflex.Dom.Builder.Class.Events where

8−

9−import Data.GADT.Compare.TH

10−

11−data EventTag

12− = AbortTag

13− | BlurTag

14− | ChangeTag

15− | ClickTag

16− | ContextmenuTag

17− | DblclickTag

18− | DragTag

19− | DragendTag

20− | DragenterTag

21− | DragleaveTag

22− | DragoverTag

23− | DragstartTag

24− | DropTag

25− | ErrorTag

26− | FocusTag

27− | InputTag

28− | InvalidTag

29− | KeydownTag

30− | KeypressTag

31− | KeyupTag

32− | LoadTag

33− | MousedownTag

34− | MouseenterTag

35− | MouseleaveTag

36− | MousemoveTag

37− | MouseoutTag

38− | MouseoverTag

39− | MouseupTag

40− | MousewheelTag

41− | ScrollTag

42− | SelectTag

43− | SubmitTag

44− | WheelTag

45− | BeforecutTag

46− | CutTag

47− | BeforecopyTag

48− | CopyTag

49− | BeforepasteTag

50− | PasteTag

51− | ResetTag

52− | SearchTag

53− | SelectstartTag

54− | TouchstartTag

55− | TouchmoveTag

56− | TouchendTag

57− | TouchcancelTag

58−

59−data EventName :: EventTag -> * where

60− Abort :: EventName 'AbortTag

61− Blur :: EventName 'BlurTag

62− Change :: EventName 'ChangeTag

63− Click :: EventName 'ClickTag

64− Contextmenu :: EventName 'ContextmenuTag

65− Dblclick :: EventName 'DblclickTag

66− Drag :: EventName 'DragTag

67− Dragend :: EventName 'DragendTag

68− Dragenter :: EventName 'DragenterTag

69− Dragleave :: EventName 'DragleaveTag

70− Dragover :: EventName 'DragoverTag

71− Dragstart :: EventName 'DragstartTag

72− Drop :: EventName 'DropTag

73− Error :: EventName 'ErrorTag

74− Focus :: EventName 'FocusTag

75− Input :: EventName 'InputTag

76− Invalid :: EventName 'InvalidTag

77− Keydown :: EventName 'KeydownTag

78− Keypress :: EventName 'KeypressTag

79− Keyup :: EventName 'KeyupTag

80− Load :: EventName 'LoadTag

81− Mousedown :: EventName 'MousedownTag

82− Mouseenter :: EventName 'MouseenterTag

83− Mouseleave :: EventName 'MouseleaveTag

84− Mousemove :: EventName 'MousemoveTag

85− Mouseout :: EventName 'MouseoutTag

86− Mouseover :: EventName 'MouseoverTag

87− Mouseup :: EventName 'MouseupTag

88− Mousewheel :: EventName 'MousewheelTag

89− Scroll :: EventName 'ScrollTag

90− Select :: EventName 'SelectTag

91− Submit :: EventName 'SubmitTag

92− Wheel :: EventName 'WheelTag

93− Beforecut :: EventName 'BeforecutTag

94− Cut :: EventName 'CutTag

95− Beforecopy :: EventName 'BeforecopyTag

96− Copy :: EventName 'CopyTag

97− Beforepaste :: EventName 'BeforepasteTag

98− Paste :: EventName 'PasteTag

99− Reset :: EventName 'ResetTag

100− Search :: EventName 'SearchTag

101− Selectstart :: EventName 'SelectstartTag

102− Touchstart :: EventName 'TouchstartTag

103− Touchmove :: EventName 'TouchmoveTag

104− Touchend :: EventName 'TouchendTag

105− Touchcancel :: EventName 'TouchcancelTag

106−

107−newtype EventResult en = EventResult { unEventResult :: EventResultType en }

108−

109−type family EventResultType (en :: EventTag) :: * where

110− EventResultType 'ClickTag = ()

111− EventResultType 'DblclickTag = (Int, Int)

112− EventResultType 'KeypressTag = Int

113− EventResultType 'KeydownTag = Int

114− EventResultType 'KeyupTag = Int

115− EventResultType 'ScrollTag = Int

116− EventResultType 'MousemoveTag = (Int, Int)

117− EventResultType 'MousedownTag = (Int, Int)

118− EventResultType 'MouseupTag = (Int, Int)

119− EventResultType 'MouseenterTag = ()

120− EventResultType 'MouseleaveTag = ()

121− EventResultType 'FocusTag = ()

122− EventResultType 'BlurTag = ()

123− EventResultType 'ChangeTag = ()

124− EventResultType 'DragTag = ()

125− EventResultType 'DragendTag = ()

126− EventResultType 'DragenterTag = ()

127− EventResultType 'DragleaveTag = ()

128− EventResultType 'DragoverTag = ()

129− EventResultType 'DragstartTag = ()

130− EventResultType 'DropTag = ()

131− EventResultType 'AbortTag = ()

132− EventResultType 'ContextmenuTag = ()

133− EventResultType 'ErrorTag = ()

134− EventResultType 'InputTag = ()

135− EventResultType 'InvalidTag = ()

136− EventResultType 'LoadTag = ()

137− EventResultType 'MouseoutTag = ()

138− EventResultType 'MouseoverTag = ()

139− EventResultType 'MousewheelTag = ()

140− EventResultType 'SelectTag = ()

141− EventResultType 'SubmitTag = ()

142− EventResultType 'BeforecutTag = ()

143− EventResultType 'CutTag = ()

144− EventResultType 'BeforecopyTag = ()

145− EventResultType 'CopyTag = ()

146− EventResultType 'BeforepasteTag = ()

147− EventResultType 'PasteTag = ()

148− EventResultType 'ResetTag = ()

149− EventResultType 'SearchTag = ()

150− EventResultType 'SelectstartTag = ()

151− EventResultType 'TouchstartTag = ()

152− EventResultType 'TouchmoveTag = ()

153− EventResultType 'TouchendTag = ()

154− EventResultType 'TouchcancelTag = ()

155− EventResultType 'WheelTag = ()

156−

157−deriveGEq ''EventName

158−deriveGCompare ''EventName

src/Reflex/Dom/Location.hsdeleted−13

@@ -1,13 +0,0 @@

1−module Reflex.Dom.Location (getLocationHost, getLocationProtocol) where

2−

3−import Data.Text (Text)

4−import Reflex.Dom.Class

5−import qualified Reflex.Dom.Internal.Foreign as F

6−

7−import Control.Monad.IO.Class

8−

9−getLocationHost :: (MonadIO m) => WebViewSingleton x -> m Text

10−getLocationHost (WebViewSingleton wv) = liftIO $ F.getLocationHost wv

11−

12−getLocationProtocol :: (MonadIO m) => WebViewSingleton x -> m Text

13−getLocationProtocol (WebViewSingleton wv) = liftIO $ F.getLocationProtocol wv