@@ -54,7 +54,7 @@ import Data.Monoid
5454import Data.Some (Some)
5555import qualified Data.Some as Some
5656import Data.Text (Text)
57−import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode)
57+import GHCJS.DOM.Document (Document, createDocumentFragmentUnchecked, createElementUnchecked, createElementNSUnchecked, createTextNodeUnchecked)
5858import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)
5959import qualified GHCJS.DOM.Element as Element
6060import qualified GHCJS.DOM.Event as Event
@@ -65,9 +65,9 @@ import qualified GHCJS.DOM.HTMLInputElement as Input
6565import qualified GHCJS.DOM.HTMLSelectElement as Select
6666import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea
6767import GHCJS.DOM.MouseEvent
68−import GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling,
69− removeChild, setNodeValue, toNode)
70−import qualified GHCJS.DOM.Node as DOM (insertBefore)
68+import GHCJS.DOM.Node (appendChild_, getOwnerDocumentUnchecked, getParentNodeUnchecked, getPreviousSiblingUnchecked,
69+ removeChild_, setNodeValue, toNode)
70+import qualified GHCJS.DOM.Node as DOM (insertBefore_)
7171import GHCJS.DOM.Types
7272 (liftJSM, askJSM, runJSM, JSM, MonadJSM(..),
7373 FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node,
@@ -75,6 +75,7 @@ import GHCJS.DOM.Types
7575import qualified GHCJS.DOM.Types as DOM
7676import GHCJS.DOM.UIEvent
7777import qualified GHCJS.DOM.Window as Window
78+import Language.Javascript.JSaddle (call, eval)
7879
7980import Debug.Trace hiding (traceEvent)
8081
@@ -125,64 +126,109 @@ askEvents = ImmediateDomBuilderT $ asks _immediateDomBuilderEnv_events
125126append :: (IsNode n, MonadJSM m) => n -> ImmediateDomBuilderT t m ()
126127append n = do
127128 p <- askParent
128− _ <- liftJSM $ appendChild p $ Just n
129+ liftJSM $ appendChild_ p $ Just n
129130 return ()
130131
131132{-# INLINABLE textNodeInternal #-}
132133textNodeInternal :: (MonadJSM m, ToDOMString contents) => contents -> ImmediateDomBuilderT t m DOM.Text
133134textNodeInternal t = do
134135 doc <- askDocument
135− Just n <- liftJSM $ createTextNode doc t
136+ n <- liftJSM $ createTextNodeUnchecked doc t
136137 append n
137138 return n
138139
139140-- | s and e must both be children of the same node and s must precede e
140141{-# INLINABLE deleteBetweenInclusive #-}
141142deleteBetweenInclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()
142−deleteBetweenInclusive s e = do
143− 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
144− case mCurrentParent of
145− Nothing -> return () --TODO: Is this the right behavior?
146− Just currentParent -> do
147− deleteUpToGivenParent currentParent s e
148− _ <- removeChild currentParent $ Just e
149− return ()
143+deleteBetweenInclusive s e = liftJSM $ do
144+ f <- eval ("(function(s,e){ \
145+ p = e.parentNode; \
146+ if(p !== null) { \
147+ for(;;){ \
148+ x = e.previousSibling; \
149+ p.removeChild(x); \
150+ if(s===x) break; \
151+ } \
152+ p.removeChild(e); \
153+ }})" :: Text)
154+ void $ call f f (s, e)
155+
156+-- do
157+-- mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
158+-- case mCurrentParent of
159+-- Nothing -> return () --TODO: Is this the right behavior?
160+-- Just currentParent -> do
161+-- deleteUpToGivenParent currentParent s e
162+-- removeChild_ currentParent $ Just e
163+-- return ()
150164
151165-- | s and e must both be children of the same node and s must precede e
152166deleteBetweenExclusive :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()
153−deleteBetweenExclusive s e = do
154− 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
155− case mCurrentParent of
156− Nothing -> return () --TODO: Is this the right behavior?
157− Just currentParent -> do
158− let go = do
159− Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
160− _ <- removeChild currentParent $ Just x
161− liftJSM (strictEqual s x) >>= \case
162− True -> return ()
163− False -> go
164− go
165− _ <- removeChild currentParent $ Just e
166− return ()
167+deleteBetweenExclusive s e = liftJSM $ do
168+ f <- eval ("(function(s,e){ \
169+ p = e.parentNode; \
170+ if(p !== null) { \
171+ for(;;){ \
172+ x = e.previousSibling; \
173+ p.removeChild(x); \
174+ if(s===x) break; \
175+ } \
176+ p.removeChild(e); \
177+ }})" :: Text)
178+ void $ call f f (s, e)
179+
180+-- do
181+-- 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
182+-- case mCurrentParent of
183+-- Nothing -> return () --TODO: Is this the right behavior?
184+-- Just currentParent -> do
185+-- let go = do
186+-- x <- getPreviousSiblingUnchecked e -- This can't be Nothing because we should hit 's' first
187+-- removeChild_ currentParent $ Just x
188+-- liftJSM (strictEqual s x) >>= \case
189+-- True -> return ()
190+-- False -> go
191+-- go
192+-- removeChild_ currentParent $ Just e
193+-- return ()
167194
168195-- | 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
169196{-# INLINABLE deleteUpTo #-}
170197deleteUpTo :: (MonadJSM m, IsNode start, IsNode end) => start -> end -> m ()
171−deleteUpTo s e = do
172− 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
173− case mCurrentParent of
174− Nothing -> return () --TODO: Is this the right behavior?
175− Just currentParent -> deleteUpToGivenParent currentParent s e
198+deleteUpTo s e = liftJSM $ do
199+ f <- eval ("(function(s,e){ \
200+ p = e.parentNode; \
201+ if(p !== null) { \
202+ for(;;) { \
203+ x = e.previousSibling; \
204+ p.removeChild(x); \
205+ if(s===x) break; \
206+ } \
207+ }})" :: Text)
208+ void $ call f f (s, e)
209+-- do
210+-- 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
211+-- case mCurrentParent of
212+-- Nothing -> return () --TODO: Is this the right behavior?
213+-- Just currentParent -> deleteUpToGivenParent currentParent s e
176214
177215{-# INLINABLE deleteUpToGivenParent #-}
178216deleteUpToGivenParent :: (MonadJSM m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m ()
179−deleteUpToGivenParent currentParent s e = do
180− fix $ \loop -> do
181− Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
182− _ <- removeChild currentParent $ Just x
183− liftJSM (strictEqual s x) >>= \case
184− True -> return ()
185− False -> loop
217+deleteUpToGivenParent currentParent s e = liftJSM $ do
218+ f <- eval ("(function(p,s,e){ \
219+ for(;;){ \
220+ x = e.previousSibling; \
221+ p.removeChild(x); \
222+ if(s===x) break; \
223+ }})" :: Text)
224+ void $ call f f (currentParent, s, e)
225+--do
226+-- fix $ \loop -> do
227+-- x <- getPreviousSiblingUnchecked e -- This can't be Nothing because we should hit 's' first
228+-- removeChild_ currentParent $ Just x
229+-- liftJSM (strictEqual s x) >>= \case
230+-- True -> return ()
231+-- False -> loop
186232
187233type 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)
188234
@@ -232,9 +278,9 @@ makeElement :: forall er t m a. SupportsImmediateDomBuilder t m => Text -> Eleme
232278makeElement elementTag cfg child = do
233279 doc <- askDocument
234280 events <- askEvents
235− Just e <- liftJSM $ case cfg ^. namespace of
236− Nothing -> createElement doc (Just elementTag)
237− Just ens -> createElementNS doc (Just ens) (Just elementTag)
281+ e <- liftJSM $ case cfg ^. namespace of
282+ Nothing -> createElementUnchecked doc (Just elementTag)
283+ Just ens -> createElementNSUnchecked doc (Just ens) (Just elementTag)
238284 ImmediateDomBuilderT $ iforM_ (cfg ^. initialAttributes) $ \(AttributeName mAttrNamespace n) v -> case mAttrNamespace of
239285 Nothing -> lift $ setAttribute e n v
240286 Just ans -> lift $ setAttributeNS e (Just ans) n v
@@ -305,7 +351,7 @@ instance er ~ EventResult => Default (GhcjsEventSpec er) where
305351 def = GhcjsEventSpec
306352 { _ghcjsEventSpec_filters = mempty
307353 , _ghcjsEventSpec_handler = \(en, GhcjsDomEvent evt) -> do
308− Just (t :: DOM.EventTarget) <- withIsEvent en $ Event.getTarget evt --TODO: Rework this; defaultDomEventHandler shouldn't need to take this as an argument
354+ t :: DOM.EventTarget <- withIsEvent en $ Event.getTargetUnchecked evt --TODO: Rework this; defaultDomEventHandler shouldn't need to take this as an argument
309355 let e = uncheckedCastTo DOM.Element t
310356 runReaderT (defaultDomEventHandler e en) evt
311357 }
@@ -335,7 +381,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
335381 ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
336382 let domInputElement = uncheckedCastTo DOM.HTMLInputElement domElement
337383 Input.setValue domInputElement $ Just (cfg ^. inputElementConfig_initialValue)
338− Just v0 <- Input.getValue domInputElement
384+ v0 <- Input.getValueUnchecked domInputElement
339385 let getMyValue = fromMaybe "" <$> Input.getValue domInputElement
340386 valueChangedByUI <- performEvent $ getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
341387 valueChangedBySetValue <- performEvent $ ffor (cfg ^. inputElementConfig_setValue) $ \v' -> do
@@ -349,11 +395,12 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
349395 checkedChangedByUI <- wrapDomEvent domInputElement (`on` Element.click) $ do
350396 Input.getChecked domInputElement
351397 checkedChangedBySetChecked <- performEvent $ ffor (_inputElementConfig_setChecked cfg) $ \newChecked -> do
352− oldChecked <- Input.getChecked domInputElement
353− if newChecked /= oldChecked
354− then do Input.setChecked domInputElement newChecked
398+-- oldChecked <- Input.getChecked domInputElement
399+-- if newChecked /= oldChecked
400+-- then do
401+ Input.setChecked domInputElement newChecked
355402 return $ Just newChecked
356− else return Nothing
403+-- else return Nothing
357404 c <- holdDyn (_inputElementConfig_initialChecked cfg) $ leftmost
358405 [ fmapMaybe id checkedChangedBySetChecked
359406 , checkedChangedByUI
@@ -382,7 +429,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
382429 ((e, _), domElement) <- makeElement "textarea" (cfg ^. textAreaElementConfig_elementConfig) $ return ()
383430 let domTextAreaElement = uncheckedCastTo DOM.HTMLTextAreaElement domElement
384431 TextArea.setValue domTextAreaElement $ Just (cfg ^. textAreaElementConfig_initialValue)
385− Just v0 <- TextArea.getValue domTextAreaElement
432+ v0 <- TextArea.getValueUnchecked domTextAreaElement
386433 let getMyValue = fromMaybe "" <$> TextArea.getValue domTextAreaElement
387434 valueChangedByUI <- performEvent $ getMyValue <$ Reflex.select (_element_events e) (WrapArg Input)
388435 valueChangedBySetValue <- performEvent $ ffor (cfg ^. textAreaElementConfig_setValue) $ \v' -> do
@@ -432,13 +479,13 @@ instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, PerformEvent t m
432479 initialEnv <- ImmediateDomBuilderT ask
433480 before <- textNodeInternal ("" :: Text)
434481 -- We draw 'after' in this roundabout way to avoid using MonadFix
435− Just after <- createTextNode (_immediateDomBuilderEnv_document initialEnv) ("" :: Text)
482+ after <- createTextNodeUnchecked (_immediateDomBuilderEnv_document initialEnv) ("" :: Text)
436483 let drawInitialChild = do
437484 result <- a0
438485 append after
439486 return result
440487 (result0, result') <- lift $ runWithReplace (runImmediateDomBuilderT drawInitialChild initialEnv) $ ffor a' $ \child -> do
441− Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
488+ df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv
442489 result <- runImmediateDomBuilderT child $ initialEnv
443490 { _immediateDomBuilderEnv_parent = toNode df
444491 }
@@ -452,7 +499,7 @@ instance (Reflex t, MonadAdjust t m, MonadJSM m, MonadHold t m, PerformEvent t m
452499 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.
453500 drawChildUpdate :: ImmediateDomBuilderT t m a -> m (DOM.DocumentFragment, DOM.Text, a)
454501 drawChildUpdate child = do
455− Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
502+ df <- createDocumentFragmentUnchecked $ _immediateDomBuilderEnv_document initialEnv
456503 runImmediateDomBuilderT ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child) $ initialEnv
457504 { _immediateDomBuilderEnv_parent = toNode df
458505 }
@@ -491,8 +538,8 @@ insertImmediateAbove :: (IsNode placeholder, PerformEvent t m, MonadJSM (Perform
491538insertImmediateAbove n toInsertAbove = do
492539 events <- askEvents
493540 lift $ performEvent $ ffor toInsertAbove $ \new -> do
494− Just doc <- getOwnerDocument n
495− Just df <- createDocumentFragment doc
541+ doc <- getOwnerDocumentUnchecked n
542+ df <- createDocumentFragmentUnchecked doc
496543 result <- runImmediateDomBuilderT new $ ImmediateDomBuilderEnv
497544 { _immediateDomBuilderEnv_parent = toNode df
498545 , _immediateDomBuilderEnv_document = doc
@@ -503,10 +550,8 @@ insertImmediateAbove n toInsertAbove = do
503550
504551insertBefore :: (MonadJSM m, IsNode new, IsNode existing) => new -> existing -> m ()
505552insertBefore new existing = do
506− mp <- getParentNode existing
507− case mp of
508− Nothing -> trace "ImmediateDomBuilderT: placeholder: Warning: (getParentNode n) returned Nothing" $ return ()
509− 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
553+ p <- getParentNodeUnchecked existing
554+ 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
510555
511556instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where
512557 type Performable (ImmediateDomBuilderT t m) = Performable m