@@ -1,3 +1,4 @@
1+{-# LANGUAGE BangPatterns #-}
12{-# LANGUAGE CPP #-}
23{-# LANGUAGE ConstraintKinds #-}
34{-# LANGUAGE DataKinds #-}
@@ -31,7 +32,6 @@ import Reflex.TriggerEvent.Base hiding (askEvents)
3132import Reflex.TriggerEvent.Class
3233
3334import Control.Concurrent.Chan
34−import Control.Exception (evaluate)
3535import Control.Lens hiding (element, ix)
3636import Control.Monad.Exception
3737import Control.Monad.Primitive
@@ -55,6 +55,7 @@ import Data.Monoid
5555import Data.Some (Some)
5656import qualified Data.Some as Some
5757import Data.Text (Text)
58+import qualified Data.Text as T
5859import GHCJS.DOM.Document (Document, createDocumentFragmentUnchecked, createElementUnchecked, createElementNSUnchecked, createTextNodeUnchecked)
5960import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)
6061import qualified GHCJS.DOM.Element as Element
@@ -81,8 +82,6 @@ import GHCJS.DOM.UIEvent
8182import qualified GHCJS.DOM.Window as Window
8283import Language.Javascript.JSaddle (call, eval)
8384
84−import Debug.Trace hiding (traceEvent)
85−
8685data TriggerRef t a = TriggerRef { unTriggerRef :: IORef (Maybe (EventTrigger t a)) }
8786
8887data ImmediateDomBuilderEnv t
@@ -146,31 +145,36 @@ textNodeInternal t = do
146145{-# INLINABLE deleteBetweenInclusive #-}
147146deleteBetweenInclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()
148147deleteBetweenInclusive s e = liftJSM $ do
149− f <- eval ("(function(s,e){ \
150− p = e.parentNode; \
151− if(p !== null) { \
152− for(;;){ \
153− x = e.previousSibling; \
154− p.removeChild(x); \
155− if(s===x) break; \
156− } \
157− p.removeChild(e); \
158− }})" :: Text)
148+ f <- eval $ T.unlines
149+ [ "(function(s,e){"
150+ , " p = e.parentNode;"
151+ , " if(p !== null) {"
152+ , " for(;;){"
153+ , " x = e.previousSibling;"
154+ , " p.removeChild(x);"
155+ , " if(s===x) break;"
156+ , " }"
157+ , " p.removeChild(e);"
158+ , " }"
159+ , "})"
160+ ]
159161 void $ call f f (s, e)
160162
161163-- | s and e must both be children of the same node and s must precede e;
162164-- all nodes between s and e will be removed, but s and e will not be removed
163165deleteBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()
164166deleteBetweenExclusive s e = liftJSM $ do
165− f <- eval ("(function(s,e){ \
166− p = e.parentNode; \
167− if(p !== null) { \
168− for(;;){ \
169− x = e.previousSibling; \
170− if(s===x) break; \
171− p.removeChild(x); \
172− } \
173− }})" :: Text)
167+ f <- eval $ T.unlines
168+ [ "(function(s,e){"
169+ , " p = e.parentNode;"
170+ , " if(p !== null) {"
171+ , " for(;;){"
172+ , " x = e.previousSibling;"
173+ , " if(s===x) break;"
174+ , " p.removeChild(x);"
175+ , " }"
176+ , " }})"
177+ ]
174178 void $ call f f (s, e)
175179
176180-- | s and e must both be children of the same node and s must precede e;
@@ -178,27 +182,31 @@ deleteBetweenExclusive s e = liftJSM $ do
178182{-# INLINABLE deleteUpTo #-}
179183deleteUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()
180184deleteUpTo s e = liftJSM $ do
181− f <- eval ("(function(s,e){ \
182− p = e.parentNode; \
183− if(p !== null) { \
184− for(;;) { \
185− x = e.previousSibling; \
186− p.removeChild(x); \
187− if(s===x) break; \
188− } \
189− }})" :: Text)
185+ f <- eval $ T.unlines
186+ [ "(function(s,e){"
187+ , " p = e.parentNode;"
188+ , " if(p !== null) {"
189+ , " for(;;) {"
190+ , " x = e.previousSibling;"
191+ , " p.removeChild(x);"
192+ , " if(s===x) break;"
193+ , " }"
194+ , " }})"
195+ ]
190196 void $ call f f (s, e)
191197
192198-- | s and all nodes between s and e will be removed, but e will not be removed
193199{-# INLINABLE deleteUpToGivenParent #-}
194200deleteUpToGivenParent :: (MonadJSM m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m ()
195201deleteUpToGivenParent currentParent s e = liftJSM $ do
196− f <- eval ("(function(p,s,e){ \
197− for(;;){ \
198− x = e.previousSibling; \
199− p.removeChild(x); \
200− if(s===x) break; \
201− }})" :: Text)
202+ f <- eval $ T.unlines
203+ [ "(function(p,s,e){"
204+ , " for(;;){"
205+ , " x = e.previousSibling;"
206+ , " p.removeChild(x);"
207+ , " if(s===x) break;"
208+ , " }})"
209+ ]
202210 void $ call f f (currentParent, s, e)
203211
204212type 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)
@@ -225,9 +233,8 @@ wrap e cfg = do
225233 liftIO $ forM_ mv $ \v -> writeChan events [TriggerRef triggerRef :=> TriggerInvocation v (return ())]
226234 return $ en :=> EventFilterTriggerRef triggerRef
227235 es <- do
228− let h :: forall en. (EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en))
229− h = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up
230− _ <- liftIO $ evaluate h
236+ let h :: GhcjsEventHandler er
237+ !h = _ghcjsEventSpec_handler $ _rawElementConfig_eventSpec cfg -- Note: this needs to be done strictly and outside of the newFanEventWithTrigger, so that the newFanEventWithTrigger doesn't retain the entire cfg, which can cause a cyclic dependency that the GC won't be able to clean up
231238 ctx <- askJSM
232239 newFanEventWithTrigger $ \(WrapArg en) t ->
233240 case DMap.lookup en eventTriggerRefs of
@@ -237,7 +244,7 @@ wrap e cfg = do
237244 writeIORef r Nothing
238245 Nothing -> (`runJSM` ctx) <$> (`runJSM` ctx) (elementOnEventName en e $ do
239246 evt <- DOM.event
240− mv <- lift $ h (en, GhcjsDomEvent evt)
247+ mv <- lift $ unGhcjsEventHandler h (en, GhcjsDomEvent evt)
241248 case mv of
242249 Nothing -> return ()
243250 Just v -> liftIO $ do
@@ -286,7 +293,7 @@ instance DomSpace GhcjsDomSpace where
286293 { _ghcjsEventSpec_filters =
287294 let f' = Just . GhcjsEventFilter . \case
288295 Nothing -> \evt -> do
289− mEventResult <- _ghcjsEventSpec_handler es (en, evt)
296+ mEventResult <- unGhcjsEventHandler (_ghcjsEventSpec_handler es) (en, evt)
290297 return (f mEventResult, return mEventResult)
291298 Just (GhcjsEventFilter oldFilter) -> \evt -> do
292299 (oldFlags, oldContinuation) <- oldFilter evt
@@ -304,9 +311,11 @@ data Maybe1 f a = Nothing1 | Just1 (f a)
304311
305312data GhcjsEventSpec er = GhcjsEventSpec
306313 { _ghcjsEventSpec_filters :: DMap EventName (GhcjsEventFilter er)
307− , _ghcjsEventSpec_handler :: forall en. (EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en))
314+ , _ghcjsEventSpec_handler :: GhcjsEventHandler er
308315 }
309316
317+newtype GhcjsEventHandler er = GhcjsEventHandler { unGhcjsEventHandler :: forall en. (EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)) }
318+
310319#ifndef USE_TEMPLATE_HASKELL
311320phantom2 :: (Functor f, Contravariant f) => f a -> f b
312321phantom2 = phantom
@@ -316,14 +325,14 @@ ghcjsEventSpec_filters :: forall er . Lens' (GhcjsEventSpec er) (DMap EventName
316325ghcjsEventSpec_filters f (GhcjsEventSpec a b) = (\a' -> GhcjsEventSpec a' b) <$> f a
317326{-# INLINE ghcjsEventSpec_filters #-}
318327ghcjsEventSpec_handler :: forall er en . Getter (GhcjsEventSpec er) ((EventName en, GhcjsDomEvent en) -> JSM (Maybe (er en)))
319−ghcjsEventSpec_handler f (GhcjsEventSpec _ b) = phantom2 (f b)
328+ghcjsEventSpec_handler f (GhcjsEventSpec _ (GhcjsEventHandler b)) = phantom2 (f b)
320329{-# INLINE ghcjsEventSpec_handler #-}
321330#endif
322331
323332instance er ~ EventResult => Default (GhcjsEventSpec er) where
324333 def = GhcjsEventSpec
325334 { _ghcjsEventSpec_filters = mempty
326− , _ghcjsEventSpec_handler = \(en, GhcjsDomEvent evt) -> do
335+ , _ghcjsEventSpec_handler = GhcjsEventHandler $ \(en, GhcjsDomEvent evt) -> do
327336 t :: DOM.EventTarget <- withIsEvent en $ Event.getTargetUnchecked evt --TODO: Rework this; defaultDomEventHandler shouldn't need to take this as an argument
328337 let e = uncheckedCastTo DOM.Element t
329338 runReaderT (defaultDomEventHandler e en) evt