git.iko.soy/reflex-dom
on develop help sign in
Merge branch 'ghcjs-dom-update' of https://github.com/hamishmack/reflex-dom into hamishmack-ghcjs-dom-update
44f2bb4Ryan Trinkle
.gitignore+1
compare with develop
unifiedsplit
@@ -38,3 +38,4 @@ cabal.sandbox.config
38codex.tags
38codex.tags
39*.dump-*
39*.dump-*
40*.verbose-core2core
40*.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
2Version: 0.4
2Version: 0.4
3Synopsis: Functional Reactive Web Apps with Reflex
3Synopsis: Functional Reactive Web Apps with Reflex
4Description: Reflex-DOM is a Functional Reactive web framework based on the Reflex FRP engine
4Description: 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
11Build-type: Simple
11Build-type: Simple
12Cabal-version: >=1.9.2
12Cabal-version: >=1.9.2
13-- Deal with https://github.com/haskell/cabal/issues/2544 / https://github.com/haskell/cabal/issues/367
13-- 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
14+extra-source-files: src/Reflex/Dom/Xhr/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
15+ src/Reflex/Dom/WebSocket/Foreign.hs
20 src/Reflex/Dom/Xhr/ResponseType.hs
16 src/Reflex/Dom/Xhr/ResponseType.hs
21 src/Reflex/Dom/Xhr/Exception.hs
17 src/Reflex/Dom/Xhr/Exception.hs
22
18
19+flag use-template-haskell
20+ description: Use template haskell to generate lenses
21+ default: True
22+ manual: True
23+
23flag use-reflex-optimizer
24flag use-reflex-optimizer
24 description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental.
25 description: Use the GHC plugin Reflex.Optimizer on some of the modules in the package. This is still experimental.
25 default: False
26 default: False
@@ -35,13 +36,13 @@ library
35 blaze-builder,
36 blaze-builder,
36 bytestring == 0.10.*,
37 bytestring == 0.10.*,
37 containers == 0.5.*,
38 containers == 0.5.*,
39+ contravariant >= 1.4 && < 1.5,
38 data-default >= 0.5 && < 0.8,
40 data-default >= 0.5 && < 0.8,
39 dependent-map == 0.2.*,
41 dependent-map == 0.2.*,
40− dependent-sum == 0.3.*,
41− dependent-sum-template >= 0.0.0.4 && < 0.1,
42 directory == 1.2.*,
42 directory == 1.2.*,
43 exception-transformers == 0.4.*,
43 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,
45 -- keycode-0.2 has a bug on firefox
46 -- keycode-0.2 has a bug on firefox
46 keycode >= 0.2.1 && < 0.3,
47 keycode >= 0.2.1 && < 0.3,
47 lens >= 4.7 && < 5,
48 lens >= 4.7 && < 5,
@@ -53,7 +54,6 @@ library
53 reflex == 0.5.*,
54 reflex == 0.5.*,
54 semigroups >= 0.16 && < 0.19,
55 semigroups >= 0.16 && < 0.19,
55 stm == 2.4.*,
56 stm == 2.4.*,
56− template-haskell,
57 text == 1.2.*,
57 text == 1.2.*,
58 these >= 0.4 && < 0.8,
58 these >= 0.4 && < 0.8,
59 time >= 1.4 && < 1.7,
59 time >= 1.4 && < 1.7,
@@ -62,35 +62,24 @@ library
62 zenc == 0.1.*
62 zenc == 0.1.*
63
63
64 if impl(ghcjs)
64 if impl(ghcjs)
65− hs-source-dirs: src-ghcjs
66 build-depends:
65 build-depends:
67 ghcjs-base,
66 ghcjs-base,
68 hashable == 1.2.*
67 hashable == 1.2.*
69 else
68 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
79 if !os(windows)
69 if !os(windows)
80 build-depends: unix == 2.7.*
70 build-depends: unix == 2.7.*
81
71
82 exposed-modules:
72 exposed-modules:
83 Foreign.JavaScript.TH
73 Foreign.JavaScript.TH
84− Reflex.Dom
85 Reflex.Dom.Builder.Class
74 Reflex.Dom.Builder.Class
86 Reflex.Dom.Builder.Class.Events
75 Reflex.Dom.Builder.Class.Events
87 Reflex.Dom.Builder.Immediate
76 Reflex.Dom.Builder.Immediate
88 Reflex.Dom.Builder.InputDisabled
77 Reflex.Dom.Builder.InputDisabled
89 Reflex.Dom.Builder.Static
78 Reflex.Dom.Builder.Static
90 Reflex.Dom.Class
79 Reflex.Dom.Class
91− Reflex.Dom.Internal
80+ Reflex.Dom.Core
92− Reflex.Dom.Internal.Foreign
93 Reflex.Dom.Location
81 Reflex.Dom.Location
82+ Reflex.Dom.Main
94 Reflex.Dom.Old
83 Reflex.Dom.Old
95 Reflex.Dom.Time
84 Reflex.Dom.Time
96 Reflex.Dom.WebSocket
85 Reflex.Dom.WebSocket
@@ -106,18 +95,29 @@ library
106 Reflex.Dom.Xhr.ResponseType
95 Reflex.Dom.Xhr.ResponseType
107 Reflex.Dom.Xhr.Exception
96 Reflex.Dom.Xhr.Exception
108
97
109− other-extensions: TemplateHaskell
110 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans
98 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2 -ferror-spans
111
99
112 if flag(use-reflex-optimizer)
100 if flag(use-reflex-optimizer)
113 ghc-options: -fplugin=Reflex.Optimizer
101 ghc-options: -fplugin=Reflex.Optimizer
114
102
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+
115−test-suite hlint
114+--test-suite hlint
116− build-depends: base, hlint == 1.9.*
115+-- build-depends: base, hlint == 1.9.*
117− hs-source-dirs: test
116+-- hs-source-dirs: test
118− main-is: hlint.hs
117+-- main-is: hlint.hs
119− type: exitcode-stdio-1.0
118+-- type: exitcode-stdio-1.0
120
119
121source-repository head
120source-repository head
122 type: git
121 type: git
123 location: https://github.com/reflex-frp/reflex-dom
122 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 @@
3{-# LANGUAGE ExistentialQuantification #-}
3{-# LANGUAGE ExistentialQuantification #-}
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE FlexibleInstances #-}
6−{-# LANGUAGE ForeignFunctionInterface #-}
7{-# LANGUAGE FunctionalDependencies #-}
6{-# LANGUAGE FunctionalDependencies #-}
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE MultiParamTypeClasses #-}
8{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE RankNTypes #-}
9{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE StandaloneDeriving #-}
10{-# LANGUAGE StandaloneDeriving #-}
11+#ifdef USE_TEMPLATE_HASKELL
12{-# LANGUAGE TemplateHaskell #-}
12{-# LANGUAGE TemplateHaskell #-}
13+#endif
13{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeSynonymInstances #-}
15{-# LANGUAGE TypeSynonymInstances #-}
15{-# LANGUAGE UndecidableInstances #-}
16{-# LANGUAGE UndecidableInstances #-}
17+{-# LANGUAGE ConstraintKinds #-}
16#ifdef __GHCJS__
18#ifdef __GHCJS__
19+{-# LANGUAGE ForeignFunctionInterface #-}
17{-# LANGUAGE JavaScriptFFI #-}
20{-# LANGUAGE JavaScriptFFI #-}
18#endif
21#endif
19module Foreign.JavaScript.TH ( module Foreign.JavaScript.TH
22module Foreign.JavaScript.TH ( module Foreign.JavaScript.TH
23+#ifdef USE_TEMPLATE_HASKELL
20 , Safety (..)
24 , Safety (..)
25+#endif
21 ) where
26 ) where
22
27
28+import Prelude hiding((!!))
23import Reflex.Class
29import Reflex.Class
24import Reflex.DynamicWriter
30import Reflex.DynamicWriter
25import Reflex.Host.Class
31import Reflex.Host.Class
@@ -28,12 +34,15 @@ import Reflex.PerformEvent.Class
28import Reflex.PostBuild.Base
34import Reflex.PostBuild.Base
29import Reflex.Requester.Base
35import Reflex.Requester.Base
30
36
37+#ifdef USE_TEMPLATE_HASKELL
31import Language.Haskell.TH
38import Language.Haskell.TH
39+#endif
32
40
41+import GHCJS.DOM.Types
42+ (toJSString, liftJSM, askJSM, runJSM, JSContextRef,
43+ Node(..), MonadJSM(..), toJSVal, JSVal)
33#ifdef __GHCJS__
44#ifdef __GHCJS__
34import qualified GHCJS.Buffer as JS
45import qualified GHCJS.Buffer as JS
35−import GHCJS.DOM
36−import GHCJS.DOM.Types hiding (Text, fromJSString)
37import qualified GHCJS.DOM.Types as JS
46import qualified GHCJS.DOM.Types as JS
38import qualified GHCJS.Foreign as JS
47import qualified GHCJS.Foreign as JS
39import qualified GHCJS.Foreign.Callback as JS
48import qualified GHCJS.Foreign.Callback as JS
@@ -53,15 +62,13 @@ import Foreign.C.Types
53import Foreign.Ptr
62import Foreign.Ptr
54import Text.Encoding.Z
63import Text.Encoding.Z
55#else
64#else
56−import Foreign.Marshal
65+import Data.Word (Word8)
57−import Graphics.UI.Gtk.WebKit.DOM.Node
66+import Control.Lens.Operators ((^.))
58−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSBase
67+import Language.Javascript.JSaddle
59−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSObjectRef
68+ (eval, valMakeString, valToNumber, function,
60−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSStringRef
69+ valMakeNumber, valBool, valToText, valToBool, valIsUndefined,
61−import Graphics.UI.Gtk.WebKit.JavaScriptCore.JSValueRef
70+ valUndefined, valIsNull, Function(..), (!!),
62−import Graphics.UI.Gtk.WebKit.JavaScriptCore.WebFrame
71+ js, js1, jss, array, freeFunction)
63−import Graphics.UI.Gtk.WebKit.WebView
64−import System.Glib.FFI
65#endif
72#endif
66
73
67import Control.Concurrent
74import Control.Concurrent
@@ -77,75 +84,74 @@ import qualified Control.Monad.State.Strict as Strict
77import Control.Monad.Trans.Control
84import Control.Monad.Trans.Control
78import Data.ByteString (ByteString)
85import Data.ByteString (ByteString)
79import qualified Data.ByteString as BS
86import qualified Data.ByteString as BS
80−import Data.Coerce
87+import Data.Coerce (coerce)
81import Data.Monoid
88import Data.Monoid
82import Data.Text (Text)
89import Data.Text (Text)
83import qualified Data.Text as T
90import qualified Data.Text as T
84
91
85−class Monad m => HasWebView m where
92+class Monad m => HasJSContext m where
86− type WebViewPhantom m :: *
93+ type JSContextPhantom m :: *
87− askWebView :: m (WebViewSingleton (WebViewPhantom m))
94+ askJSContext :: m (JSContextSingleton (JSContextPhantom m))
88
95
89−instance HasWebView m => HasWebView (ReaderT r m) where
96+type HasWebView = HasJSContext
90− type WebViewPhantom (ReaderT r m) = WebViewPhantom m
97+-- Not sure if we should deprecate this {-# DEPRECATED HasWebView "Use HasJSContext" #-}
91− askWebView = lift askWebView
92
98
93−instance HasWebView m => HasWebView (StateT r m) where
99+instance HasJSContext m => HasJSContext (ReaderT r m) where
94− type WebViewPhantom (StateT r m) = WebViewPhantom m
100+ type JSContextPhantom (ReaderT r m) = JSContextPhantom m
95− askWebView = lift askWebView
101+ askJSContext = lift askJSContext
96
102
97−instance HasWebView m => HasWebView (Strict.StateT r m) where
103+instance HasJSContext m => HasJSContext (StateT r m) where
98− type WebViewPhantom (Strict.StateT r m) = WebViewPhantom m
104+ type JSContextPhantom (StateT r m) = JSContextPhantom m
99− askWebView = lift askWebView
105+ askJSContext = lift askJSContext
100
106
101−instance HasWebView m => HasWebView (PostBuildT t m) where
107+instance HasJSContext m => HasJSContext (Strict.StateT r m) where
102− type WebViewPhantom (PostBuildT t m) = WebViewPhantom m
108+ type JSContextPhantom (Strict.StateT r m) = JSContextPhantom m
103− askWebView = lift askWebView
109+ askJSContext = lift askJSContext
104
110
105−instance (ReflexHost t, HasWebView (HostFrame t)) => HasWebView (PerformEventT t m) where
111+instance HasJSContext m => HasJSContext (PostBuildT t m) where
106− type WebViewPhantom (PerformEventT t m) = WebViewPhantom (HostFrame t)
112+ type JSContextPhantom (PostBuildT t m) = JSContextPhantom m
107− askWebView = PerformEventT $ lift askWebView
113+ askJSContext = lift askJSContext
108
114
109−instance HasWebView m => HasWebView (DynamicWriterT t w m) where
115+instance (ReflexHost t, HasJSContext (HostFrame t)) => HasJSContext (PerformEventT t m) where
110− type WebViewPhantom (DynamicWriterT t w m) = WebViewPhantom m
116+ type JSContextPhantom (PerformEventT t m) = JSContextPhantom (HostFrame t)
111− askWebView = lift askWebView
117+ askJSContext = PerformEventT $ lift askJSContext
112
118
113−instance HasWebView m => HasWebView (RequesterT t request response m) where
119+instance HasJSContext m => HasJSContext (DynamicWriterT t w m) where
114− type WebViewPhantom (RequesterT t request response m) = WebViewPhantom m
120+ type JSContextPhantom (DynamicWriterT t w m) = JSContextPhantom m
115− askWebView = lift askWebView
121+ askJSContext = lift askJSContext
116
122
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)
118
124
119−instance PrimMonad m => PrimMonad (WithWebView x m) where
125+instance PrimMonad m => PrimMonad (WithJSContextSingleton x m) where
120− type PrimState (WithWebView x m) = PrimState m
126+ type PrimState (WithJSContextSingleton x m) = PrimState m
121 primitive = lift . primitive
127 primitive = lift . primitive
122
128
123−instance MonadAdjust t m => MonadAdjust t (WithWebView x m) where
129+instance MonadAdjust t m => MonadAdjust t (WithJSContextSingleton x m) where
124− runWithReplace a0 a' = WithWebView $ runWithReplace (coerce a0) (coerceEvent a')
130+ runWithReplace a0 a' = WithJSContextSingleton $ runWithReplace (coerce a0) (coerceEvent a')
125− sequenceDMapWithAdjust dm0 dm' = WithWebView $ sequenceDMapWithAdjust (coerce dm0) (coerceEvent dm')
131+ sequenceDMapWithAdjust dm0 dm' = WithJSContextSingleton $ sequenceDMapWithAdjust (coerce dm0) (coerceEvent dm')
126
132
127−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithWebView x m) where
133+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (WithJSContextSingleton x m) where
128 {-# INLINABLE newEventWithTrigger #-}
134 {-# INLINABLE newEventWithTrigger #-}
129 newEventWithTrigger = lift . newEventWithTrigger
135 newEventWithTrigger = lift . newEventWithTrigger
130 {-# INLINABLE newFanEventWithTrigger #-}
136 {-# INLINABLE newFanEventWithTrigger #-}
131 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
137 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
132
138
133−instance MonadSubscribeEvent t m => MonadSubscribeEvent t (WithWebView x m) where
139+instance MonadSubscribeEvent t m => MonadSubscribeEvent t (WithJSContextSingleton x m) where
134 {-# INLINABLE subscribeEvent #-}
140 {-# INLINABLE subscribeEvent #-}
135 subscribeEvent = lift . subscribeEvent
141 subscribeEvent = lift . subscribeEvent
136
142
137−instance MonadReflexHost t m => MonadReflexHost t (WithWebView x m) where
143+instance MonadReflexHost t m => MonadReflexHost t (WithJSContextSingleton x m) where
138− type ReadPhase (WithWebView x m) = ReadPhase m
144+ type ReadPhase (WithJSContextSingleton x m) = ReadPhase m
139 {-# INLINABLE fireEventsAndRead #-}
145 {-# INLINABLE fireEventsAndRead #-}
140 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
146 fireEventsAndRead dm a = lift $ fireEventsAndRead dm a
141 {-# INLINABLE runHostFrame #-}
147 {-# INLINABLE runHostFrame #-}
142 runHostFrame = lift . runHostFrame
148 runHostFrame = lift . runHostFrame
143
149
144−instance MonadSample t m => MonadSample t (WithWebView x m) where
150+instance MonadSample t m => MonadSample t (WithJSContextSingleton x m) where
145 {-# INLINABLE sample #-}
151 {-# INLINABLE sample #-}
146 sample = lift . sample
152 sample = lift . sample
147
153
148−instance MonadHold t m => MonadHold t (WithWebView x m) where
154+instance MonadHold t m => MonadHold t (WithJSContextSingleton x m) where
149 {-# INLINABLE hold #-}
155 {-# INLINABLE hold #-}
150 hold v0 = lift . hold v0
156 hold v0 = lift . hold v0
151 {-# INLINABLE holdDyn #-}
157 {-# INLINABLE holdDyn #-}
@@ -153,41 +159,41 @@ instance MonadHold t m => MonadHold t (WithWebView x m) where
153 {-# INLINABLE holdIncremental #-}
159 {-# INLINABLE holdIncremental #-}
154 holdIncremental v0 = lift . holdIncremental v0
160 holdIncremental v0 = lift . holdIncremental v0
155
161
156−instance MonadTransControl (WithWebView x) where
162+instance MonadTransControl (WithJSContextSingleton x) where
157− type StT (WithWebView x) a = StT (ReaderT (WebViewSingleton x)) a
163+ type StT (WithJSContextSingleton x) a = StT (ReaderT (JSContextSingleton x)) a
158 {-# INLINABLE liftWith #-}
164 {-# INLINABLE liftWith #-}
159− liftWith = defaultLiftWith WithWebView unWithWebView
165+ liftWith = defaultLiftWith WithJSContextSingleton unWithJSContextSingleton
160 {-# INLINABLE restoreT #-}
166 {-# INLINABLE restoreT #-}
161− restoreT = defaultRestoreT WithWebView
167+ restoreT = defaultRestoreT WithJSContextSingleton
162
168
163−instance PerformEvent t m => PerformEvent t (WithWebView x m) where
169+instance PerformEvent t m => PerformEvent t (WithJSContextSingleton x m) where
164− type Performable (WithWebView x m) = WithWebView x (Performable m)
170+ type Performable (WithJSContextSingleton x m) = WithJSContextSingleton x (Performable m)
165 {-# INLINABLE performEvent_ #-}
171 {-# INLINABLE performEvent_ #-}
166 performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
172 performEvent_ e = liftWith $ \run -> performEvent_ $ fmap run e
167 {-# INLINABLE performEvent #-}
173 {-# INLINABLE performEvent #-}
168 performEvent e = liftWith $ \run -> performEvent $ fmap run e
174 performEvent e = liftWith $ \run -> performEvent $ fmap run e
169
175
170−runWithWebView :: WithWebView x m a -> WebViewSingleton x -> m a
176+runWithJSContextSingleton :: WithJSContextSingleton x m a -> JSContextSingleton x -> m a
171−runWithWebView = runReaderT . unWithWebView
177+runWithJSContextSingleton = runReaderT . unWithJSContextSingleton
172
178
173−instance (Monad m) => HasWebView (WithWebView x m) where
179+instance (Monad m) => HasJSContext (WithJSContextSingleton x m) where
174− type WebViewPhantom (WithWebView x m) = x
180+ type JSContextPhantom (WithJSContextSingleton x m) = x
175− askWebView = WithWebView ask
181+ askJSContext = WithJSContextSingleton ask
176
182
177−instance MonadRef m => MonadRef (WithWebView x m) where
183+instance MonadRef m => MonadRef (WithJSContextSingleton x m) where
178− type Ref (WithWebView x m) = Ref m
184+ type Ref (WithJSContextSingleton x m) = Ref m
179 newRef = lift . newRef
185 newRef = lift . newRef
180 readRef = lift . readRef
186 readRef = lift . readRef
181 writeRef r = lift . writeRef r
187 writeRef r = lift . writeRef r
182
188
183−instance MonadAtomicRef m => MonadAtomicRef (WithWebView x m) where
189+instance MonadAtomicRef m => MonadAtomicRef (WithJSContextSingleton x m) where
184 atomicModifyRef r = lift . atomicModifyRef r
190 atomicModifyRef r = lift . atomicModifyRef r
185
191
186−withWebViewSingleton :: WebView -> (forall x. WebViewSingleton x -> r) -> r
192+withJSContextSingleton :: MonadJSM m => (forall x. JSContextSingleton x -> m r) -> m r
187−withWebViewSingleton wv f = f $ WebViewSingleton wv
193+withJSContextSingleton f = askJSM >>= f . JSContextSingleton
188
194
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
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
190−newtype WebViewSingleton x = WebViewSingleton { unWebViewSingleton :: WebView }
196+newtype JSContextSingleton x = JSContextSingleton { unJSContextSingleton :: JSContextRef }
191
197
192#ifdef __GHCJS__
198#ifdef __GHCJS__
193type JSFFI_Internal = JS.MutableJSArray -> IO JS.JSVal
199type JSFFI_Internal = JS.MutableJSArray -> IO JS.JSVal
@@ -196,39 +202,40 @@ newtype JSFFI = JSFFI JSFFI_Internal
196newtype JSFFI = JSFFI String
202newtype JSFFI = JSFFI String
197#endif
203#endif
198
204
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+ }
200
210
201instance ToJS x (JSFun x) where
211instance ToJS x (JSFun x) where
202− withJS (JSFun r) f = f r
212+ withJS r f = f (unJSFun r)
203−
204−instance FromJS x (JSFun x) where
205− fromJS = return . JSFun
206
213
207class IsJSContext x where
214class IsJSContext x where
208 data JSRef x
215 data JSRef x
209
216
210−class (Monad m, MonadIO (JSM m), MonadFix (JSM m), MonadJS x (JSM m)) => HasJS x m | m -> x where
217+class (Monad m, MonadIO (JSX m), MonadFix (JSX m), MonadJS x (JSX m)) => HasJS x m | m -> x where
211− type JSM m :: * -> *
218+ type JSX m :: * -> *
212− liftJS :: JSM m a -> m a
219+ liftJS :: JSX m a -> m a
213
220
214instance HasJS x m => HasJS x (ReaderT r m) where
221instance 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
216 liftJS = lift . liftJS
223 liftJS = lift . liftJS
217
224
218instance (HasJS x m, ReflexHost t) => HasJS x (PostBuildT t m) where
225instance (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
220 liftJS = lift . liftJS
227 liftJS = lift . liftJS
221
228
222instance (HasJS x (HostFrame t), ReflexHost t) => HasJS x (PerformEventT t m) where
229instance (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)
224 liftJS = PerformEventT . lift . liftJS
231 liftJS = PerformEventT . lift . liftJS
225
232
226instance HasJS x m => HasJS x (DynamicWriterT t w m) where
233instance 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
228 liftJS = lift . liftJS
235 liftJS = lift . liftJS
229
236
230instance HasJS x m => HasJS x (RequesterT t request response m) where
237instance 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
232 liftJS = lift . liftJS
239 liftJS = lift . liftJS
233
240
234-- | A Monad that is capable of executing JavaScript
241-- | A Monad that is capable of executing JavaScript
@@ -259,8 +266,8 @@ class Monad m => MonadJS x m | m -> x where
259
266
260data JSCtx_IO
267data JSCtx_IO
261
268
262−instance MonadIO m => HasJS JSCtx_IO (WithWebView x m) where
269+instance MonadIO m => HasJS JSCtx_IO (WithJSContextSingleton x m) where
263− type JSM (WithWebView x m) = IO
270+ type JSX (WithJSContextSingleton x m) = IO
264 liftJS = liftIO
271 liftJS = liftIO
265
272
266instance IsJSContext JSCtx_IO where
273instance IsJSContext JSCtx_IO where
@@ -276,9 +283,7 @@ instance MonadJS JSCtx_IO IO where
276 fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.pFromJSVal r
283 fromJSString (JSRef_IO r) = return $ JS.fromJSString $ JS.pFromJSVal r
277 fromJSArray (JSRef_IO r) = fmap coerce $ JS.toListIO $ coerce r
284 fromJSArray (JSRef_IO r) = fmap coerce $ JS.toListIO $ coerce r
278 fromJSUint8Array (JSRef_IO r) = fmap (JS.toByteString 0 Nothing . JS.createFromArrayBuffer) $ JSArrayBuffer.unsafeFreeze $ JS.pFromJSVal r --TODO: Assert that this is immutable
285 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
286+ fromJSNumber (JSRef_IO r) = JS.fromJSValUnchecked r
280− Just n <- JS.fromJSVal r
281− return n
282 withJSBool b f = f $ JSRef_IO $ JS.toJSBool b
287 withJSBool b f = f $ JSRef_IO $ JS.toJSBool b
283 withJSString s f = f $ JSRef_IO $ JS.pToJSVal $ JS.toJSString s
288 withJSString s f = f $ JSRef_IO $ JS.pToJSVal $ JS.toJSString s
284 withJSNumber n f = do
289 withJSNumber n f = do
@@ -309,65 +314,51 @@ foreign import javascript unsafe "function(){ return $1(arguments); }" funWithAr
309
314
310#else
315#else
311
316
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−
324data JSCtx_JavaScriptCore x
317data JSCtx_JavaScriptCore x
325
318
326instance IsJSContext (JSCtx_JavaScriptCore x) where
319instance 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 }
328
321
329−instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithWebView x m) where
322+instance MonadIO m => HasJS (JSCtx_JavaScriptCore x) (WithJSContextSingleton x m) where
330− type JSM (WithWebView x m) = WithWebView x IO
323+ type JSX (WithJSContextSingleton x m) = WithJSContextSingleton x IO
331 liftJS a = do
324 liftJS a = do
332− wv <- askWebView
325+ wv <- askJSContext
333− liftIO $ runWithWebView a wv
326+ liftIO $ runWithJSContextSingleton a wv
334
327
335newtype WithJSContext x m a = WithJSContext { unWithJSContext :: ReaderT JSContextRef m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
328newtype WithJSContext x m a = WithJSContext { unWithJSContext :: ReaderT JSContextRef m a } deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadTrans, MonadException, MonadAsyncException)
336
329
337runWithJSContext :: WithJSContext x m a -> JSContextRef -> m a
330runWithJSContext :: WithJSContext x m a -> JSContextRef -> m a
338runWithJSContext = runReaderT . unWithJSContext
331runWithJSContext = runReaderT . unWithJSContext
339
332
340−class Monad m => HasJSContext m where
341− askJSContext :: m JSContextRef
342−
343−instance MonadIO m => HasJSContext (WithWebView x m) where
333+instance MonadIO m => MonadJSM (WithJSContextSingleton x m) where
344− askJSContext = do
334+ liftJSM' f = do
345− wv <- askWebView
335+ wv <- askJSContext
346− liftIO $ webFrameGetGlobalContext =<< webViewGetMainFrame (unWebViewSingleton wv)
336+ runJSM f $ unJSContextSingleton wv
347
337
348−instance Monad m => HasJSContext (WithJSContext x m) where
338+instance MonadIO m => MonadJSM (WithJSContext x m) where
339+ liftJSM' f =
349− askJSContext = WithJSContext ask
340+ runJSM f =<< WithJSContext ask
350
341
351−lowerWithJSContext :: (HasJSContext m, MonadIO m) => WithJSContext x IO a -> m a
342+lowerWithJSContext :: MonadJSM m => WithJSContext x IO a -> m a
352lowerWithJSContext a = do
343lowerWithJSContext a = do
353− c <- askJSContext
344+ c <- askJSM
354 liftIO $ runWithJSContext a c
345 liftIO $ runWithJSContext a c
355
346
356−liftWithWebViewThroughWithJSContext :: (HasJSContext m, HasWebView m, MonadIO m, MonadTrans t, Monad m1)
347+liftWithJSContextSingletonThroughWithJSContext :: (HasJSContext m, MonadJSM m, MonadTrans t, Monad m1)
357 => ((t1 -> t m1 a) -> WithJSContext x IO b)
348 => ((t1 -> t m1 a) -> WithJSContext x IO b)
358− -> (t1 -> WithWebView (WebViewPhantom m) m1 a)
349+ -> (t1 -> WithJSContextSingleton (JSContextPhantom m) m1 a)
359 -> m b
350 -> m b
360−liftWithWebViewThroughWithJSContext f a = do
351+liftWithJSContextSingletonThroughWithJSContext f a = do
361− wv <- askWebView
352+ wv <- askJSContext
362− lowerWithJSContext $ f $ \b' -> lift $ runWithWebView (a b') wv
353+ lowerWithJSContext $ f $ \b' -> lift $ runWithJSContextSingleton (a b') wv
363
354
364−instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
355+instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContextSingleton x IO) where
365 forkJS a = do
356 forkJS a = do
366− wv <- askWebView
357+ wv <- askJSContext
367− liftIO $ forkIO $ runWithWebView a wv
358+ liftIO $ forkIO $ runWithJSContextSingleton a wv
368 mkJSFun a = do
359 mkJSFun a = do
369− wv <- askWebView
360+ wv <- askJSContext
370− lowerWithJSContext $ mkJSFun $ \args -> lift $ runWithWebView (a args) wv
361+ lowerWithJSContext $ mkJSFun $ \args -> lift $ runWithJSContextSingleton (a args) wv
371 runJS expr args = lowerWithJSContext $ runJS expr args
362 runJS expr args = lowerWithJSContext $ runJS expr args
372 mkJSUndefined = lowerWithJSContext mkJSUndefined
363 mkJSUndefined = lowerWithJSContext mkJSUndefined
373 isJSNull = lowerWithJSContext . isJSNull
364 isJSNull = lowerWithJSContext . isJSNull
@@ -378,106 +369,55 @@ instance MonadJS (JSCtx_JavaScriptCore x) (WithWebView x IO) where
378 fromJSUint8Array = lowerWithJSContext . fromJSUint8Array
369 fromJSUint8Array = lowerWithJSContext . fromJSUint8Array
379 fromJSNumber = lowerWithJSContext . fromJSNumber
370 fromJSNumber = lowerWithJSContext . fromJSNumber
380 freeJSFun = lowerWithJSContext . freeJSFun
371 freeJSFun = lowerWithJSContext . freeJSFun
381− withJSBool = liftWithWebViewThroughWithJSContext . withJSBool
372+ withJSBool = liftWithJSContextSingletonThroughWithJSContext . withJSBool
382− withJSString = liftWithWebViewThroughWithJSContext . withJSString
373+ withJSString = liftWithJSContextSingletonThroughWithJSContext . withJSString
383− withJSNumber = liftWithWebViewThroughWithJSContext . withJSNumber
374+ withJSNumber = liftWithJSContextSingletonThroughWithJSContext . withJSNumber
384− withJSArray = liftWithWebViewThroughWithJSContext . withJSArray
375+ withJSArray = liftWithJSContextSingletonThroughWithJSContext . withJSArray
385− withJSUint8Array = liftWithWebViewThroughWithJSContext . withJSUint8Array
376+ withJSUint8Array = liftWithJSContextSingletonThroughWithJSContext . withJSUint8Array
386− withJSNode = liftWithWebViewThroughWithJSContext . withJSNode
377+ withJSNode = liftWithJSContextSingletonThroughWithJSContext . withJSNode
387 setJSProp propName valRef objRef = lowerWithJSContext $ setJSProp propName valRef objRef
378 setJSProp propName valRef objRef = lowerWithJSContext $ setJSProp propName valRef objRef
388 getJSProp propName objRef = lowerWithJSContext $ getJSProp propName objRef
379 getJSProp propName objRef = lowerWithJSContext $ getJSProp propName objRef
389
380
390instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContext x IO) where
381instance MonadJS (JSCtx_JavaScriptCore x) (WithJSContext x IO) where
391− runJS (JSFFI body) args = do
382+ runJS (JSFFI body) args =
392− jsContext <- askJSContext
393− withJSArray args $ \(JSRef_JavaScriptCore this) -> liftIO $ do
383+ withJSArray args $ \(JSRef_JavaScriptCore this) -> do
394− result <- bracket (jsstringcreatewithutf8cstring body) jsstringrelease $ \script -> jsevaluatescript jsContext script this nullPtr 1 nullPtr
384+ result <- liftJSM $ eval ("(function(){ return (" <> body <> "); })") ^. js1 "apply" this
395− return $ JSRef_JavaScriptCore result --TODO: Protect and unprotect result
385+ return $ JSRef_JavaScriptCore result
396 forkJS a = do
386 forkJS a = do
397− c <- askJSContext
387+ c <- askJSM
398− liftIO $ forkIO $ runWithJSContext a c
388+ liftIO . forkIO $ runWithJSContext a c
399− mkJSUndefined = do
389+ mkJSUndefined = return $ JSRef_JavaScriptCore valUndefined
400− jsContext <- askJSContext
401− fmap JSRef_JavaScriptCore $ liftIO $ jsvaluemakeundefined jsContext
402− isJSNull (JSRef_JavaScriptCore r) = do
390+ isJSNull (JSRef_JavaScriptCore r) = liftJSM $ valIsNull r
403− jsContext <- askJSContext
404− liftIO $ jsvalueisnull jsContext r
405− isJSUndefined (JSRef_JavaScriptCore r) = do
391+ isJSUndefined (JSRef_JavaScriptCore r) = liftJSM $ valIsUndefined r
406− jsContext <- askJSContext
407− liftIO $ jsvalueisundefined jsContext r
408− fromJSBool (JSRef_JavaScriptCore r) = do
392+ fromJSBool (JSRef_JavaScriptCore r) = liftJSM $ valToBool r
409− jsContext <- askJSContext
410− liftIO $ jsvaluetoboolean jsContext r
411− fromJSString (JSRef_JavaScriptCore r) = do
393+ fromJSString (JSRef_JavaScriptCore r) = liftJSM (T.unpack <$> valToText r)
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
394+ withJSBool b a = a $ JSRef_JavaScriptCore (valBool b)
423− withJSString str a = do
395+ withJSString str a = a . JSRef_JavaScriptCore =<< liftJSM (valMakeString $ toJSString str)
424− jsContext <- askJSContext
396+ withJSNumber n a = a . JSRef_JavaScriptCore =<< liftJSM (valMakeNumber n)
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
397+ withJSArray elems a = a . JSRef_JavaScriptCore =<< liftJSM
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
398+ (toJSVal =<< array (map (\(JSRef_JavaScriptCore r) -> r) elems))
439− --TODO: When supported by webkitgtk3-javascriptcore, go directly from C string to Uint8Array without creating each item individually
440 withJSUint8Array payload f = withJSArrayFromList (BS.unpack payload) $ \x -> do
399 withJSUint8Array payload f = withJSArrayFromList (BS.unpack payload) $ \x -> do
441 payloadRef <- runJS (JSFFI "new Uint8Array(this[0])") [x]
400 payloadRef <- runJS (JSFFI "new Uint8Array(this[0])") [x]
442 f $ JSUint8Array payloadRef
401 f $ JSUint8Array payloadRef
443− fromJSArray (JSRef_JavaScriptCore a) = do
402+ fromJSArray (JSRef_JavaScriptCore a) = liftJSM $ do
444− jsContext <- askJSContext
403+ len <- round <$> (valToNumber =<< (a ^. js "length"))
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
404+ forM [0..len-1] $ \i -> JSRef_JavaScriptCore <$> a !! i
450− JSRef_JavaScriptCore <$> jsobjectgetpropertyatindex jsContext a i nullPtr --TODO: Exceptions
451 fromJSUint8Array a = do
405 fromJSUint8Array a = do
452 vals <- fromJSArray a
406 vals <- fromJSArray a
453 doubles <- mapM fromJSNumber vals
407 doubles <- mapM fromJSNumber vals
454 return $ BS.pack $ map round doubles
408 return $ BS.pack $ map round doubles
455− fromJSNumber (JSRef_JavaScriptCore val) = do
409+ fromJSNumber (JSRef_JavaScriptCore val) = liftJSM $ valToNumber val
456− jsContext <- askJSContext
457− liftIO $ jsvaluetonumber jsContext val nullPtr --TODO: Exceptions
458− mkJSFun a = do
410+ mkJSFun a = liftJSM $ do
459− jsContext <- askJSContext
411+ ctx <- askJSM
460− cb <- liftIO $ mkJSObjectCallAsFunctionCallback $ \_ _ _ argc argv _ -> do --TODO: Use the exception pointer to handle haskell exceptions
412+ f <- function $ \_ _ args -> liftIO $ void $ runWithJSContext (a $ map JSRef_JavaScriptCore args) ctx
461− args <- forM [0..fromIntegral (argc-1)] $ \n -> do
413+ fRef <- toJSVal f
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
414+ return $ JSFun (JSRef_JavaScriptCore fRef) f
469− freeJSFun (JSFun (JSRef_JavaScriptCore f)) = do
415+ freeJSFun (JSFun _ f) = liftJSM $ freeFunction f
470− jsContext <- askJSContext
471− liftIO $ jsvalueunprotect jsContext f
472− setJSProp propName (JSRef_JavaScriptCore valRef) (JSRef_JavaScriptCore objRef) = do
416+ setJSProp propName (JSRef_JavaScriptCore valRef) (JSRef_JavaScriptCore objRef) =
473− withJSStringRaw propName $ \propNameRaw -> do
417+ liftJSM $ objRef ^. jss propName valRef
474− jsContext <- askJSContext
475− liftIO $ jsobjectsetproperty jsContext objRef propNameRaw valRef 0 nullPtr --TODO: property attribute, exceptions
476− getJSProp propName (JSRef_JavaScriptCore objRef) = do
418+ getJSProp propName (JSRef_JavaScriptCore objRef) =
477− withJSStringRaw propName $ \propNameRaw -> do
419+ JSRef_JavaScriptCore <$> liftJSM (objRef ^. js propName)
478− jsContext <- askJSContext
420+ withJSNode n f = f . JSRef_JavaScriptCore =<< liftJSM (toJSVal n)
479− liftIO $ JSRef_JavaScriptCore <$> jsobjectgetproperty jsContext objRef propNameRaw nullPtr --TODO: property attribute, exceptions
480− withJSNode = error "withJSNode is only supported in ghcjs"
481
421
482#endif
422#endif
483
423
@@ -559,6 +499,8 @@ instance ToJS x Node where
559 withJS = withJSNode
499 withJS = withJSNode
560
500
561
501
502+#ifdef USE_TEMPLATE_HASKELL
503+
562importJS :: Safety -> String -> String -> Q Type -> Q [Dec]
504importJS :: Safety -> String -> String -> Q Type -> Q [Dec]
563importJS safety body name qt = do
505importJS safety body name qt = do
564 t <- qt
506 t <- qt
@@ -606,3 +548,5 @@ parseType (ForallT _ [AppT (AppT (ConT monadJs) (VarT _)) (VarT m)] funType)
606 | m' == m -> ([], result)
548 | m' == m -> ([], result)
607 _ -> error $ "parseType: can't parse type " <> show t
549 _ -> error $ "parseType: can't parse type " <> show t
608parseType t = error $ "parseType: can't parse type " <> show t
550parseType 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 #-}
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DefaultSignatures #-}
4{-# LANGUAGE DefaultSignatures #-}
@@ -12,7 +13,9 @@
12{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE RankNTypes #-}
13{-# LANGUAGE RecursiveDo #-}
14{-# LANGUAGE RecursiveDo #-}
14{-# LANGUAGE ScopedTypeVariables #-}
15{-# LANGUAGE ScopedTypeVariables #-}
16+#ifdef USE_TEMPLATE_HASKELL
15{-# LANGUAGE TemplateHaskell #-}
17{-# LANGUAGE TemplateHaskell #-}
18+#endif
16{-# LANGUAGE TypeFamilies #-}
19{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE UndecidableInstances #-}
20{-# LANGUAGE UndecidableInstances #-}
18module Reflex.Dom.Builder.Class
21module Reflex.Dom.Builder.Class
@@ -152,6 +155,19 @@ data TextNodeConfig t
152 , _textNodeConfig_setContents :: Event t Text
155 , _textNodeConfig_setContents :: Event t Text
153 }
156 }
154
157
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+
155instance (Reflex t) => Default (TextNodeConfig t) where
171instance (Reflex t) => Default (TextNodeConfig t) where
156 {-# INLINABLE def #-}
172 {-# INLINABLE def #-}
157 def = TextNodeConfig
173 def = TextNodeConfig
@@ -216,6 +232,29 @@ data ElementConfig er t m
216 , _elementConfig_eventSpec :: EventSpec (DomBuilderSpace m) er
232 , _elementConfig_eventSpec :: EventSpec (DomBuilderSpace m) er
217 }
233 }
218
234
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+
219data Element er d t
258data Element er d t
220 = Element { _element_events :: EventSelector t (WrapArg er EventName) --TODO: EventSelector should have two arguments
259 = Element { _element_events :: EventSelector t (WrapArg er EventName) --TODO: EventSelector should have two arguments
221 , _element_raw :: RawElement d
260 , _element_raw :: RawElement d
@@ -226,6 +265,19 @@ data PlaceholderConfig above t m
226 , _placeholderConfig_deleteSelf :: Event t ()
265 , _placeholderConfig_deleteSelf :: Event t ()
227 }
266 }
228
267
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+
229instance Reflex t => Default (PlaceholderConfig above t m) where
281instance Reflex t => Default (PlaceholderConfig above t m) where
230 {-# INLINABLE def #-}
282 {-# INLINABLE def #-}
231 def = PlaceholderConfig
283 def = PlaceholderConfig
@@ -246,6 +298,28 @@ data InputElementConfig er t m
246 , _inputElementConfig_elementConfig :: ElementConfig er t m
298 , _inputElementConfig_elementConfig :: ElementConfig er t m
247 }
299 }
248
300
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+
249instance (Reflex t, er ~ EventResult, DomBuilder t m) => Default (InputElementConfig er t m) where
323instance (Reflex t, er ~ EventResult, DomBuilder t m) => Default (InputElementConfig er t m) where
250 {-# INLINABLE def #-}
324 {-# INLINABLE def #-}
251 def = InputElementConfig
325 def = InputElementConfig
@@ -273,6 +347,22 @@ data TextAreaElementConfig er t m
273 , _textAreaElementConfig_elementConfig :: ElementConfig er t m
347 , _textAreaElementConfig_elementConfig :: ElementConfig er t m
274 }
348 }
275
349
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+
276instance (Reflex t, er ~ EventResult, DomBuilder t m) => Default (TextAreaElementConfig er t m) where
366instance (Reflex t, er ~ EventResult, DomBuilder t m) => Default (TextAreaElementConfig er t m) where
277 {-# INLINABLE def #-}
367 {-# INLINABLE def #-}
278 def = TextAreaElementConfig
368 def = TextAreaElementConfig
@@ -300,6 +390,23 @@ data RawElementConfig er t m = RawElementConfig
300 , _rawElementConfig_eventSpec :: EventSpec (DomBuilderSpace m) er
390 , _rawElementConfig_eventSpec :: EventSpec (DomBuilderSpace m) er
301 }
391 }
302
392
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+
303instance (Reflex t, DomSpace (DomBuilderSpace m)) => Default (RawElementConfig EventResult t m) where
410instance (Reflex t, DomSpace (DomBuilderSpace m)) => Default (RawElementConfig EventResult t m) where
304 def = RawElementConfig
411 def = RawElementConfig
305 { _rawElementConfig_modifyAttributes = never
412 { _rawElementConfig_modifyAttributes = never
@@ -312,6 +419,22 @@ data SelectElementConfig er t m = SelectElementConfig
312 , _selectElementConfig_elementConfig :: ElementConfig er t m
419 , _selectElementConfig_elementConfig :: ElementConfig er t m
313 }
420 }
314
421
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+
315instance (Reflex t, er ~ EventResult, DomBuilder t m) => Default (SelectElementConfig er t m) where
438instance (Reflex t, er ~ EventResult, DomBuilder t m) => Default (SelectElementConfig er t m) where
316 def = SelectElementConfig
439 def = SelectElementConfig
317 { _selectElementConfig_initialValue = ""
440 { _selectElementConfig_initialValue = ""
@@ -327,6 +450,7 @@ data SelectElement er d t = SelectElement
327 , _selectElement_raw :: RawSelectElement d
450 , _selectElement_raw :: RawSelectElement d
328 }
451 }
329
452
453+#ifdef USE_TEMPLATE_HASKELL
330concat <$> mapM makeLenses
454concat <$> mapM makeLenses
331 [ ''TextNodeConfig
455 [ ''TextNodeConfig
332 , ''ElementConfig
456 , ''ElementConfig
@@ -336,6 +460,7 @@ concat <$> mapM makeLenses
336 , ''SelectElementConfig
460 , ''SelectElementConfig
337 , ''RawElementConfig
461 , ''RawElementConfig
338 ]
462 ]
463+#endif
339
464
340class CanDeleteSelf t a | a -> t where
465class CanDeleteSelf t a | a -> t where
341 deleteSelf :: Lens' a (Event t ())
466 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 #-}
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE EmptyDataDecls #-}
4{-# LANGUAGE EmptyDataDecls #-}
@@ -11,7 +12,9 @@
11{-# LANGUAGE RankNTypes #-}
12{-# LANGUAGE RankNTypes #-}
12{-# LANGUAGE RecursiveDo #-}
13{-# LANGUAGE RecursiveDo #-}
13{-# LANGUAGE ScopedTypeVariables #-}
14{-# LANGUAGE ScopedTypeVariables #-}
15+#ifdef USE_TEMPLATE_HASKELL
14{-# LANGUAGE TemplateHaskell #-}
16{-# LANGUAGE TemplateHaskell #-}
17+#endif
15{-# LANGUAGE TypeFamilies #-}
18{-# LANGUAGE TypeFamilies #-}
16{-# LANGUAGE TypeOperators #-}
19{-# LANGUAGE TypeOperators #-}
17{-# LANGUAGE UndecidableInstances #-}
20{-# LANGUAGE UndecidableInstances #-}
@@ -34,6 +37,9 @@ import Control.Monad.Primitive
34import Control.Monad.Reader
37import Control.Monad.Reader
35import Control.Monad.Ref
38import Control.Monad.Ref
36import Control.Monad.Trans.Control
39import Control.Monad.Trans.Control
40+#ifndef USE_TEMPLATE_HASKELL
41+import Data.Functor.Contravariant (phantom)
42+#endif
37import Data.Bitraversable
43import Data.Bitraversable
38import Data.Default
44import Data.Default
39import Data.Dependent.Map (DMap)
45import Data.Dependent.Map (DMap)
@@ -48,7 +54,7 @@ import Data.Monoid
48import Data.Some (Some)
54import Data.Some (Some)
49import qualified Data.Some as Some
55import qualified Data.Some as Some
50import Data.Text (Text)
56import Data.Text (Text)
51−import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode)
57+import GHCJS.DOM.Document (Document, createDocumentFragmentUnchecked, createElementUnchecked, createElementNSUnchecked, createTextNodeUnchecked)
52import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)
58import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)
53import qualified GHCJS.DOM.Element as Element
59import qualified GHCJS.DOM.Element as Element
54import qualified GHCJS.DOM.Event as Event
60import qualified GHCJS.DOM.Event as Event
@@ -59,15 +65,17 @@ import qualified GHCJS.DOM.HTMLInputElement as Input
59import qualified GHCJS.DOM.HTMLSelectElement as Select
65import qualified GHCJS.DOM.HTMLSelectElement as Select
60import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea
66import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea
61import GHCJS.DOM.MouseEvent
67import GHCJS.DOM.MouseEvent
62−import GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling, removeChild,
68+import GHCJS.DOM.Node (appendChild_, getOwnerDocumentUnchecked, getParentNodeUnchecked,
63 setNodeValue, toNode)
69 setNodeValue, toNode)
64−import qualified GHCJS.DOM.Node as DOM
70+import qualified GHCJS.DOM.Node as DOM (insertBefore_)
71+import GHCJS.DOM.Types
72+ (liftJSM, askJSM, runJSM, JSM, MonadJSM(..),
65−import GHCJS.DOM.Types (FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node, ToDOMString, TouchEvent,
73+ FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node,
66− WheelEvent, castToHTMLInputElement, castToHTMLSelectElement,
74+ ToDOMString, TouchEvent, WheelEvent, uncheckedCastTo)
67− castToHTMLTextAreaElement)
68import qualified GHCJS.DOM.Types as DOM
75import qualified GHCJS.DOM.Types as DOM
69import GHCJS.DOM.UIEvent
76import GHCJS.DOM.UIEvent
70import qualified GHCJS.DOM.Window as Window
77import qualified GHCJS.DOM.Window as Window
78+import Language.Javascript.JSaddle (call, eval)
71
79
72import Debug.Trace hiding (traceEvent)
80import Debug.Trace hiding (traceEvent)
73
81
@@ -81,6 +89,11 @@ data ImmediateDomBuilderEnv t
81
89
82newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
90newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
83
91
92+#ifndef __GHCJS__
93+instance MonadJSM m => MonadJSM (ImmediateDomBuilderT t m) where
94+ liftJSM' = ImmediateDomBuilderT . liftJSM'
95+#endif
96+
84instance PrimMonad m => PrimMonad (ImmediateDomBuilderT x m) where
97instance PrimMonad m => PrimMonad (ImmediateDomBuilderT x m) where
85 type PrimState (ImmediateDomBuilderT x m) = PrimState m
98 type PrimState (ImmediateDomBuilderT x m) = PrimState m
86 primitive = lift . primitive
99 primitive = lift . primitive
@@ -110,64 +123,81 @@ askEvents :: Monad m => ImmediateDomBuilderT t m (Chan [DSum (TriggerRef t) Trig
110askEvents = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_events
123askEvents = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_events
111
124
112{-# INLINABLE append #-}
125{-# INLINABLE append #-}
113−append :: (IsNode n, MonadIO m) => n -> ImmediateDomBuilderT t m ()
126+append :: (IsNode n, MonadJSM m) => n -> ImmediateDomBuilderT t m ()
114append n = do
127append n = do
115 p <- askParent
128 p <- askParent
116− _ <- liftIO $ appendChild p $ Just n
129+ liftJSM $ appendChild_ p $ Just n
117 return ()
130 return ()
118
131
119{-# INLINABLE textNodeInternal #-}
132{-# 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
121textNodeInternal t = do
134textNodeInternal t = do
122 doc <- askDocument
135 doc <- askDocument
123− Just n <- liftIO $ createTextNode doc t
136+ n <- liftJSM $ createTextNodeUnchecked doc t
124 append n
137 append n
125 return n
138 return n
126
139
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
128{-# INLINABLE deleteBetweenInclusive #-}
142{-# INLINABLE deleteBetweenInclusive #-}
129−deleteBetweenInclusive :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m ()
143+deleteBetweenInclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()
130−deleteBetweenInclusive s e = do
144+deleteBetweenInclusive s e = liftJSM $ 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
145+ f <- eval ("(function(s,e){ \
132− case mCurrentParent of
146+ p = e.parentNode; \
133− Nothing -> return () --TODO: Is this the right behavior?
147+ if(p !== null) { \
134− Just currentParent -> do
148+ for(;;){ \
135− deleteUpToGivenParent currentParent s e
149+ x = e.previousSibling; \
136− _ <- removeChild currentParent $ Just e
150+ p.removeChild(x); \
137− return ()
151+ if(s===x) break; \
138−
152+ } \
153+ p.removeChild(e); \
154+ }})" :: Text)
155+ void $ call f f (s, e)
156+
139−-- | s and e must both be children of the same node and s must precede e
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
140−deleteBetweenExclusive :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m ()
159+deleteBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()
141−deleteBetweenExclusive s e = do
160+deleteBetweenExclusive s e = liftJSM $ 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
161+ f <- eval ("(function(s,e){ \
143− case mCurrentParent of
162+ p = e.parentNode; \
144− Nothing -> return () --TODO: Is this the right behavior?
163+ if(p !== null) { \
145− Just currentParent -> do
164+ for(;;){ \
146− let go = do
165+ x = e.previousSibling; \
147− Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
166+ if(s===x) break; \
148− when (toNode s /= toNode x) $ do
167+ p.removeChild(x); \
149− _ <- removeChild currentParent $ Just x
168+ } \
150− go
169+ }})" :: Text)
151− go
170+ void $ call f f (s, e)
152−
171+
172+-- | s and e must both be children of the same node and s must precede e;
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
173+-- s and all nodes between s and e will be removed, but e will not be removed
154{-# INLINABLE deleteUpTo #-}
174{-# INLINABLE deleteUpTo #-}
155−deleteUpTo :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m ()
175+deleteUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()
156−deleteUpTo s e = do
176+deleteUpTo s e = liftJSM $ 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
177+ f <- eval ("(function(s,e){ \
158− case mCurrentParent of
178+ p = e.parentNode; \
159− Nothing -> return () --TODO: Is this the right behavior?
179+ if(p !== null) { \
160− Just currentParent -> deleteUpToGivenParent currentParent s e
180+ for(;;) { \
161−
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
162{-# INLINABLE deleteUpToGivenParent #-}
189{-# INLINABLE deleteUpToGivenParent #-}
163−deleteUpToGivenParent :: (MonadIO m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m ()
190+deleteUpToGivenParent :: (MonadJSM m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m ()
164−deleteUpToGivenParent currentParent s e = do
191+deleteUpToGivenParent currentParent s e = liftJSM $ do
165− fix $ \loop -> do
192+ f <- eval ("(function(p,s,e){ \
166− Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
193+ for(;;){ \
194+ x = e.previousSibling; \
167− _ <- removeChild currentParent $ Just x
195+ p.removeChild(x); \
168− when (toNode s /= toNode x) loop
196+ if(s===x) break; \
169−
197+ }})" :: Text)
198+ void $ call f f (currentParent, s, e)
199+
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)
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)
171
201
172newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))
202newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))
173
203
@@ -177,35 +207,37 @@ wrap e cfg = do
177 lift $ performEvent_ $ ffor (cfg ^. modifyAttributes) $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
207 lift $ performEvent_ $ ffor (cfg ^. modifyAttributes) $ imapM_ $ \(AttributeName mAttrNamespace n) mv -> case mAttrNamespace of
178 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv
208 Nothing -> maybe (removeAttribute e n) (setAttribute e n) mv
179 Just ns -> maybe (removeAttributeNS e (Just ns) n) (setAttributeNS e (Just ns) n) mv
209 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
210+ eventTriggerRefs :: DMap EventName (EventFilterTriggerRef t er) <- liftJSM $ fmap DMap.fromList $ forM (DMap.toList $ _ghcjsEventSpec_filters $ _rawElementConfig_eventSpec cfg) $ \(en :=> GhcjsEventFilter f) -> do
181− triggerRef <- newIORef Nothing
211+ triggerRef <- liftIO $ newIORef Nothing
182 _ <- elementOnEventName en e $ do
212 _ <- elementOnEventName en e $ do
183 evt <- DOM.event
213 evt <- DOM.event
184− (flags, k) <- liftIO $ f $ GhcjsDomEvent evt
214+ (flags, k) <- liftJSM $ f $ GhcjsDomEvent evt
185 when (_eventFlags_preventDefault flags) $ withIsEvent en DOM.preventDefault
215 when (_eventFlags_preventDefault flags) $ withIsEvent en DOM.preventDefault
186 case _eventFlags_propagation flags of
216 case _eventFlags_propagation flags of
187 Propagation_Continue -> return ()
217 Propagation_Continue -> return ()
188 Propagation_Stop -> withIsEvent en DOM.stopPropagation
218 Propagation_Stop -> withIsEvent en DOM.stopPropagation
189 Propagation_StopImmediate -> withIsEvent en DOM.stopImmediatePropagation
219 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
191 liftIO $ forM_ mv $ \v -> writeChan events [TriggerRef triggerRef :=> TriggerInvocation v (return ())]
221 liftIO $ forM_ mv $ \v -> writeChan events [TriggerRef triggerRef :=> TriggerInvocation v (return ())]
192 return $ en :=> EventFilterTriggerRef triggerRef
222 return $ en :=> EventFilterTriggerRef triggerRef
223+ es <- do
224+ ctx <- askJSM
193− es <- newFanEventWithTrigger $ \(WrapArg en) t -> do
225+ newFanEventWithTrigger $ \(WrapArg en) t ->
194− case DMap.lookup en eventTriggerRefs of
226+ case DMap.lookup en eventTriggerRefs of
195− Just (EventFilterTriggerRef r) -> do
227+ Just (EventFilterTriggerRef r) -> do
196− writeIORef r $ Just t
228+ writeIORef r $ Just t
197− return $ do
229+ return $ do
198− writeIORef r Nothing
230+ writeIORef r Nothing
199− Nothing -> elementOnEventName en e $ do
231+ Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do
200− evt <- DOM.event
232+ evt <- DOM.event
201− let h = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg
233+ let h = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg
202− mv <- liftIO $ h (en, GhcjsDomEvent evt)
234+ mv <- lift $ h (en, GhcjsDomEvent evt)
203− case mv of
235+ case mv of
204− Nothing -> return ()
236+ Nothing -> return ()
205− Just v -> liftIO $ do
237+ 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
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
207− ref <- newIORef $ Just t
239+ ref <- newIORef $ Just t
208− writeChan events [TriggerRef ref :=> TriggerInvocation v (return ())]
240+ writeChan events [TriggerRef ref :=> TriggerInvocation v (return ())])
209 return $ Element es e
241 return $ Element es e
210
242
211{-# INLINABLE makeElement #-}
243{-# INLINABLE makeElement #-}
@@ -213,12 +245,12 @@ makeElement :: forall er t m a. SupportsImmediateDomBuilder t m => Text -> Eleme
213makeElement elementTag cfg child = do
245makeElement elementTag cfg child = do
214 doc <- askDocument
246 doc <- askDocument
215 events <- askEvents
247 events <- askEvents
216− Just e <- ImmediateDomBuilderT $ fmap DOM.castToElement <$> case cfg ^. namespace of
248+ e <- liftJSM $ case cfg ^. namespace of
217− Nothing -> createElement doc (Just elementTag)
249+ Nothing -> createElementUnchecked doc (Just elementTag)
218− Just ens -> createElementNS doc (Just ens) (Just elementTag)
250+ Just ens -> createElementNSUnchecked doc (Just ens) (Just elementTag)
219 ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
251 ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
220− Nothing -> setAttribute e n v
252+ Nothing -> lift $ setAttribute e n v
221− Just ans -> setAttributeNS e (Just ans) n v
253+ Just ans -> lift $ setAttributeNS e (Just ans) n v
222 result <- lift $ runImmediateDomBuilderT child $ ImmediateDomBuilderEnv
254 result <- lift $ runImmediateDomBuilderT child $ ImmediateDomBuilderEnv
223 { _immediateDomBuilderEnv_parent = toNode e
255 { _immediateDomBuilderEnv_parent = toNode e
224 , _immediateDomBuilderEnv_document = doc
256 , _immediateDomBuilderEnv_document = doc
@@ -228,9 +260,9 @@ makeElement elementTag cfg child = do
228 wrapped <- wrap e $ extractRawElementConfig cfg
260 wrapped <- wrap e $ extractRawElementConfig cfg
229 return ((wrapped, result), e)
261 return ((wrapped, result), e)
230
262
231−newtype GhcjsDomHandler a b = GhcjsDomHandler { unGhcjsDomHandler :: a -> IO b }
263+newtype GhcjsDomHandler a b = GhcjsDomHandler { unGhcjsDomHandler :: a -> JSM b }
232
264
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) }
234
266
235newtype GhcjsDomEvent en = GhcjsDomEvent { unGhcjsDomEvent :: EventType en }
267newtype GhcjsDomEvent en = GhcjsDomEvent { unGhcjsDomEvent :: EventType en }
236
268
@@ -258,7 +290,7 @@ instance DomSpace GhcjsDomSpace where
258 in DMap.alter f' en $ _ghcjsEventSpec_filters es
290 in DMap.alter f' en $ _ghcjsEventSpec_filters es
259 }
291 }
260
292
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))))
262
294
263data Pair1 (f :: k -> *) (g :: k -> *) (a :: k) = Pair1 (f a) (g a)
295data Pair1 (f :: k -> *) (g :: k -> *) (a :: k) = Pair1 (f a) (g a)
264
296
@@ -266,15 +298,29 @@ data Maybe1 f a = Nothing1 | Just1 (f a)
266
298
267data GhcjsEventSpec er = GhcjsEventSpec
299data GhcjsEventSpec er = GhcjsEventSpec
268 { _ghcjsEventSpec_filters :: DMap EventName (GhcjsEventFilter er)
300 { _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))
270 }
302 }
271
303
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+
272instance er ~ EventResult => Default (GhcjsEventSpec er) where
317instance er ~ EventResult => Default (GhcjsEventSpec er) where
273 def = GhcjsEventSpec
318 def = GhcjsEventSpec
274 { _ghcjsEventSpec_filters = mempty
319 { _ghcjsEventSpec_filters = mempty
275 , _ghcjsEventSpec_handler = \(en, GhcjsDomEvent evt) -> do
320 , _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
321+ t :: DOM.EventTarget <- withIsEvent en $ Event.getTargetUnchecked evt --TODO: Rework this; defaultDomEventHandler shouldn't need to take this as an argument
277− runReaderT (defaultDomEventHandler (Element.castToElement t) en) evt
322+ let e = uncheckedCastTo DOM.Element t
323+ runReaderT (defaultDomEventHandler e en) evt
278 }
324 }
279
325
280instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t m) where
326instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t m) where
@@ -300,9 +346,9 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
300 {-# INLINABLE inputElement #-}
346 {-# INLINABLE inputElement #-}
301 inputElement cfg = do
347 inputElement cfg = do
302 ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
348 ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
303− let domInputElement = castToHTMLInputElement domElement
349+ let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
304 Input.setValue domInputElement $ Just (cfg ^. inputElementConfig_initialValue)
350 Input.setValue domInputElement $ Just (cfg ^. inputElementConfig_initialValue)
305− Just v0 <- Input.getValue domInputElement
351+ v0 <- Input.getValueUnchecked domInputElement
306 let getMyValue = fromMaybe "" <$> Input.getValue domInputElement
352 let getMyValue = fromMaybe "" <$> Input.getValue domInputElement
307 valueChangedByUI <- performEvent $ getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
353 valueChangedByUI <- performEvent $ getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
308 valueChangedBySetValue <- performEvent $ ffor (cfg ^. inputElementConfig_setValue) $ \v' -> do
354 valueChangedBySetValue <- performEvent $ ffor (cfg ^. inputElementConfig_setValue) $ \v' -> do
@@ -317,10 +363,10 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
317 Input.getChecked domInputElement
363 Input.getChecked domInputElement
318 checkedChangedBySetChecked <- performEvent $ ffor (_inputElementConfig_setChecked cfg) $ \newChecked -> do
364 checkedChangedBySetChecked <- performEvent $ ffor (_inputElementConfig_setChecked cfg) $ \newChecked -> do
319 oldChecked <- Input.getChecked domInputElement
365 oldChecked <- Input.getChecked domInputElement
320− if newChecked /= oldChecked
321− then do Input.setChecked domInputElement newChecked
366+ Input.setChecked domInputElement newChecked
367+ return $ if newChecked /= oldChecked
322− return $ Just newChecked
368+ then Just newChecked
323− else return Nothing
369+ else Nothing
324 c <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
370 c <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
325 [ fmapMaybe id checkedChangedBySetChecked
371 [ fmapMaybe id checkedChangedBySetChecked
326 , checkedChangedByUI
372 , checkedChangedByUI
@@ -347,9 +393,9 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
347 {-# INLINABLE textAreaElement #-}
393 {-# INLINABLE textAreaElement #-}
348 textAreaElement cfg = do --TODO
394 textAreaElement cfg = do --TODO
349 ((e, _), domElement) <- makeElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
395 ((e, _), domElement) <- makeElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
350− let domTextAreaElement = castToHTMLTextAreaElement domElement
396+ let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
351 TextArea.setValue domTextAreaElement $ Just (cfg ^. textAreaElementConfig_initialValue)
397 TextArea.setValue domTextAreaElement $ Just (cfg ^. textAreaElementConfig_initialValue)
352− Just v0 <- TextArea.getValue domTextAreaElement
398+ v0 <- TextArea.getValueUnchecked domTextAreaElement
353 let getMyValue = fromMaybe "" <$> TextArea.getValue domTextAreaElement
399 let getMyValue = fromMaybe "" <$> TextArea.getValue domTextAreaElement
354 valueChangedByUI <- performEvent $ getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
400 valueChangedByUI <- performEvent $ getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
355 valueChangedBySetValue <- performEvent $ ffor (cfg ^. textAreaElementConfig_setValue) $ \v' -> do
401 valueChangedBySetValue <- performEvent $ ffor (cfg ^. textAreaElementConfig_setValue) $ \v' -> do
@@ -370,7 +416,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
370 {-# INLINABLE selectElement #-}
416 {-# INLINABLE selectElement #-}
371 selectElement cfg child = do
417 selectElement cfg child = do
372 ((e, result), domElement) <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child
418 ((e, result), domElement) <- makeElement "select" (cfg ^. selectElementConfig_elementConfig) child
373− let domSelectElement = castToHTMLSelectElement domElement
419+ let domSelectElement = uncheckedCastTo DOM.HTMLSelectElement domElement
374 Select.setValue domSelectElement $ Just (cfg ^. selectElementConfig_initialValue)
420 Select.setValue domSelectElement $ Just (cfg ^. selectElementConfig_initialValue)
375 Just v0 <- Select.getValue domSelectElement
421 Just v0 <- Select.getValue domSelectElement
376 let getMyValue = fromMaybe "" <$> Select.getValue domSelectElement
422 let getMyValue = fromMaybe "" <$> Select.getValue domSelectElement
@@ -394,18 +440,18 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
394 placeRawElement = append
440 placeRawElement = append
395 wrapRawElement = wrap
441 wrapRawElement = wrap
396
442
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
398 runWithReplace a0 a' = do
444 runWithReplace a0 a' = do
399 initialEnv <- ImmediateDomBuilderT ask
445 initialEnv <- ImmediateDomBuilderT ask
400 before <- textNodeInternal ("" :: Text)
446 before <- textNodeInternal ("" :: Text)
401 -- We draw 'after' in this roundabout way to avoid using MonadFix
447 -- 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)
403 let drawInitialChild = do
449 let drawInitialChild = do
404 result <- a0
450 result <- a0
405 append after
451 append after
406 return result
452 return result
407 (result0, result') <- lift $ runWithReplace (runImmediateDomBuilderT drawInitialChild initialEnv) $ ffor a' $ \child -> do
453 (result0, result') <- lift $ runWithReplace (runImmediateDomBuilderT drawInitialChild initialEnv) $ ffor a' $ \child -> do
408− Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
454+ df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv
409 result <- runImmediateDomBuilderT child $ initialEnv
455 result <- runImmediateDomBuilderT child $ initialEnv
410 { _immediateDomBuilderEnv_parent = toNode df
456 { _immediateDomBuilderEnv_parent = toNode df
411 }
457 }
@@ -419,7 +465,7 @@ instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, PerformEvent t m,
419 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.
465 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.
420 drawChildUpdate :: ImmediateDomBuilderT t m a -> m (DOM.DocumentFragment, DOM.Text, a)
466 drawChildUpdate :: ImmediateDomBuilderT t m a -> m (DOM.DocumentFragment, DOM.Text, a)
421 drawChildUpdate child = do
467 drawChildUpdate child = do
422− Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
468+ df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv
423 runImmediateDomBuilderT ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child) $ initialEnv
469 runImmediateDomBuilderT ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child) $ initialEnv
424 { _immediateDomBuilderEnv_parent = toNode df
470 { _immediateDomBuilderEnv_parent = toNode df
425 }
471 }
@@ -454,12 +500,12 @@ mkHasFocus e = do
454 ]
500 ]
455
501
456{-# INLINABLE insertImmediateAbove #-}
502{-# 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)
458insertImmediateAbove n toInsertAbove = do
504insertImmediateAbove n toInsertAbove = do
459 events <- askEvents
505 events <- askEvents
460 lift $ performEvent $ ffor toInsertAbove $ \new -> do
506 lift $ performEvent $ ffor toInsertAbove $ \new -> do
461− Just doc <- getOwnerDocument n
507+ doc <- getOwnerDocumentUnchecked n
462− Just df <- createDocumentFragment doc
508+ df <- createDocumentFragmentUnchecked doc
463 result <- runImmediateDomBuilderT new $ ImmediateDomBuilderEnv
509 result <- runImmediateDomBuilderT new $ ImmediateDomBuilderEnv
464 { _immediateDomBuilderEnv_parent = toNode df
510 { _immediateDomBuilderEnv_parent = toNode df
465 , _immediateDomBuilderEnv_document = doc
511 , _immediateDomBuilderEnv_document = doc
@@ -468,12 +514,10 @@ insertImmediateAbove n toInsertAbove = do
468 df `insertBefore` n
514 df `insertBefore` n
469 return result
515 return result
470
516
471−insertBefore :: (MonadIO m, IsNode new, IsNode existing) => new -> existing -> m ()
517+insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
472insertBefore new existing = do
518insertBefore new existing = do
473− mp <- getParentNode existing
519+ p <- getParentNodeUnchecked 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
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
477
521
478instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where
522instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where
479 type Performable (ImmediateDomBuilderT t m) = Performable m
523 type Performable (ImmediateDomBuilderT t m) = Performable m
@@ -501,17 +545,17 @@ instance (Monad m, MonadRef m, Ref m ~ Ref IO, MonadReflexCreateTrigger t m) =>
501 newTriggerEventWithOnComplete = do
545 newTriggerEventWithOnComplete = do
502 events <- askEvents
546 events <- askEvents
503 (eResult, reResultTrigger) <- lift newEventWithTriggerRef
547 (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)]
505 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
549 {-# INLINABLE newEventWithLazyTriggerWithOnComplete #-}
506 newEventWithLazyTriggerWithOnComplete f = do
550 newEventWithLazyTriggerWithOnComplete f = do
507 events <- askEvents
551 events <- askEvents
508 lift $ newEventWithTrigger $ \t -> f $ \a cb -> do
552 lift $ newEventWithTrigger $ \t -> f $ \a cb -> do
509 reResultTrigger <- newIORef $ Just t
553 reResultTrigger <- newIORef $ Just t
510− writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a cb]
554+ writeChan events [TriggerRef reResultTrigger :=> TriggerInvocation a (liftIO cb)]
511
555
512−instance HasWebView m => HasWebView (ImmediateDomBuilderT t m) where
556+instance HasJSContext m => HasJSContext (ImmediateDomBuilderT t m) where
513− type WebViewPhantom (ImmediateDomBuilderT t m) = WebViewPhantom m
557+ type JSContextPhantom (ImmediateDomBuilderT t m) = JSContextPhantom m
514− askWebView = lift askWebView
558+ askJSContext = lift askJSContext
515
559
516instance MonadRef m => MonadRef (ImmediateDomBuilderT t m) where
560instance MonadRef m => MonadRef (ImmediateDomBuilderT t m) where
517 type Ref (ImmediateDomBuilderT t m) = Ref m
561 type Ref (ImmediateDomBuilderT t m) = Ref m
@@ -527,7 +571,7 @@ instance MonadAtomicRef m => MonadAtomicRef (ImmediateDomBuilderT t m) where
527 atomicModifyRef r = lift . atomicModifyRef r
571 atomicModifyRef r = lift . atomicModifyRef r
528
572
529instance (HasJS x m, ReflexHost t) => HasJS x (ImmediateDomBuilderT t m) where
573instance (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
531 liftJS = lift . liftJS
575 liftJS = lift . liftJS
532
576
533type family EventType en where
577type family EventType en where
@@ -728,8 +772,57 @@ withIsEvent en r = case en of
728 Mousewheel -> r
772 Mousewheel -> r
729 Wheel -> r
773 Wheel -> r
730
774
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+
731{-# INLINABLE elementOnEventName #-}
824{-# 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 ())
733elementOnEventName en e = case en of
826elementOnEventName en e = case en of
734 Abort -> on e Element.abort
827 Abort -> on e Element.abort
735 Blur -> on e Element.blurEvent
828 Blur -> on e Element.blurEvent
@@ -779,7 +872,7 @@ elementOnEventName en e = case en of
779 Touchcancel -> on e Element.touchCancel
872 Touchcancel -> on e Element.touchCancel
780
873
781{-# INLINABLE windowOnEventName #-}
874{-# 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 ())
783windowOnEventName en e = case en of
876windowOnEventName en e = case en of
784 Abort -> on e Window.abort
877 Abort -> on e Window.abort
785 Blur -> on e Window.blurEvent
878 Blur -> on e Window.blurEvent
@@ -829,15 +922,15 @@ windowOnEventName en e = case en of
829 Touchcancel -> on e Window.touchCancel
922 Touchcancel -> on e Window.touchCancel
830
923
831{-# INLINABLE wrapDomEvent #-}
924{-# 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)
833wrapDomEvent el elementOnevent getValue = wrapDomEventMaybe el elementOnevent $ fmap Just getValue
926wrapDomEvent el elementOnevent getValue = wrapDomEventMaybe el elementOnevent $ fmap Just getValue
834
927
835{-# INLINABLE subscribeDomEvent #-}
928{-# INLINABLE subscribeDomEvent #-}
836−subscribeDomEvent :: (EventM e event () -> IO (IO ()))
929+subscribeDomEvent :: (EventM e event () -> JSM (JSM ()))
837 -> EventM e event (Maybe a)
930 -> EventM e event (Maybe a)
838 -> Chan [DSum (TriggerRef t) TriggerInvocation]
931 -> Chan [DSum (TriggerRef t) TriggerInvocation]
839 -> EventTrigger t a
932 -> EventTrigger t a
840− -> IO (IO ())
933+ -> JSM (JSM ())
841subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do
934subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do
842 mv <- getValue
935 mv <- getValue
843 forM_ mv $ \v -> liftIO $ do
936 forM_ mv $ \v -> liftIO $ do
@@ -846,25 +939,28 @@ subscribeDomEvent elementOnevent getValue eventChan et = elementOnevent $ do
846 writeChan eventChan [TriggerRef etr :=> TriggerInvocation v (return ())]
939 writeChan eventChan [TriggerRef etr :=> TriggerInvocation v (return ())]
847
940
848{-# INLINABLE wrapDomEventMaybe #-}
941{-# INLINABLE wrapDomEventMaybe #-}
849−wrapDomEventMaybe :: TriggerEvent t m
942+wrapDomEventMaybe :: (TriggerEvent t m, MonadJSM m)
850 => e
943 => e
851− -> (e -> EventM e event () -> IO (IO ()))
944+ -> (e -> EventM e event () -> JSM (JSM ()))
852 -> EventM e event (Maybe a)
945 -> EventM e event (Maybe a)
853 -> m (Event t a)
946 -> m (Event t a)
854wrapDomEventMaybe el elementOnevent getValue = do
947wrapDomEventMaybe el elementOnevent getValue = do
948+ ctx <- askJSM
855− newEventWithLazyTriggerWithOnComplete $ \trigger -> elementOnevent el $ do
949+ newEventWithLazyTriggerWithOnComplete $ \trigger -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnevent el $ do
856 mv <- getValue
950 mv <- getValue
857− forM_ mv $ \v -> liftIO $ trigger v $ return ()
951+ forM_ mv $ \v -> liftIO $ trigger v $ return ())
858
952
859{-# INLINABLE wrapDomEventsMaybe #-}
953{-# INLINABLE wrapDomEventsMaybe #-}
860−wrapDomEventsMaybe :: (MonadIO m, MonadReflexCreateTrigger t m)
954+wrapDomEventsMaybe :: (MonadJSM m, MonadReflexCreateTrigger t m)
861 => e
955 => e
862 -> (forall en. IsEvent (EventType en) => EventName en -> EventM e (EventType en) (Maybe (f en)))
956 -> (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 ()))
864 -> ImmediateDomBuilderT t m (EventSelector t (WrapArg f EventName))
958 -> ImmediateDomBuilderT t m (EventSelector t (WrapArg f EventName))
865wrapDomEventsMaybe target handlers onEventName = do
959wrapDomEventsMaybe target handlers onEventName = do
960+ ctx <- askJSM
866 eventChan <- askEvents
961 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)
868 return $! e
964 return $! e
869
965
870{-# INLINABLE getKeyEvent #-}
966{-# INLINABLE getKeyEvent #-}
@@ -905,7 +1001,7 @@ data Window t = Window
905 , _window_raw :: DOM.Window
1001 , _window_raw :: DOM.Window
906 }
1002 }
907
1003
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)
909wrapWindow wv _ = do
1005wrapWindow wv _ = do
910 events <- wrapDomEventsMaybe wv (defaultDomWindowEventHandler wv) windowOnEventName
1006 events <- wrapDomEventsMaybe wv (defaultDomWindowEventHandler wv) windowOnEventName
911 return $ Window
1007 return $ Window
@@ -913,4 +1009,6 @@ wrapWindow wv _ = do
913 , _window_raw = wv
1009 , _window_raw = wv
914 }
1010 }
915
1011
1012+#ifdef USE_TEMPLATE_HASKELL
916makeLenses ''GhcjsEventSpec
1013makeLenses ''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
84 }
84 }
85 lift $ selectElement cfg' $ runInputDisabledT child
85 lift $ selectElement cfg' $ runInputDisabledT child
86
86
87−instance HasWebView m => HasWebView (InputDisabledT m) where
87+instance HasJSContext m => HasJSContext (InputDisabledT m) where
88− type WebViewPhantom (InputDisabledT m) = WebViewPhantom m
88+ type JSContextPhantom (InputDisabledT m) = JSContextPhantom m
89− askWebView = lift askWebView
89+ askJSContext = lift askJSContext
90
90
91instance HasJS js m => HasJS js (InputDisabledT m) where
91instance HasJS js m => HasJS js (InputDisabledT m) where
92− type JSM (InputDisabledT m) = JSM m
92+ type JSX (InputDisabledT m) = JSX m
93 liftJS = lift . liftJS
93 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
2
2
3import Reflex as X hiding (askEvents)
3import Reflex as X hiding (askEvents)
4import Reflex.Dom.Builder.Class as X
4import Reflex.Dom.Builder.Class as X
@@ -6,8 +6,8 @@ import Reflex.Dom.Builder.Immediate as X
6import Reflex.Dom.Builder.InputDisabled as X
6import Reflex.Dom.Builder.InputDisabled as X
7import Reflex.Dom.Builder.Static as X
7import Reflex.Dom.Builder.Static as X
8import Reflex.Dom.Class as X
8import Reflex.Dom.Class as X
9−import Reflex.Dom.Internal as X
10import Reflex.Dom.Location as X
9import Reflex.Dom.Location as X
10+import Reflex.Dom.Main as X
11import Reflex.Dom.Old as X
11import Reflex.Dom.Old as X
12import Reflex.Dom.Time as X
12import Reflex.Dom.Time as X
13import Reflex.Dom.WebSocket as X
13import 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
2+
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)
8+
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 #-}
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
@@ -11,14 +12,14 @@
11{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE TypeOperators #-}
13{-# LANGUAGE TypeOperators #-}
13{-# LANGUAGE UndecidableInstances #-}
14{-# LANGUAGE UndecidableInstances #-}
15+{-# LANGUAGE PatternSynonyms #-}
14−module Reflex.Dom.Internal where
16+module Reflex.Dom.Main where
15
17
16import Prelude hiding (concat, mapM, mapM_, sequence, sequence_)
18import Prelude hiding (concat, mapM, mapM_, sequence, sequence_)
17
19
18import qualified Reflex as R
20import qualified Reflex as R
19import Reflex.Dom.Builder.Immediate
21import Reflex.Dom.Builder.Immediate
20import Reflex.Dom.Class
22import Reflex.Dom.Class
21−import Reflex.Dom.Internal.Foreign
22import Reflex.Host.Class
23import Reflex.Host.Class
23import Reflex.PerformEvent.Base
24import Reflex.PerformEvent.Base
24import Reflex.PostBuild.Base
25import Reflex.PostBuild.Base
@@ -38,74 +39,91 @@ import Data.Monoid ((<>))
38import Data.Text (Text)
39import Data.Text (Text)
39import qualified Data.Text as T
40import qualified Data.Text as T
40import Data.Text.Encoding
41import Data.Text.Encoding
41−import GHCJS.DOM hiding (runWebGUI)
42+import GHCJS.DOM
42import GHCJS.DOM.Document
43import GHCJS.DOM.Document
43import GHCJS.DOM.Element
44import GHCJS.DOM.Element
44import GHCJS.DOM.Node
45import GHCJS.DOM.Node
45import qualified GHCJS.DOM.Types as DOM
46import qualified GHCJS.DOM.Types as DOM
47+import GHCJS.DOM.Types (MonadJSM(..), JSM)
46
48
47{-# INLINABLE mainWidget #-}
49{-# INLINABLE mainWidget #-}
48−mainWidget :: (forall x. Widget x ()) -> IO ()
50+mainWidget :: (forall x. Widget x ()) -> JSM ()
49−mainWidget w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
51+mainWidget w = withJSContextSingleton $ \jsSing -> do
50− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
52+ doc <- currentDocumentUnchecked
51− Just body <- getBody doc
53+ body <- getBodyUnchecked doc
52− attachWidget body webViewSing w
54+ attachWidget body jsSing w
55+ forever $ do
56+ liftIO $ threadDelay 100000
57+ syncPoint
53
58
54--TODO: The x's should be unified here
59--TODO: The x's should be unified here
55{-# INLINABLE mainWidgetWithHead #-}
60{-# INLINABLE mainWidgetWithHead #-}
56−mainWidgetWithHead :: (forall x. Widget x ()) -> (forall x. Widget x ()) -> IO ()
61+mainWidgetWithHead :: (forall x. Widget x ()) -> (forall x. Widget x ()) -> JSM ()
57−mainWidgetWithHead h b = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
62+mainWidgetWithHead h b = withJSContextSingleton $ \jsSing -> do
58− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
63+ doc <- currentDocumentUnchecked
59− Just headElement <- fmap DOM.castToHTMLElement <$> getHead doc
64+ headElement <- getHeadUnchecked doc
60− attachWidget headElement webViewSing h
65+ attachWidget headElement jsSing h
61− Just body <- getBody doc
66+ body <- getBodyUnchecked doc
62− attachWidget body webViewSing b
67+ attachWidget body jsSing b
68+ forever $ do
69+ liftIO $ threadDelay 100000
70+ syncPoint
63
71
64{-# INLINABLE mainWidgetWithCss #-}
72{-# INLINABLE mainWidgetWithCss #-}
65−mainWidgetWithCss :: ByteString -> (forall x. Widget x ()) -> IO ()
73+mainWidgetWithCss :: ByteString -> (forall x. Widget x ()) -> JSM ()
66−mainWidgetWithCss css w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
74+mainWidgetWithCss css w = withJSContextSingleton $ \jsSing -> do
67− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
75+ doc <- currentDocumentUnchecked
68− Just headElement <- fmap DOM.castToHTMLElement <$> getHead doc
76+ headElement <- getHeadUnchecked doc
69 setInnerHTML headElement . Just $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this
77 setInnerHTML headElement . Just $ "<style>" <> T.unpack (decodeUtf8 css) <> "</style>" --TODO: Fix this
70− Just body <- getBody doc
78+ body <- getBodyUnchecked doc
71− attachWidget body webViewSing w
79+ attachWidget body jsSing w
80+ forever $ do
81+ liftIO $ threadDelay 100000
82+ syncPoint
72
83
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
74
85
75−{-# INLINABLE attachWidget #-}
86+#ifndef __GHCJS__
76−attachWidget :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO a
87+instance MonadJSM m => MonadJSM (PostBuildT t m) where
77−attachWidget rootElement wv w = fst <$> attachWidget' rootElement wv w
88+ liftJSM' = PostBuildT . liftJSM'
89+#endif
78
90
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+
79−mainWidgetWithHead' :: (forall x. (a -> Widget x b, b -> Widget x a)) -> IO ()
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
80−mainWidgetWithHead' widgets = runWebGUI $ \webView -> withWebViewSingleton webView $ \wv -> fmap fst $ attachWidget'' $ \events -> do
100+-- runWebGUI $ \webView -> withWebViewSingleton webView $ \wv ->
101+ liftIO $ fmap fst $ attachWidget'' $ \events -> do
81 let (headWidget, bodyWidget) = widgets
102 let (headWidget, bodyWidget) = widgets
82− Just doc <- liftIO $ fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
83− Just headElement <- getHead doc
84− Just bodyElement <- getBody doc
85 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
103 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
86− rec b <- unsafeReplaceElementContentsWithWidget events postBuild headElement wv $ headWidget a
104+ rec b <- unsafeReplaceElementContentsWithWidget events postBuild headElement jsSing $ headWidget a
87− a <- unsafeReplaceElementContentsWithWidget events postBuild bodyElement wv $ bodyWidget b
105+ a <- unsafeReplaceElementContentsWithWidget events postBuild bodyElement jsSing $ bodyWidget b
88 return ((), postBuildTriggerRef)
106 return ((), postBuildTriggerRef)
89
107
90−unsafeReplaceElementContentsWithWidget :: DOM.IsElement e => EventChannel -> R.Event Spider () -> e -> WebViewSingleton x -> Widget x a -> PerformEventT Spider (SpiderHost Global) a
108+unsafeReplaceElementContentsWithWidget :: DOM.IsElement e => EventChannel -> R.Event Spider () -> e -> JSContextSingleton x -> Widget x a -> PerformEventT Spider (SpiderHost Global) a
91−unsafeReplaceElementContentsWithWidget events postBuild rootElement wv w = do
109+unsafeReplaceElementContentsWithWidget events postBuild rootElement jsSing w = (`runWithJSContextSingleton` jsSing) $ do
92− Just doc <- getOwnerDocument rootElement
110+ doc <- getOwnerDocumentUnchecked rootElement
93− Just df <- createDocumentFragment doc
111+ df <- createDocumentFragmentUnchecked doc
94 let builderEnv = ImmediateDomBuilderEnv
112 let builderEnv = ImmediateDomBuilderEnv
95 { _immediateDomBuilderEnv_document = doc
113 { _immediateDomBuilderEnv_document = doc
96 , _immediateDomBuilderEnv_parent = toNode df
114 , _immediateDomBuilderEnv_parent = toNode df
97 , _immediateDomBuilderEnv_events = events
115 , _immediateDomBuilderEnv_events = events
98 }
116 }
99− result <- runWithWebView (runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv) wv
117+ result <- runImmediateDomBuilderT (runPostBuildT w postBuild) builderEnv
100 setInnerHTML rootElement $ Just ("" :: String)
118 setInnerHTML rootElement $ Just ("" :: String)
101− _ <- appendChild rootElement $ Just df
119+ _ <- appendChildUnchecked rootElement $ Just df
102 return result
120 return result
103
121
104{-# INLINABLE attachWidget' #-}
122{-# INLINABLE attachWidget' #-}
105−attachWidget' :: DOM.IsElement e => e -> WebViewSingleton x -> Widget x a -> IO (a, FireCommand Spider (SpiderHost Global))
123+attachWidget' :: DOM.IsElement e => e -> JSContextSingleton x -> Widget x a -> IO (a, FireCommand Spider (SpiderHost Global))
106−attachWidget' rootElement wv w = attachWidget'' $ \events -> do
124+attachWidget' rootElement jsSing w = attachWidget'' $ \events -> do
107 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
125 (postBuild, postBuildTriggerRef) <- newEventWithTriggerRef
108− result <- unsafeReplaceElementContentsWithWidget events postBuild rootElement wv w
126+ result <- unsafeReplaceElementContentsWithWidget events postBuild rootElement jsSing w
109 return (result, postBuildTriggerRef)
127 return (result, postBuildTriggerRef)
110
128
111type EventChannel = Chan [DSum (TriggerRef Spider) TriggerInvocation]
129type EventChannel = Chan [DSum (TriggerRef Spider) TriggerInvocation]
@@ -121,7 +139,7 @@ attachWidget'' w = do
121 return (result, fc)
139 return (result, fc)
122 void $ forkIO $ forever $ do
140 void $ forkIO $ forever $ do
123 ers <- readChan events
141 ers <- readChan events
124− _ <- postGUISync $ runSpiderHost $ do
142+ _ <- runSpiderHost $ do
125 mes <- liftIO $ forM ers $ \(TriggerRef er :=> TriggerInvocation a _) -> do
143 mes <- liftIO $ forM ers $ \(TriggerRef er :=> TriggerInvocation a _) -> do
126 me <- readIORef er
144 me <- readIORef er
127 return $ fmap (\e -> e :=> Identity a) me
145 return $ fmap (\e -> e :=> Identity a) me
@@ -131,11 +149,14 @@ attachWidget'' w = do
131 return (result, fc)
149 return (result, fc)
132
150
133-- | Run a reflex-dom application inside of an existing DOM element with the given ID
151-- | Run a reflex-dom application inside of an existing DOM element with the given ID
134−mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> IO ()
152+mainWidgetInElementById :: Text -> (forall x. Widget x ()) -> JSM ()
135−mainWidgetInElementById eid w = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
153+mainWidgetInElementById eid w = withJSContextSingleton $ \jsSing -> do
136− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
154+ doc <- currentDocumentUnchecked
137− Just root <- getElementById doc eid
155+ root <- getElementByIdUnchecked doc eid
138− attachWidget root webViewSing w
156+ attachWidget root jsSing w
157+ forever $ do
158+ liftIO $ threadDelay 100000
159+ syncPoint
139
160
140data AppInput t = AppInput
161data AppInput t = AppInput
141 { _appInput_window :: Window t
162 { _appInput_window :: Window t
@@ -145,14 +166,16 @@ data AppOutput t = AppOutput --TODO: Add quit event
145 { _appOutput_windowConfig :: WindowConfig t
166 { _appOutput_windowConfig :: WindowConfig t
146 }
167 }
147
168
148−runApp' :: (t ~ Spider) => (forall x. AppInput t -> Widget x (AppOutput t)) -> IO ()
169+runApp' :: (t ~ Spider) => (forall x. AppInput t -> Widget x (AppOutput t)) -> JSM ()
149−runApp' app = runWebGUI $ \webView -> withWebViewSingleton webView $ \webViewSing -> do
170+runApp' app = withJSContextSingleton $ \jsSing -> do
150− Just doc <- fmap DOM.castToHTMLDocument <$> webViewGetDomDocument webView
171+ doc <- currentDocumentUnchecked
151− Just body <- getBody doc
172+ body <- getBodyUnchecked doc
152− Just win <- getDefaultView doc
173+ win <- getDefaultViewUnchecked doc
153− rec o <- attachWidget body webViewSing $ do
174+ rec o <- attachWidget body jsSing $ do
154 w <- lift $ wrapWindow win $ _appOutput_windowConfig o
175 w <- lift $ wrapWindow win $ _appOutput_windowConfig o
155 app $ AppInput
176 app $ AppInput
156 { _appInput_window = w
177 { _appInput_window = w
157 }
178 }
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 #-}
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ExplicitForAll #-}
3{-# LANGUAGE ExplicitForAll #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
@@ -5,9 +6,12 @@
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE Rank2Types #-}
7{-# LANGUAGE Rank2Types #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE TemplateHaskell #-}
9{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE UndecidableInstances #-}
10{-# LANGUAGE UndecidableInstances #-}
11+{-# LANGUAGE LambdaCase #-}
12+#ifdef USE_TEMPLATE_HASKELL
13+{-# LANGUAGE TemplateHaskell #-}
14+#endif
11module Reflex.Dom.Old
15module Reflex.Dom.Old
12 ( MonadWidget
16 ( MonadWidget
13 , El
17 , El
@@ -31,7 +35,6 @@ module Reflex.Dom.Old
31 , elWith'
35 , elWith'
32 , emptyElWith
36 , emptyElWith
33 , emptyElWith'
37 , emptyElWith'
34− , getQuitWidget
35 , namedNodeMapGetNames
38 , namedNodeMapGetNames
36 , nodeClear
39 , nodeClear
37 , onEventName
40 , onEventName
@@ -43,7 +46,11 @@ module Reflex.Dom.Old
43 ) where
46 ) where
44
47
45import Control.Arrow (first)
48import Control.Arrow (first)
49+#ifdef USE_TEMPLATE_HASKELL
46import Control.Lens (makeLenses, (%~), (&), (.~), (^.))
50import Control.Lens (makeLenses, (%~), (&), (.~), (^.))
51+#else
52+import Control.Lens (Lens, Lens', (%~), (&), (.~), (^.))
53+#endif
47import Control.Monad
54import Control.Monad
48import Control.Monad.Fix
55import Control.Monad.Fix
49import Control.Monad.IO.Class
56import Control.Monad.IO.Class
@@ -62,13 +69,13 @@ import Foreign.JavaScript.TH
62import qualified GHCJS.DOM.Element as Element
69import qualified GHCJS.DOM.Element as Element
63import GHCJS.DOM.EventM (EventM)
70import GHCJS.DOM.EventM (EventM)
64import GHCJS.DOM.NamedNodeMap as NNM
71import GHCJS.DOM.NamedNodeMap as NNM
65−import GHCJS.DOM.Node (getFirstChild, getNodeName, removeChild)
72+import GHCJS.DOM.Node (getFirstChild, getNodeName, getParentNode, getPreviousSibling, removeChildUnchecked)
66−import GHCJS.DOM.Types (IsElement, IsNode)
73+import GHCJS.DOM.Types
74+ (MonadJSM, strictEqual, liftJSM, JSM, IsElement, IsNode)
67import qualified GHCJS.DOM.Types as DOM
75import qualified GHCJS.DOM.Types as DOM
68import Reflex.Class
76import Reflex.Class
69import Reflex.Dom.Builder.Class
77import Reflex.Dom.Builder.Class
70import Reflex.Dom.Builder.Immediate
78import Reflex.Dom.Builder.Immediate
71−import Reflex.Dom.Internal.Foreign
72import Reflex.Dom.Widget.Basic
79import Reflex.Dom.Widget.Basic
73import Reflex.Host.Class
80import Reflex.Host.Class
74import Reflex.PerformEvent.Class
81import Reflex.PerformEvent.Class
@@ -86,7 +93,16 @@ instance attrs ~ Map Text Text => Default (ElConfig attrs) where
86 , _elConfig_attributes = mempty
93 , _elConfig_attributes = mempty
87 }
94 }
88
95
96+#ifdef USE_TEMPLATE_HASKELL
89makeLenses ''ElConfig
97makeLenses ''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
90
106
91--TODO: HasDocument is still not accounted for
107--TODO: HasDocument is still not accounted for
92type MonadWidgetConstraints t m =
108type MonadWidgetConstraints t m =
@@ -100,9 +116,13 @@ type MonadWidgetConstraints t m =
100 , PerformEvent t m
116 , PerformEvent t m
101 , MonadIO m
117 , MonadIO m
102 , MonadIO (Performable m)
118 , MonadIO (Performable m)
119+#ifndef ghcjs_HOST_OS
120+ , MonadJSM m
121+ , MonadJSM (Performable m)
122+#endif
103 , TriggerEvent t m
123 , TriggerEvent t m
104− , HasWebView m
124+ , HasJSContext m
105− , HasWebView (Performable m)
125+ , HasJSContext (Performable m)
106 , MonadRef m
126 , MonadRef m
107 , Ref m ~ Ref IO
127 , Ref m ~ Ref IO
108 , MonadRef (Performable m)
128 , MonadRef (Performable m)
@@ -159,7 +179,8 @@ addDynamicAttributes attrs cfg = do
159buildElementCommon :: MonadWidget t m => Text -> m a -> ElementConfig er t m -> m (Element er (DomBuilderSpace m) t, a)
179buildElementCommon :: MonadWidget t m => Text -> m a -> ElementConfig er t m -> m (Element er (DomBuilderSpace m) t, a)
160buildElementCommon elementTag child cfg = element elementTag cfg child
180buildElementCommon elementTag child cfg = element elementTag cfg child
161
181
182+
162−onEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> IO (IO ())
183+onEventName :: IsElement e => EventName en -> e -> EventM e (EventType en) () -> JSM (JSM ())
163onEventName = elementOnEventName
184onEventName = elementOnEventName
164
185
165schedulePostBuild :: (PostBuild t m, PerformEvent t m) => WidgetHost m () -> m ()
186schedulePostBuild :: (PostBuild t m, PerformEvent t m) => WidgetHost m () -> m ()
@@ -211,7 +232,7 @@ _el_scrolled = domEvent Scroll
211
232
212wrapElement :: 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)
233wrapElement :: 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)
213wrapElement eh e = do
234wrapElement 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))
215 h (en, GhcjsDomEvent evt) = runReaderT (eh e en) evt
236 h (en, GhcjsDomEvent evt) = runReaderT (eh e en) evt
216 wrapRawElement e $ (def :: RawElementConfig EventResult t m)
237 wrapRawElement e $ (def :: RawElementConfig EventResult t m)
217 { _rawElementConfig_eventSpec = def
238 { _rawElementConfig_eventSpec = def
@@ -224,28 +245,23 @@ unsafePlaceElement e = do
224 placeRawElement e
245 placeRawElement e
225 wrapRawElement e def
246 wrapRawElement e def
226
247
227−namedNodeMapGetNames :: DOM.NamedNodeMap -> IO (Set Text)
248+namedNodeMapGetNames :: DOM.NamedNodeMap -> JSM (Set Text)
228namedNodeMapGetNames self = do
249namedNodeMapGetNames self = do
229 l <- NNM.getLength self
250 l <- NNM.getLength self
230 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
251 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
231 fmap (Set.fromList . catMaybes) $ forM locations $ \i -> do
252 fmap (Set.fromList . catMaybes) $ forM locations $ \i -> do
232− Just n <- NNM.item self i
253+ n <- NNM.itemUnchecked self i
233 getNodeName n
254 getNodeName n
234
255
235−nodeClear :: IsNode self => self -> IO ()
256+nodeClear :: IsNode self => self -> JSM ()
236nodeClear n = do
257nodeClear n = do
237 mfc <- getFirstChild n
258 mfc <- getFirstChild n
238 case mfc of
259 case mfc of
239 Nothing -> return ()
260 Nothing -> return ()
240 Just fc -> do
261 Just fc -> do
241− _ <- removeChild n $ Just fc
262+ removeChildUnchecked n $ Just fc
242 nodeClear n
263 nodeClear n
243
264
244−getQuitWidget :: MonadWidget t m => m (WidgetHost m ())
245−getQuitWidget = return $ do
246− WebViewSingleton wv <- askWebView
247− liftIO $ quitWebView wv
248−
249elStopPropagationNS :: forall t m en a. (MonadWidget t m) => Maybe Text -> Text -> EventName en -> m a -> m a
265elStopPropagationNS :: forall t m en a. (MonadWidget t m) => Maybe Text -> Text -> EventName en -> m a -> m a
250elStopPropagationNS ns elementTag en child = do
266elStopPropagationNS ns elementTag en child = do
251 let f = GhcjsEventFilter $ \_ -> do
267 let f = GhcjsEventFilter $ \_ -> do
@@ -255,12 +271,12 @@ elStopPropagationNS ns elementTag en child = do
255 & elementConfig_eventSpec . ghcjsEventSpec_filters %~ DMap.insert en f
271 & elementConfig_eventSpec . ghcjsEventSpec_filters %~ DMap.insert en f
256 snd <$> element elementTag cfg child
272 snd <$> element elementTag cfg child
257
273
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)
259elDynHtmlAttr' elementTag attrs html = do
275elDynHtmlAttr' elementTag attrs html = do
260 let cfg = def & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs
276 let cfg = def & initialAttributes .~ Map.mapKeys (AttributeName Nothing) attrs
261 (e, _) <- element elementTag cfg $ return ()
277 (e, _) <- element elementTag cfg $ return ()
262 postBuild <- getPostBuild
278 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]
264 return e
280 return e
265
281
266elDynHtml' :: MonadWidget t m => Text -> Dynamic t Text -> m (Element EventResult GhcjsDomSpace t)
282elDynHtml' :: 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 #-}
1{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE AllowAmbiguousTypes #-}
2{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE ConstraintKinds #-}
3{-# LANGUAGE DeriveDataTypeable #-}
4{-# LANGUAGE DeriveDataTypeable #-}
@@ -15,7 +16,9 @@
15{-# LANGUAGE RecursiveDo #-}
16{-# LANGUAGE RecursiveDo #-}
16{-# LANGUAGE ScopedTypeVariables #-}
17{-# LANGUAGE ScopedTypeVariables #-}
17{-# LANGUAGE StandaloneDeriving #-}
18{-# LANGUAGE StandaloneDeriving #-}
19+#ifdef USE_TEMPLATE_HASKELL
18{-# LANGUAGE TemplateHaskell #-}
20{-# LANGUAGE TemplateHaskell #-}
21+#endif
19{-# LANGUAGE TypeFamilies #-}
22{-# LANGUAGE TypeFamilies #-}
20{-# LANGUAGE UndecidableInstances #-}
23{-# LANGUAGE UndecidableInstances #-}
21
24
@@ -32,7 +35,7 @@ import Reflex.TriggerEvent.Class
32
35
33import Control.Concurrent
36import Control.Concurrent
34import Control.Concurrent.STM
37import Control.Concurrent.STM
35−import Control.Exception (SomeException, catch)
38+import Control.Exception (SomeException)
36import Control.Lens
39import Control.Lens
37import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
40import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
38import Control.Monad.IO.Class
41import Control.Monad.IO.Class
@@ -42,6 +45,8 @@ import Data.Default
42import Data.IORef
45import Data.IORef
43import Data.Maybe (isJust)
46import Data.Maybe (isJust)
44import Data.Text
47import Data.Text
48+import GHCJS.DOM.Types (runJSM, askJSM, MonadJSM, liftJSM, JSM)
49+import qualified Language.Javascript.JSaddle.Monad as JS (catch)
45
50
46data WebSocketConfig t a
51data WebSocketConfig t a
47 = WebSocketConfig { _webSocketConfig_send :: Event t [a]
52 = WebSocketConfig { _webSocketConfig_send :: Event t [a]
@@ -72,12 +77,12 @@ instance (IsWebSocketMessage a, IsWebSocketMessage b) => IsWebSocketMessage (Eit
72 webSocketSend jws (Right a) = webSocketSend jws a
77 webSocketSend jws (Right a) = webSocketSend jws a
73
78
74
79
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)
76webSocket url config = webSocket' url config onBSMessage
81webSocket url config = webSocket' url config onBSMessage
77
82
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)
79webSocket' url config onRawMessage = do
84webSocket' url config onRawMessage = do
80− wv <- fmap unWebViewSingleton askWebView
85+ wv <- fmap unJSContextSingleton askJSContext
81 (eRecv, onMessage) <- newTriggerEvent
86 (eRecv, onMessage) <- newTriggerEvent
82 currentSocketRef <- liftIO $ newIORef Nothing
87 currentSocketRef <- liftIO $ newIORef Nothing
83 (eOpen, triggerEOpen) <- newTriggerEventWithOnComplete
88 (eOpen, triggerEOpen) <- newTriggerEventWithOnComplete
@@ -88,27 +93,26 @@ webSocket' url config onRawMessage = do
88 let onOpen = triggerEOpen () $ liftIO $ void $ atomically $ tryPutTMVar isOpen ()
93 let onOpen = triggerEOpen () $ liftIO $ void $ atomically $ tryPutTMVar isOpen ()
89 onError = triggerEError ()
94 onError = triggerEError ()
90 onClose args = do
95 onClose args = do
91− triggerEClose args
96+ liftIO $ 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
97+ _ <- liftIO $ atomically $ tryTakeTMVar isOpen
95− liftIO $ writeIORef currentSocketRef Nothing
98+ liftIO $ writeIORef currentSocketRef Nothing
96− when (_webSocketConfig_reconnect config) $ do
99+ when (_webSocketConfig_reconnect config) $ do
97− liftIO $ threadDelay 1000000
100+ liftIO $ threadDelay 1000000
98− start
101+ start
99 start = do
102 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
101 liftIO $ writeIORef currentSocketRef $ Just ws
104 liftIO $ writeIORef currentSocketRef $ Just ws
102 return ()
105 return ()
103− performEvent_ . (liftIO start <$) =<< getPostBuild
106+ performEvent_ . (liftJSM start <$) =<< getPostBuild
104 performEvent_ $ ffor (_webSocketConfig_send config) $ \payloads -> forM_ payloads $ \payload ->
107 performEvent_ $ ffor (_webSocketConfig_send config) $ \payloads -> forM_ payloads $ \payload ->
105 liftIO $ atomically $ writeTQueue payloadQueue payload
108 liftIO $ atomically $ writeTQueue payloadQueue payload
106− performEvent_ $ ffor (_webSocketConfig_close config) $ \(code,reason) -> liftIO $ do
109+ performEvent_ $ ffor (_webSocketConfig_close config) $ \(code,reason) -> liftJSM $ do
107− mws <- readIORef currentSocketRef
110+ mws <- liftIO $ readIORef currentSocketRef
108 case mws of
111 case mws of
109 Nothing -> return ()
112 Nothing -> return ()
110 Just ws -> closeWebSocket ws (fromIntegral code) reason
113 Just ws -> closeWebSocket ws (fromIntegral code) reason
111
114
115+ ctx <- askJSM
112 _ <- liftIO $ forkIO $ forever $ do
116 _ <- liftIO $ forkIO $ forever $ do
113 payload <- atomically $ do
117 payload <- atomically $ do
114 pl <- readTQueue payloadQueue
118 pl <- readTQueue payloadQueue
@@ -118,10 +122,26 @@ webSocket' url config onRawMessage = do
118 mws <- liftIO $ readIORef currentSocketRef
122 mws <- liftIO $ readIORef currentSocketRef
119 success <- case mws of
123 success <- case mws of
120 Nothing -> return False
124 Nothing -> return False
121− Just ws -> liftIO ((webSocketSend ws payload >> return True)
125+ Just ws -> runJSM ((webSocketSend ws payload >> return True)
122− `catch`
126+ `JS.catch`
123− (\(_ :: SomeException) -> return False))
127+ (\(_ :: SomeException) -> return False)) ctx
124 unless success $ atomically $ unGetTQueue payloadQueue payload
128 unless success $ atomically $ unGetTQueue payloadQueue payload
125 return $ RawWebSocket eRecv eOpen eError eClose
129 return $ RawWebSocket eRecv eOpen eError eClose
126
130
131+#ifdef USE_TEMPLATE_HASKELL
127makeLensesWith (lensRules & simpleLenses .~ True) ''WebSocketConfig
132makeLensesWith (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
1{-# LANGUAGE ForeignFunctionInterface #-}
3{-# LANGUAGE ForeignFunctionInterface #-}
2{-# LANGUAGE JavaScriptFFI #-}
4{-# LANGUAGE JavaScriptFFI #-}
5+#endif
6+{-# LANGUAGE LambdaCase #-}
3
7
4module Reflex.Dom.WebSocket.Foreign
8module Reflex.Dom.WebSocket.Foreign
5 ( module Reflex.Dom.WebSocket.Foreign
9 ( module Reflex.Dom.WebSocket.Foreign
@@ -8,7 +12,6 @@ module Reflex.Dom.WebSocket.Foreign
8
12
9import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)
13import Prelude hiding (all, concat, concatMap, div, mapM, mapM_, sequence, span)
10
14
11−import Control.Monad.IO.Class
12import Control.Monad.Reader
15import Control.Monad.Reader
13import Data.ByteString (ByteString)
16import Data.ByteString (ByteString)
14import qualified Data.ByteString as BS
17import qualified Data.ByteString as BS
@@ -18,72 +21,77 @@ import Data.Text.Encoding
18import GHCJS.Buffer
21import GHCJS.Buffer
19import GHCJS.DOM.CloseEvent
22import GHCJS.DOM.CloseEvent
20import GHCJS.DOM.EventM (on)
23import GHCJS.DOM.EventM (on)
21−import GHCJS.DOM.EventTargetClosures (EventName, unsafeEventName)
22import GHCJS.DOM.MessageEvent
24import GHCJS.DOM.MessageEvent
23import GHCJS.DOM.Types hiding (Text)
25import GHCJS.DOM.Types hiding (Text)
24import qualified GHCJS.DOM.WebSocket as GD
26import qualified GHCJS.DOM.WebSocket as GD
25−import GHCJS.Foreign.Internal
27+import GHCJS.Foreign (JSType(..), jsTypeOf)
26−import GHCJS.Marshal.Pure
27import GHCJS.Types
28import GHCJS.Types
28import JavaScript.TypedArray.ArrayBuffer as JS
29import 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
29
35
30data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }
36data JSWebSocket = JSWebSocket { unWebSocket :: WebSocket }
31
37
32class IsWebSocketMessage a where
38class IsWebSocketMessage a where
33− webSocketSend :: JSWebSocket -> a -> IO ()
39+ webSocketSend :: JSWebSocket -> a -> JSM ()
34
40
35-- Use binary websocket communication for ByteString
41-- Use binary websocket communication for ByteString
36-- Note: Binary websockets may not work correctly in IE 11 and below
42-- Note: Binary websockets may not work correctly in IE 11 and below
37instance IsWebSocketMessage ByteString where
43instance IsWebSocketMessage ByteString where
38 webSocketSend (JSWebSocket ws) bs = do
44 webSocketSend (JSWebSocket ws) bs = do
39− let (b, off, len) = fromByteString bs
45+ (b, off, len) <- ghcjsPure $ fromByteString bs
40 ab <- ArrayBuffer <$> if BS.length bs == 0 --TODO: remove this logic when https://github.com/ghcjs/ghcjs-base/issues/49 is fixed
46 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
47+ then create 0 >>= ghcjsPure . getArrayBuffer >>= ghcjsPure . jsval
42− else return $ js_dataView off len $ jsval $ getArrayBuffer b
48+ else do
49+ ref <- ghcjsPure (getArrayBuffer b) >>= ghcjsPure . jsval
50+ js_dataView off len ref -- new (jsg "DataView") (ref, off, len)
43 GD.send ws $ Just ab
51 GD.send ws $ Just ab
44
52
45-- Use plaintext websocket communication for Text, and String
53-- Use plaintext websocket communication for Text, and String
46instance IsWebSocketMessage Text where
54instance IsWebSocketMessage Text where
47 webSocketSend (JSWebSocket ws) = GD.sendString ws . T.unpack
55 webSocketSend (JSWebSocket ws) = GD.sendString ws . T.unpack
48
56
49−closeWebSocket :: JSWebSocket -> Word -> Text -> IO ()
57+closeWebSocket :: JSWebSocket -> Word -> Text -> JSM ()
50closeWebSocket (JSWebSocket ws) = GD.close ws
58closeWebSocket (JSWebSocket ws) = GD.close ws
51
59
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−
57newWebSocket
60newWebSocket
58 :: a
61 :: a
59 -> Text -- url
62 -> Text -- url
60− -> (Either ByteString JSVal -> IO ()) -- onmessage
63+ -> (Either ByteString JSVal -> JSM ()) -- onmessage
61− -> IO () -- onopen
64+ -> JSM () -- onopen
62− -> IO () -- onerror
65+ -> JSM () -- onerror
63− -> ((Bool, Word, Text) -> IO ()) -- onclose
66+ -> ((Bool, Word, Text) -> JSM ()) -- onclose
64− -> IO JSWebSocket
67+ -> JSM JSWebSocket
65newWebSocket _ url onMessage onOpen onError onClose = do
68newWebSocket _ url onMessage onOpen onError onClose = do
66 ws <- GD.newWebSocket url (Just [] :: Maybe [Text])
69 ws <- GD.newWebSocket url (Just [] :: Maybe [Text])
67 GD.setBinaryType ws "arraybuffer"
70 GD.setBinaryType ws "arraybuffer"
68− _ <- on ws GD.open $ liftIO onOpen
71+ _ <- on ws GD.open $ liftJSM onOpen
69− _ <- on ws GD.error $ liftIO onError
72+ _ <- on ws GD.error $ liftJSM onError
70− _ <- on ws closeEvent $ do
73+ _ <- on ws GD.closeEvent $ do
71 e <- ask
74 e <- ask
72 wasClean <- getWasClean e
75 wasClean <- getWasClean e
73 code <- getCode e
76 code <- getCode e
74 reason <- getReason e
77 reason <- getReason e
75− liftIO $ onClose (wasClean, code, reason)
78+ liftJSM $ onClose (wasClean, code, reason)
76 _ <- on ws GD.message $ do
79 _ <- on ws GD.message $ do
77 e <- ask
80 e <- ask
78 d <- getData e
81 d <- getData e
79− liftIO $ case jsTypeOf d of
82+ liftJSM $ ghcjsPure (jsTypeOf d) >>= \case
80 String -> onMessage $ Right d
83 String -> onMessage $ Right d
81 _ -> do
84 _ -> do
82− ab <- unsafeFreeze $ pFromJSVal d
85+ ab <- mutableArrayBufferFromJSVal d >>= unsafeFreeze
83− onMessage $ Left $ toByteString 0 Nothing $ createFromArrayBuffer ab
86+ ghcjsPure (createFromArrayBuffer ab) >>= ghcjsPure . toByteString 0 Nothing >>= onMessage . Left
84 return $ JSWebSocket ws
87 return $ JSWebSocket ws
85
88
89+#ifdef ghcjs_HOST_OS
86−foreign import javascript safe "new DataView($3,$1,$2)" js_dataView :: Int -> Int -> JSVal -> JSVal
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
87
95
88−onBSMessage :: Either ByteString JSVal -> ByteString
96+onBSMessage :: Either ByteString JSVal -> JSM ByteString
89−onBSMessage = either id (encodeUtf8 . pFromJSVal)
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
82import Reflex.Class
82import Reflex.Class
83import Reflex.Dom.Builder.Class
83import Reflex.Dom.Builder.Class
84import Reflex.Dom.Class
84import Reflex.Dom.Class
85−import Reflex.Dom.Internal.Foreign ()
86import Reflex.Dynamic
85import Reflex.Dynamic
87import Reflex.PostBuild.Class
86import Reflex.PostBuild.Class
88
87
src/Reflex/Dom/Widget/Input.hs → reflex-dom-core/src/Reflex/Dom/Widget/Input.hsrenamed+145−8
@@ -1,3 +1,4 @@
1+{-# LANGUAGE CPP #-}
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE DataKinds #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
@@ -8,7 +9,9 @@
8{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE RecursiveDo #-}
10{-# LANGUAGE RecursiveDo #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12+#ifdef USE_TEMPLATE_HASKELL
11{-# LANGUAGE TemplateHaskell #-}
13{-# LANGUAGE TemplateHaskell #-}
14+#endif
12{-# LANGUAGE TypeFamilies #-}
15{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE UndecidableInstances #-}
16{-# LANGUAGE UndecidableInstances #-}
14module Reflex.Dom.Widget.Input (module Reflex.Dom.Widget.Input, def, (&), (.~)) where
17module Reflex.Dom.Widget.Input (module Reflex.Dom.Widget.Input, def, (&), (.~)) where
@@ -30,13 +33,13 @@ import Data.Maybe
30import Data.Semigroup
33import Data.Semigroup
31import Data.Text (Text)
34import Data.Text (Text)
32import qualified Data.Text as T
35import qualified Data.Text as T
33−import GHCJS.DOM.Element (castToElement)
34import qualified GHCJS.DOM.Element as Element
36import qualified GHCJS.DOM.Element as Element
35import GHCJS.DOM.EventM (on)
37import GHCJS.DOM.EventM (on)
36import qualified GHCJS.DOM.FileList as FileList
38import qualified GHCJS.DOM.FileList as FileList
37import GHCJS.DOM.HTMLInputElement (HTMLInputElement)
39import GHCJS.DOM.HTMLInputElement (HTMLInputElement)
38import GHCJS.DOM.HTMLTextAreaElement (HTMLTextAreaElement)
40import 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(..))
40import Reflex.Class
43import Reflex.Class
41import Reflex.Dom.Builder.Class
44import Reflex.Dom.Builder.Class
42import Reflex.Dom.Builder.Immediate
45import Reflex.Dom.Builder.Immediate
@@ -284,8 +287,8 @@ checkboxView dAttrs dValue = do
284 postBuild <- getPostBuild
287 postBuild <- getPostBuild
285 let filters :: DMap EventName (GhcjsEventFilter CheckboxViewEventResult)
288 let filters :: DMap EventName (GhcjsEventFilter CheckboxViewEventResult)
286 filters = DMap.singleton Click $ GhcjsEventFilter $ \(GhcjsDomEvent evt) -> do
289 filters = DMap.singleton Click $ GhcjsEventFilter $ \(GhcjsDomEvent evt) -> do
287− Just t <- Event.getTarget evt
290+ t <- Event.getTargetUnchecked evt
288− b <- Input.getChecked $ Input.castToHTMLInputElement t
291+ b <- Input.getChecked $ uncheckedCastTo Input.HTMLInputElement t
289 return $ (,) preventDefault $ return $ Just $ CheckboxViewEventResult b
292 return $ (,) preventDefault $ return $ Just $ CheckboxViewEventResult b
290 elementConfig :: ElementConfig CheckboxViewEventResult t m
293 elementConfig :: ElementConfig CheckboxViewEventResult t m
291 elementConfig = (def :: ElementConfig EventResult t m)
294 elementConfig = (def :: ElementConfig EventResult t m)
@@ -296,8 +299,9 @@ checkboxView dAttrs dValue = do
296 , _ghcjsEventSpec_handler = \(en, GhcjsDomEvent evt) -> case en of
299 , _ghcjsEventSpec_handler = \(en, GhcjsDomEvent evt) -> case en of
297 Click -> error "impossible"
300 Click -> error "impossible"
298 _ -> do
301 _ -> do
299− Just e <- withIsEvent en $ Event.getTarget evt
302+ e :: DOM.EventTarget <- withIsEvent en $ Event.getTargetUnchecked evt
303+ let element = uncheckedCastTo DOM.Element e
300− mr <- runReaderT (defaultDomEventHandler (castToElement e) en) evt
304+ mr <- runReaderT (defaultDomEventHandler element en) evt
301 return $ ffor mr $ \(EventResult r) -> CheckboxViewEventResult $ regularToCheckboxViewEventType en r
305 return $ ffor mr $ \(EventResult r) -> CheckboxViewEventResult $ regularToCheckboxViewEventType en r
302 }
306 }
303 }
307 }
@@ -321,7 +325,7 @@ instance Reflex t => Default (FileInputConfig t) where
321 def = FileInputConfig { _fileInputConfig_attributes = constDyn mempty
325 def = FileInputConfig { _fileInputConfig_attributes = constDyn mempty
322 }
326 }
323
327
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)
325 => FileInputConfig t -> m (FileInput (DomBuilderSpace m) t)
329 => FileInputConfig t -> m (FileInput (DomBuilderSpace m) t)
326fileInput config = do
330fileInput config = do
327 let insertType = Map.insert "type" "file"
331 let insertType = Map.insert "type" "file"
@@ -336,7 +340,7 @@ fileInput config = do
336 eRaw <- inputElement cfg
340 eRaw <- inputElement cfg
337 let e = _inputElement_raw eRaw
341 let e = _inputElement_raw eRaw
338 eChange <- wrapDomEvent e (`on` Element.change) $ do
342 eChange <- wrapDomEvent e (`on` Element.change) $ do
339− Just files <- Input.getFiles e
343+ files <- Input.getFilesUnchecked e
340 len <- FileList.getLength files
344 len <- FileList.getLength files
341 mapM (fmap (fromMaybe (error "fileInput: fileList.item returned null")) . FileList.item files) [0 .. len-1]
345 mapM (fmap (fromMaybe (error "fileInput: fileList.item returned null")) . FileList.item files) [0 .. len-1]
342 dValue <- holdDyn [] eChange
346 dValue <- holdDyn [] eChange
@@ -443,6 +447,7 @@ dropdown k0 options (DropdownConfig setK attrs) = do
443 dValue <- fmap (zipDynWith readKey ixKeys) $ holdDyn (Just k0) $ leftmost [eChange, fmap Just setK]
447 dValue <- fmap (zipDynWith readKey ixKeys) $ holdDyn (Just k0) $ leftmost [eChange, fmap Just setK]
444 return $ Dropdown dValue (attachPromptlyDynWith readKey ixKeys eChange)
448 return $ Dropdown dValue (attachPromptlyDynWith readKey ixKeys eChange)
445
449
450+#ifdef USE_TEMPLATE_HASKELL
446concat <$> mapM makeLenses
451concat <$> mapM makeLenses
447 [ ''TextAreaConfig
452 [ ''TextAreaConfig
448 , ''TextArea
453 , ''TextArea
@@ -457,6 +462,138 @@ concat <$> mapM makeLenses
457 , ''CheckboxConfig
462 , ''CheckboxConfig
458 , ''Checkbox
463 , ''Checkbox
459 ]
464 ]
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
460
597
461instance HasAttributes (TextAreaConfig t) where
598instance HasAttributes (TextAreaConfig t) where
462 type Attrs (TextAreaConfig t) = Dynamic t (Map Text Text)
599 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
16import Reflex.PostBuild.Class
16import Reflex.PostBuild.Class
17
17
18import Control.Monad.Fix
18import Control.Monad.Fix
19−import Control.Monad.IO.Class
20import Data.Fixed
19import Data.Fixed
21import Data.Map (Map)
20import Data.Map (Map)
22import qualified Data.Map as Map
21import qualified Data.Map as Map
@@ -24,9 +23,10 @@ import Data.Monoid
24import Data.Text (Text)
23import Data.Text (Text)
25import qualified Data.Text as T
24import qualified Data.Text as T
26import GHCJS.DOM.Element
25import GHCJS.DOM.Element
26+import GHCJS.DOM.Types (MonadJSM)
27
27
28-- |A list view for long lists. Creates a scrollable element and only renders child row elements near the current scroll position.
28-- |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)
30 => Dynamic t Int -- ^ The height of the visible region in pixels
30 => Dynamic t Int -- ^ The height of the visible region in pixels
31 -> Int -- ^ The height of each row in pixels
31 -> Int -- ^ The height of each row in pixels
32 -> Dynamic t Int -- ^ The total number of items
32 -> Dynamic t Int -- ^ The total number of items
@@ -58,8 +58,8 @@ virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTa
58 let window = zipDynWith (findWindow rowPx) heightPx scrollPosition
58 let window = zipDynWith (findWindow rowPx) heightPx scrollPosition
59 itemsInWindow = zipDynWith (\(_,(idx,num)) is -> Map.fromList $ map (\i -> let ix = indexToKey i in (ix, Map.lookup ix is)) [idx .. idx + num]) window items
59 itemsInWindow = zipDynWith (\(_,(idx,num)) is -> Map.fromList $ map (\i -> let ix = indexToKey i in (ix, Map.lookup ix is)) [idx .. idx + num]) window items
60 postBuild <- getPostBuild
60 postBuild <- getPostBuild
61− performEvent_ $ ffor (leftmost [setI, i0 <$ postBuild]) $ \i -> do
61+ performEvent_ $ ffor (leftmost [setI, i0 <$ postBuild]) $ \i ->
62− liftIO $ setScrollTop (_element_raw container) (i * rowPx)
62+ setScrollTop (_element_raw container) (i * rowPx)
63 let indexAndLength = fmap snd window
63 let indexAndLength = fmap snd window
64 return (indexAndLength, sel)
64 return (indexAndLength, sel)
65 where
65 where
@@ -80,7 +80,7 @@ virtualListWithSelection heightPx rowPx maxIndex i0 setI listTag listAttrs rowTa
80 preItems = min startingIndex numItems
80 preItems = min startingIndex numItems
81 in (topPx - preItems * sizeIncrement, (startingIndex - preItems, preItems + numItems * 2))
81 in (topPx - preItems * sizeIncrement, (startingIndex - preItems, preItems + numItems * 2))
82
82
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)
84 => Dynamic t Int -- ^ A 'Dynamic' of the visible region's height in pixels
84 => Dynamic t Int -- ^ A 'Dynamic' of the visible region's height in pixels
85 -> Int -- ^ The fixed height of each row in pixels
85 -> Int -- ^ The fixed height of each row in pixels
86 -> Dynamic t Int -- ^ A 'Dynamic' of the total number of items
86 -> 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
102 , fmap (const (i0 * rowPx)) pb
102 , fmap (const (i0 * rowPx)) pb
103 ]
103 ]
104 let window = zipDynWith (findWindow rowPx) heightPx scrollPosition
104 let window = zipDynWith (findWindow rowPx) heightPx scrollPosition
105− performEvent_ $ ffor (leftmost [setI, i0 <$ pb]) $ \i -> do
105+ performEvent_ $ ffor (leftmost [setI, i0 <$ pb]) $ \i ->
106− liftIO $ setScrollTop (_element_raw viewport) (i * rowPx)
106+ setScrollTop (_element_raw viewport) (i * rowPx)
107 return (uniqDyn window, result)
107 return (uniqDyn window, result)
108 where
108 where
109 toStyleAttr m = "style" =: Map.foldWithKey (\k v s -> k <> ":" <> v <> ";" <> s) "" m
109 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
124 in (startingIndex, numItems)
124 in (startingIndex, numItems)
125
125
126virtualListBuffered
126virtualListBuffered
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)
128 => Int
128 => Int
129 -> Dynamic t Int
129 -> Dynamic t Int
130 -> Int
130 -> 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 #-}
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE OverloadedStrings #-}
@@ -24,19 +25,20 @@ import Data.Text (Text)
24import qualified Data.Text as T
25import qualified Data.Text as T
25import GHCJS.DOM.Element hiding (reset)
26import GHCJS.DOM.Element hiding (reset)
26import GHCJS.DOM.EventM (on)
27import GHCJS.DOM.EventM (on)
28+import GHCJS.DOM.Types (liftJSM, MonadJSM)
27
29
28-- | A widget that wraps the given widget in a div and fires an event when resized.
30-- | A widget that wraps the given widget in a div and fires an event when resized.
29-- Adapted from github.com/marcj/css-element-queries
31-- 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)
31resizeDetector = resizeDetectorWithStyle ""
33resizeDetector = resizeDetectorWithStyle ""
32
34
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)
34 => Text -- ^ A css style string. Warning: It should not contain the "position" style attribute.
36 => Text -- ^ A css style string. Warning: It should not contain the "position" style attribute.
35 -> m a -- ^ The embedded widget
37 -> m a -- ^ The embedded widget
36 -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
38 -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
37resizeDetectorWithStyle styleString = resizeDetectorWithAttrs ("style" =: styleString)
39resizeDetectorWithStyle styleString = resizeDetectorWithAttrs ("style" =: styleString)
38
40
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)
40 => Map Text Text -- ^ A map of attributes. Warning: It should not modify the "position" style attribute.
42 => Map Text Text -- ^ A map of attributes. Warning: It should not modify the "position" style attribute.
41 -> m a -- ^ The embedded widget
43 -> m a -- ^ The embedded widget
42 -> m (Event t (), a) -- ^ An 'Event' that fires on resize, and the result of the embedded widget
44 -> 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
77 pb <- getPostBuild
79 pb <- getPostBuild
78 expandScroll <- wrapDomEvent (_element_raw expand) (`on` scroll) $ return ()
80 expandScroll <- wrapDomEvent (_element_raw expand) (`on` scroll) $ return ()
79 shrinkScroll <- wrapDomEvent (_element_raw shrink) (`on` scroll) $ return ()
81 shrinkScroll <- wrapDomEvent (_element_raw shrink) (`on` scroll) $ return ()
80− size0 <- performEvent $ fmap (const $ liftIO reset) pb
82+ size0 <- performEvent $ fmap (const $ liftJSM reset) pb
81− rec resize <- performEventAsync $ fmap (\d cb -> liftIO $ cb =<< resetIfChanged d) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]
83+ rec resize <- performEventAsync $ fmap (\d cb -> (liftIO . cb) =<< liftJSM (resetIfChanged d)) $ tag (current dimensions) $ leftmost [expandScroll, shrinkScroll]
82 dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]
84 dimensions <- holdDyn (Nothing, Nothing) $ leftmost [ size0, fmapMaybe id resize ]
83 return (fmapMaybe void resize, w')
85 return (fmapMaybe void resize, w')
src/Reflex/Dom/Xhr.hs → reflex-dom-core/src/Reflex/Dom/Xhr.hsrenamed+94−25
@@ -5,7 +5,9 @@
5{-# LANGUAGE GADTs #-}
5{-# LANGUAGE GADTs #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE OverloadedStrings #-}
8+#ifdef USE_TEMPLATE_HASKELL
8{-# LANGUAGE TemplateHaskell #-}
9{-# LANGUAGE TemplateHaskell #-}
10+#endif
9module Reflex.Dom.Xhr
11module Reflex.Dom.Xhr
10 ( XMLHttpRequest
12 ( XMLHttpRequest
11 , XhrRequest (..)
13 , XhrRequest (..)
@@ -61,11 +63,11 @@ where
61
63
62import Reflex.Class
64import Reflex.Class
63import Reflex.Dom.Class
65import Reflex.Dom.Class
66+import Reflex.PerformEvent.Class
67+import Reflex.TriggerEvent.Class
64import Reflex.Dom.Xhr.Exception
68import Reflex.Dom.Xhr.Exception
65import Reflex.Dom.Xhr.Foreign
69import Reflex.Dom.Xhr.Foreign
66import Reflex.Dom.Xhr.ResponseType
70import Reflex.Dom.Xhr.ResponseType
67−import Reflex.PerformEvent.Class
68−import Reflex.TriggerEvent.Class
69
71
70import Control.Concurrent
72import Control.Concurrent
71import Control.Exception (handle)
73import Control.Exception (handle)
@@ -93,6 +95,8 @@ import qualified Data.Text.Lazy.Builder as B
93import Data.Traversable
95import Data.Traversable
94import Data.Typeable
96import Data.Typeable
95
97
98+import Language.Javascript.JSaddle.Monad (JSM, askJSM, runJSM, MonadJSM, liftJSM)
99+
96data XhrRequest a
100data XhrRequest a
97 = XhrRequest { _xhrRequest_method :: Text
101 = XhrRequest { _xhrRequest_method :: Text
98 , _xhrRequest_url :: Text
102 , _xhrRequest_url :: Text
@@ -155,18 +159,19 @@ xhrRequest = XhrRequest
155-- the XHR connection), and will pass an exception ('XhrException') to the
159-- the XHR connection), and will pass an exception ('XhrException') to the
156-- continuation if the connection cannot be made (or is aborted).
160-- continuation if the connection cannot be made (or is aborted).
157newXMLHttpRequestWithError
161newXMLHttpRequestWithError
158− :: (HasWebView m, MonadIO m, IsXhrPayload a)
162+ :: (HasJSContext m, MonadJSM m, IsXhrPayload a)
159 => XhrRequest a
163 => XhrRequest a
160 -- ^ The request to make.
164 -- ^ The request to make.
161− -> (Either XhrException XhrResponse -> IO ())
165+ -> (Either XhrException XhrResponse -> JSM ())
162 -- ^ A continuation to be called once a response comes back, or in
166 -- ^ A continuation to be called once a response comes back, or in
163 -- case of error.
167 -- case of error.
164 -> m XMLHttpRequest
168 -> m XMLHttpRequest
165 -- ^ The XHR request, which could for example be aborted.
169 -- ^ The XHR request, which could for example be aborted.
166newXMLHttpRequestWithError req cb = do
170newXMLHttpRequestWithError req cb = do
167− wv <- askWebView
171+ wv <- askJSContext
168− xhr <- liftIO $ xmlHttpRequestNew $ unWebViewSingleton wv
172+ xhr <- xmlHttpRequestNew
173+ ctx <- askJSM
169− void $ liftIO $ forkIO $ handle (cb . Left) $ void $ do
174+ void $ liftIO $ forkIO $ handle ((`runJSM` ctx) . cb . Left) $ void . (`runJSM` ctx) $ do
170 let c = _xhrRequest_config req
175 let c = _xhrRequest_config req
171 rt = _xhrRequestConfig_responseType c
176 rt = _xhrRequestConfig_responseType c
172 creds = _xhrRequestConfig_withCredentials c
177 creds = _xhrRequestConfig_withCredentials c
@@ -181,20 +186,20 @@ newXMLHttpRequestWithError req cb = do
181 maybe (return ()) (xmlHttpRequestSetResponseType xhr . fromResponseType) rt
186 maybe (return ()) (xmlHttpRequestSetResponseType xhr . fromResponseType) rt
182 xmlHttpRequestSetWithCredentials xhr creds
187 xmlHttpRequestSetWithCredentials xhr creds
183 _ <- xmlHttpRequestOnreadystatechange xhr $ do
188 _ <- xmlHttpRequestOnreadystatechange xhr $ do
184− readyState <- liftIO $ xmlHttpRequestGetReadyState xhr
189+ readyState <- xmlHttpRequestGetReadyState xhr
185− status <- liftIO $ xmlHttpRequestGetStatus xhr
190+ status <- xmlHttpRequestGetStatus xhr
186− statusText <- liftIO $ xmlHttpRequestGetStatusText xhr
191+ statusText <- xmlHttpRequestGetStatusText xhr
187 when (readyState == 4) $ do
192 when (readyState == 4) $ do
188 t <- if rt == Just XhrResponseType_Text || isNothing rt
193 t <- if rt == Just XhrResponseType_Text || isNothing rt
189− then liftIO $ xmlHttpRequestGetResponseText xhr
194+ then xmlHttpRequestGetResponseText xhr
190 else return Nothing
195 else return Nothing
191− r <- liftIO $ xmlHttpRequestGetResponse xhr
196+ r <- xmlHttpRequestGetResponse xhr
192 h <- case _xhrRequestConfig_responseHeaders c of
197 h <- case _xhrRequestConfig_responseHeaders c of
193− AllHeaders -> liftIO $ parseAllHeadersString <$>
198+ AllHeaders -> parseAllHeadersString <$>
194 xmlHttpRequestGetAllResponseHeaders xhr
199 xmlHttpRequestGetAllResponseHeaders xhr
195− OnlyHeaders xs -> liftIO $ traverse (xmlHttpRequestGetResponseHeader xhr)
200+ OnlyHeaders xs -> traverse (xmlHttpRequestGetResponseHeader xhr)
196 (Map.fromSet id xs)
201 (Map.fromSet id xs)
197− _ <- liftIO $ cb $ Right
202+ _ <- liftJSM $ cb $ Right
198 XhrResponse { _xhrResponse_status = status
203 XhrResponse { _xhrResponse_status = status
199 , _xhrResponse_statusText = statusText
204 , _xhrResponse_statusText = statusText
200 , _xhrResponse_response = r
205 , _xhrResponse_response = r
@@ -211,7 +216,7 @@ parseAllHeadersString s = Map.fromList $ fmap (stripBoth . T.span (/=':')) $
211 L.dropWhileEnd T.null $ T.splitOn (T.pack "\r\n") s
216 L.dropWhileEnd T.null $ T.splitOn (T.pack "\r\n") s
212 where stripBoth (txt1, txt2) = (T.strip txt1, T.strip $ T.drop 1 txt2)
217 where stripBoth (txt1, txt2) = (T.strip txt1, T.strip $ T.drop 1 txt2)
213
218
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
215newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb
220newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb
216
221
217-- | Given Event of requests, issue them when the Event fires.
222-- | Given Event of requests, issue them when the Event fires.
@@ -220,20 +225,20 @@ newXMLHttpRequest req cb = newXMLHttpRequestWithError req $ mapM_ cb
220-- The request is processed asynchronously, therefore handling does
225-- The request is processed asynchronously, therefore handling does
221-- not block or cause a delay while creating the connection.
226-- not block or cause a delay while creating the connection.
222performRequestAsyncWithError
227performRequestAsyncWithError
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)
224 => Event t (XhrRequest a)
229 => Event t (XhrRequest a)
225 -> m (Event t (Either XhrException XhrResponse))
230 -> m (Event t (Either XhrException XhrResponse))
226performRequestAsyncWithError = performRequestAsync' newXMLHttpRequestWithError . fmap return
231performRequestAsyncWithError = performRequestAsync' newXMLHttpRequestWithError . fmap return
227
232
228-- | Given Event of request, issue them when the Event fires. Returns Event of corresponding response.
233-- | 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)
230performRequestAsync = performRequestAsync' newXMLHttpRequest . fmap return
235performRequestAsync = performRequestAsync' newXMLHttpRequest . fmap return
231
236
232-- | Given Event with an action that creates a request, build and issue the request when the Event fires. Returns Event of corresponding response.
237-- | 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)
234performMkRequestAsync = performRequestAsync' newXMLHttpRequest
239performMkRequestAsync = performRequestAsync' newXMLHttpRequest
235
240
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)
237performRequestAsync' newXhr req = performEventAsync $ ffor req $ \hr cb -> do
242performRequestAsync' newXhr req = performEventAsync $ ffor req $ \hr cb -> do
238 r <- hr
243 r <- hr
239 _ <- newXhr r $ liftIO . cb
244 _ <- newXhr r $ liftIO . cb
@@ -249,19 +254,19 @@ performRequestAsync' newXhr req = performEventAsync $ ffor req $ \hr cb -> do
249-- Order of request execution and completion is not guaranteed, but
254-- Order of request execution and completion is not guaranteed, but
250-- order of creation and the collection result is preserved.
255-- order of creation and the collection result is preserved.
251performRequestsAsyncWithError
256performRequestsAsyncWithError
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)
253 => Event t (f (XhrRequest a)) -> m (Event t (f (Either XhrException XhrResponse)))
258 => Event t (f (XhrRequest a)) -> m (Event t (f (Either XhrException XhrResponse)))
254performRequestsAsyncWithError = performRequestsAsync' newXMLHttpRequestWithError . fmap return
259performRequestsAsyncWithError = performRequestsAsync' newXMLHttpRequestWithError . fmap return
255
260
256-- | 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-- | 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))
258performRequestsAsync = performRequestsAsync' newXMLHttpRequest . fmap return
263performRequestsAsync = performRequestsAsync' newXMLHttpRequest . fmap return
259
264
260-- | 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.
265-- | 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))
262performMkRequestsAsync = performRequestsAsync' newXMLHttpRequest
267performMkRequestsAsync = performRequestsAsync' newXMLHttpRequest
263
268
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))
265performRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
270performRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
266 rs <- hrs
271 rs <- hrs
267 resps <- forM rs $ \r -> do
272 resps <- forM rs $ \r -> do
@@ -272,7 +277,7 @@ performRequestsAsync' newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
272 return ()
277 return ()
273
278
274-- | Simplified interface to "GET" URLs and return decoded results.
279-- | 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))
276getAndDecode url = do
281getAndDecode url = do
277 r <- performRequestAsync $ fmap (\x -> XhrRequest "GET" x def) url
282 r <- performRequestAsync $ fmap (\x -> XhrRequest "GET" x def) url
278 return $ fmap decodeXhrResponse r
283 return $ fmap decodeXhrResponse r
@@ -298,8 +303,72 @@ decodeText = decode . BL.fromStrict . encodeUtf8
298decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
303decodeXhrResponse :: FromJSON a => XhrResponse -> Maybe a
299decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText
304decodeXhrResponse = join . fmap decodeText . _xhrResponse_responseText
300
305
306+#ifdef USE_TEMPLATE_HASKELL
301concat <$> mapM makeLenses
307concat <$> mapM makeLenses
302 [ ''XhrRequest
308 [ ''XhrRequest
303 , ''XhrRequestConfig
309 , ''XhrRequestConfig
304 , ''XhrResponse
310 , ''XhrResponse
305 ]
311 ]
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 (
10) where
10) where
11
11
12import Control.Exception (catch, throwIO)
12import Control.Exception (catch, throwIO)
13+import Control.Monad (join)
14+import Control.Monad.IO.Class (MonadIO(..))
13import Data.Maybe (fromMaybe)
15import Data.Maybe (fromMaybe)
14import Data.Text (Text)
16import Data.Text (Text)
17+import Data.ByteString (ByteString)
18+import GHCJS.Marshal (fromJSValUnchecked)
15import GHCJS.DOM
19import GHCJS.DOM
16import GHCJS.DOM.Enums
20import GHCJS.DOM.Enums
17import GHCJS.DOM.EventM (EventM, on)
21import GHCJS.DOM.EventM (EventM, on)
18import GHCJS.DOM.EventTarget (dispatchEvent)
22import GHCJS.DOM.EventTarget (dispatchEvent)
19import GHCJS.DOM.Types hiding (Text)
23import GHCJS.DOM.Types hiding (Text)
20import GHCJS.DOM.XMLHttpRequest
24import GHCJS.DOM.XMLHttpRequest
21−import GHCJS.Types
25+-- import GHCJS.Types
22import Prelude hiding (error)
26import Prelude hiding (error)
23−import Reflex.Dom.Internal.Foreign
24import Reflex.Dom.Xhr.Exception
27import Reflex.Dom.Xhr.Exception
25import Reflex.Dom.Xhr.ResponseType
28import 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)
26
35
27−prepareWebView :: WebView -> IO ()
28−prepareWebView _ = return ()
29−
30−xmlHttpRequestNew :: a -> IO XMLHttpRequest
36+xmlHttpRequestNew :: MonadJSM m => m XMLHttpRequest
31−xmlHttpRequestNew _ = newXMLHttpRequest
37+xmlHttpRequestNew = newXMLHttpRequest
32
38
33xmlHttpRequestOpen ::
39xmlHttpRequestOpen ::
34− (ToJSString method, ToJSString url, ToJSString user, ToJSString password) =>
40+ (ToJSString method, ToJSString url, ToJSString user, ToJSString password, MonadJSM m) =>
35− XMLHttpRequest -> method -> url -> Bool -> user -> password -> IO ()
41+ XMLHttpRequest -> method -> url -> Bool -> user -> password -> m ()
36xmlHttpRequestOpen = open
42xmlHttpRequestOpen = open
37
43
38convertException :: XHRError -> XhrException
44convertException :: XHRError -> XhrException
@@ -41,7 +47,7 @@ convertException e = case e of
41 XHRAborted -> XhrException_Aborted
47 XHRAborted -> XhrException_Aborted
42
48
43class IsXhrPayload a where
49class IsXhrPayload a where
44− sendXhrPayload :: XMLHttpRequest -> a -> IO ()
50+ sendXhrPayload :: MonadJSM m => XMLHttpRequest -> a -> m ()
45
51
46instance IsXhrPayload () where
52instance IsXhrPayload () where
47 sendXhrPayload xhr _ = send xhr
53 sendXhrPayload xhr _ = send xhr
@@ -64,79 +70,79 @@ instance IsXhrPayload Blob where
64newtype XhrPayload = XhrPayload { unXhrPayload :: JSVal }
70newtype XhrPayload = XhrPayload { unXhrPayload :: JSVal }
65
71
66-- This used to be a non blocking call, but now it uses an interruptible ffi
72-- This used to be a non blocking call, but now it uses an interruptible ffi
67−xmlHttpRequestSend :: IsXhrPayload payload => XMLHttpRequest -> payload -> IO ()
73+xmlHttpRequestSend :: IsXhrPayload payload => XMLHttpRequest -> payload -> JSM ()
68−xmlHttpRequestSend self p = sendXhrPayload self p `catch` (throwIO . convertException)
74+xmlHttpRequestSend self p = sendXhrPayload self p `JS.catch` (liftIO . throwIO . convertException)
69
75
70
76
71−xmlHttpRequestSetRequestHeader :: (ToJSString header, ToJSString value)
77+xmlHttpRequestSetRequestHeader :: (ToJSString header, ToJSString value, MonadJSM m)
72− => XMLHttpRequest -> header -> value -> IO ()
78+ => XMLHttpRequest -> header -> value -> m ()
73xmlHttpRequestSetRequestHeader = setRequestHeader
79xmlHttpRequestSetRequestHeader = setRequestHeader
74
80
75−xmlHttpRequestAbort :: XMLHttpRequest -> IO ()
81+xmlHttpRequestAbort :: MonadJSM m => XMLHttpRequest -> m ()
76xmlHttpRequestAbort = abort
82xmlHttpRequestAbort = abort
77
83
78−xmlHttpRequestGetAllResponseHeaders :: XMLHttpRequest -> IO Text
84+xmlHttpRequestGetAllResponseHeaders :: MonadJSM m => XMLHttpRequest -> m Text
79xmlHttpRequestGetAllResponseHeaders self = fromMaybe "" <$> getAllResponseHeaders self
85xmlHttpRequestGetAllResponseHeaders self = fromMaybe "" <$> getAllResponseHeaders self
80
86
81−xmlHttpRequestGetResponseHeader :: (ToJSString header)
87+xmlHttpRequestGetResponseHeader :: (ToJSString header, MonadJSM m)
82− => XMLHttpRequest -> header -> IO Text
88+ => XMLHttpRequest -> header -> m Text
83xmlHttpRequestGetResponseHeader self header = fromMaybe "" <$> getResponseHeader self header
89xmlHttpRequestGetResponseHeader self header = fromMaybe "" <$> getResponseHeader self header
84
90
85−xmlHttpRequestOverrideMimeType :: ToJSString override => XMLHttpRequest -> override -> IO ()
91+xmlHttpRequestOverrideMimeType :: (ToJSString override, MonadJSM m) => XMLHttpRequest -> override -> m ()
86xmlHttpRequestOverrideMimeType = overrideMimeType
92xmlHttpRequestOverrideMimeType = overrideMimeType
87
93
88−xmlHttpRequestDispatchEvent :: IsEvent evt => XMLHttpRequest -> Maybe evt -> IO Bool
94+xmlHttpRequestDispatchEvent :: (IsEvent evt, MonadJSM m) => XMLHttpRequest -> Maybe evt -> m Bool
89xmlHttpRequestDispatchEvent = dispatchEvent
95xmlHttpRequestDispatchEvent = dispatchEvent
90
96
91−xmlHttpRequestOnabort :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())
97+xmlHttpRequestOnabort :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> JSM (JSM ())
92xmlHttpRequestOnabort = (`on` abortEvent)
98xmlHttpRequestOnabort = (`on` abortEvent)
93
99
94−xmlHttpRequestOnerror :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())
100+xmlHttpRequestOnerror :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> JSM (JSM ())
95xmlHttpRequestOnerror = (`on` error)
101xmlHttpRequestOnerror = (`on` error)
96
102
97−xmlHttpRequestOnload :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())
103+xmlHttpRequestOnload :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> JSM (JSM ())
98xmlHttpRequestOnload = (`on` load)
104xmlHttpRequestOnload = (`on` load)
99
105
100−xmlHttpRequestOnloadend :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())
106+xmlHttpRequestOnloadend :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> JSM (JSM ())
101xmlHttpRequestOnloadend = (`on` loadEnd)
107xmlHttpRequestOnloadend = (`on` loadEnd)
102
108
103−xmlHttpRequestOnloadstart :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())
109+xmlHttpRequestOnloadstart :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> JSM (JSM ())
104xmlHttpRequestOnloadstart = (`on` loadStart)
110xmlHttpRequestOnloadstart = (`on` loadStart)
105
111
106−xmlHttpRequestOnprogress :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> IO (IO ())
112+xmlHttpRequestOnprogress :: XMLHttpRequest -> EventM XMLHttpRequest XMLHttpRequestProgressEvent () -> JSM (JSM ())
107xmlHttpRequestOnprogress = (`on` progress)
113xmlHttpRequestOnprogress = (`on` progress)
108
114
109−xmlHttpRequestOntimeout :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> IO (IO ())
115+xmlHttpRequestOntimeout :: XMLHttpRequest -> EventM XMLHttpRequest ProgressEvent () -> JSM (JSM ())
110xmlHttpRequestOntimeout = (`on` timeout)
116xmlHttpRequestOntimeout = (`on` timeout)
111
117
112−xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> EventM XMLHttpRequest Event () -> IO (IO ())
118+xmlHttpRequestOnreadystatechange :: XMLHttpRequest -> EventM XMLHttpRequest Event () -> JSM (JSM ())
113xmlHttpRequestOnreadystatechange = (`on` readyStateChange)
119xmlHttpRequestOnreadystatechange = (`on` readyStateChange)
114
120
115−xmlHttpRequestSetTimeout :: XMLHttpRequest -> Word -> IO ()
121+xmlHttpRequestSetTimeout :: MonadJSM m => XMLHttpRequest -> Word -> m ()
116xmlHttpRequestSetTimeout = setTimeout
122xmlHttpRequestSetTimeout = setTimeout
117
123
118−xmlHttpRequestGetTimeout :: XMLHttpRequest -> IO Word
124+xmlHttpRequestGetTimeout :: MonadJSM m => XMLHttpRequest -> m Word
119xmlHttpRequestGetTimeout = getTimeout
125xmlHttpRequestGetTimeout = getTimeout
120
126
121−xmlHttpRequestGetReadyState :: XMLHttpRequest -> IO Word
127+xmlHttpRequestGetReadyState :: MonadJSM m => XMLHttpRequest -> m Word
122xmlHttpRequestGetReadyState = getReadyState
128xmlHttpRequestGetReadyState = getReadyState
123
129
124−xmlHttpRequestSetWithCredentials :: XMLHttpRequest -> Bool -> IO ()
130+xmlHttpRequestSetWithCredentials :: MonadJSM m => XMLHttpRequest -> Bool -> m ()
125xmlHttpRequestSetWithCredentials = setWithCredentials
131xmlHttpRequestSetWithCredentials = setWithCredentials
126
132
127−xmlHttpRequestGetWithCredentials :: XMLHttpRequest -> IO Bool
133+xmlHttpRequestGetWithCredentials :: MonadJSM m => XMLHttpRequest -> m Bool
128xmlHttpRequestGetWithCredentials = getWithCredentials
134xmlHttpRequestGetWithCredentials = getWithCredentials
129
135
130−xmlHttpRequestGetUpload :: XMLHttpRequest -> IO (Maybe XMLHttpRequestUpload)
136+xmlHttpRequestGetUpload :: MonadJSM m => XMLHttpRequest -> m (Maybe XMLHttpRequestUpload)
131xmlHttpRequestGetUpload = getUpload
137xmlHttpRequestGetUpload = getUpload
132
138
133−xmlHttpRequestGetResponseText :: FromJSString result => XMLHttpRequest -> IO (Maybe result)
139+xmlHttpRequestGetResponseText :: (FromJSString result, MonadJSM m) => XMLHttpRequest -> m (Maybe result)
134xmlHttpRequestGetResponseText = getResponseText
140xmlHttpRequestGetResponseText = getResponseText
135
141
136−xmlHttpRequestGetResponseXML :: XMLHttpRequest -> IO (Maybe Document)
142+xmlHttpRequestGetResponseXML :: MonadJSM m => XMLHttpRequest -> m (Maybe Document)
137xmlHttpRequestGetResponseXML = getResponseXML
143xmlHttpRequestGetResponseXML = getResponseXML
138
144
139−xmlHttpRequestSetResponseType :: XMLHttpRequest -> XMLHttpRequestResponseType -> IO ()
145+xmlHttpRequestSetResponseType :: MonadJSM m => XMLHttpRequest -> XMLHttpRequestResponseType -> m ()
140xmlHttpRequestSetResponseType = setResponseType
146xmlHttpRequestSetResponseType = setResponseType
141
147
142fromResponseType :: XhrResponseType -> XMLHttpRequestResponseType
148fromResponseType :: XhrResponseType -> XMLHttpRequestResponseType
@@ -152,28 +158,31 @@ toResponseType XMLHttpRequestResponseTypeBlob = Just XhrResponseType_Blob
152toResponseType XMLHttpRequestResponseTypeText = Just XhrResponseType_Text
158toResponseType XMLHttpRequestResponseTypeText = Just XhrResponseType_Text
153toResponseType _ = Nothing
159toResponseType _ = Nothing
154
160
155−xmlHttpRequestGetResponseType :: XMLHttpRequest -> IO (Maybe XhrResponseType)
161+xmlHttpRequestGetResponseType :: MonadJSM m => XMLHttpRequest -> m (Maybe XhrResponseType)
156xmlHttpRequestGetResponseType = fmap toResponseType . getResponseType
162xmlHttpRequestGetResponseType = fmap toResponseType . getResponseType
157
163
158−xmlHttpRequestGetStatus :: XMLHttpRequest -> IO Word
164+xmlHttpRequestGetStatus :: MonadJSM m => XMLHttpRequest -> m Word
159xmlHttpRequestGetStatus = getStatus
165xmlHttpRequestGetStatus = getStatus
160
166
161−xmlHttpRequestGetStatusText :: FromJSString result => XMLHttpRequest -> IO result
167+xmlHttpRequestGetStatusText :: MonadJSM m => FromJSString result => XMLHttpRequest -> m result
162xmlHttpRequestGetStatusText = getStatusText
168xmlHttpRequestGetStatusText = getStatusText
163
169
164−xmlHttpRequestGetResponseURL :: FromJSString result => XMLHttpRequest -> IO result
170+xmlHttpRequestGetResponseURL :: (FromJSString result, MonadJSM m) => XMLHttpRequest -> m result
165xmlHttpRequestGetResponseURL = getResponseURL
171xmlHttpRequestGetResponseURL = getResponseURL
166
172
167−xmlHttpRequestGetResponse :: XMLHttpRequest -> IO (Maybe XhrResponseBody)
173+xmlHttpRequestGetResponse :: MonadJSM m => XMLHttpRequest -> m (Maybe XhrResponseBody)
168xmlHttpRequestGetResponse xhr = do
174xmlHttpRequestGetResponse xhr = do
169 mr <- getResponse xhr
175 mr <- getResponse xhr
170 rt <- xmlHttpRequestGetResponseType xhr
176 rt <- xmlHttpRequestGetResponseType xhr
171 case rt of
177 case rt of
172− Just XhrResponseType_Blob -> return $ XhrResponseBody_Blob . castToBlob <$> mr
178+ Just XhrResponseType_Blob -> fmap XhrResponseBody_Blob . join <$> mapM (castTo Blob) mr
173 Just XhrResponseType_Text -> Just . XhrResponseBody_Text <$> xmlHttpRequestGetStatusText xhr
179 Just XhrResponseType_Text -> Just . XhrResponseBody_Text <$> xmlHttpRequestGetStatusText xhr
174 Just XhrResponseType_Default -> Just . XhrResponseBody_Text <$> xmlHttpRequestGetStatusText xhr
180 Just XhrResponseType_Default -> Just . XhrResponseBody_Text <$> xmlHttpRequestGetStatusText xhr
175 Just XhrResponseType_ArrayBuffer -> case fmap unGObject mr of
181 Just XhrResponseType_ArrayBuffer -> case fmap unGObject mr of
176 Nothing -> return Nothing
182 Nothing -> return Nothing
177− Just ptr -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer ptr ptr
183+ Just ptr -> Just . XhrResponseBody_ArrayBuffer <$> bsFromArrayBuffer (pFromJSVal ptr)
178 _ -> return Nothing
184 _ -> return Nothing
179
185
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
17 | XhrResponseBody_Text Text
17 | XhrResponseBody_Text Text
18 | XhrResponseBody_Blob Blob
18 | XhrResponseBody_Blob Blob
19 | XhrResponseBody_ArrayBuffer ByteString
19 | XhrResponseBody_ArrayBuffer ByteString
20− deriving (Eq)
20+-- deriving (Eq)
21
21
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 @@
1+Copyright (c) 2015, Obsidian Systems LLC
2+All rights reserved.
3+
4+Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
5+
6+1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
7+
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.
9+
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
2+
3+import Reflex.Dom.Core as X hiding
4+ (mainWidget, mainWidgetWithHead, mainWidgetWithCss,
5+ mainWidgetWithHead', mainWidgetInElementById, runApp')
6+import Reflex.Dom.Internal as X
7+
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
7+
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