@@ -9,6 +9,7 @@
99{-# LANGUAGE OverloadedStrings #-}
1010{-# LANGUAGE PolyKinds #-}
1111{-# LANGUAGE RankNTypes #-}
12+{-# LANGUAGE RecursiveDo #-}
1213{-# LANGUAGE ScopedTypeVariables #-}
1314{-# LANGUAGE TemplateHaskell #-}
1415{-# LANGUAGE TypeFamilies #-}
@@ -35,10 +36,15 @@ import Data.Default
3536import Data.Dependent.Map (DMap)
3637import qualified Data.Dependent.Map as DMap
3738import Data.Dependent.Sum
39+import Data.Functor.Compose
3840import Data.Functor.Misc
3941import Data.IORef
42+import Data.Map (Map)
43+import qualified Data.Map as Map
4044import Data.Maybe
4145import Data.Monoid
46+import Data.Some (Some)
47+import qualified Data.Some as Some
4248import Data.Text (Text)
4349import GHCJS.DOM.Document (Document, createDocumentFragment, createElement, createElementNS, createTextNode)
4450import GHCJS.DOM.Element (getScrollTop, removeAttribute, removeAttributeNS, setAttribute, setAttributeNS)
@@ -51,8 +57,9 @@ import qualified GHCJS.DOM.HTMLInputElement as Input
5157import qualified GHCJS.DOM.HTMLSelectElement as Select
5258import qualified GHCJS.DOM.HTMLTextAreaElement as TextArea
5359import GHCJS.DOM.MouseEvent
54−import GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling, insertBefore,
60+import GHCJS.DOM.Node (appendChild, getOwnerDocument, getParentNode, getPreviousSibling,
5561 removeChild, setNodeValue, toNode)
62+import qualified GHCJS.DOM.Node as DOM
5663import GHCJS.DOM.Types (FocusEvent, IsElement, IsEvent, IsNode, KeyboardEvent, Node, ToDOMString, TouchEvent,
5764 WheelEvent, castToHTMLInputElement, castToHTMLSelectElement,
5865 castToHTMLTextAreaElement)
@@ -121,15 +128,28 @@ deleteBetweenInclusive s e = do
121128 case mCurrentParent of
122129 Nothing -> return () --TODO: Is this the right behavior?
123130 Just currentParent -> do
124− let go = do
125− Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
126− _ <- removeChild currentParent $ Just x
127− when (toNode s /= toNode x) go
128− go
131+ deleteUpToGivenParent currentParent s e
129132 _ <- removeChild currentParent $ Just e
130133 return ()
131134
132−type SupportsImmediateDomBuilder t m = (Reflex t, MonadIO m, MonadHold t m, MonadFix m, PerformEvent t m, Performable m ~ m, MonadReflexCreateTrigger t m, Deletable t m, MonadRef m, Ref m ~ Ref IO)
135+-- | 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
136+{-# INLINABLE deleteUpTo #-}
137+deleteUpTo :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m ()
138+deleteUpTo s e = do
139+ 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
140+ case mCurrentParent of
141+ Nothing -> return () --TODO: Is this the right behavior?
142+ Just currentParent -> deleteUpToGivenParent currentParent s e
143+
144+{-# INLINABLE deleteUpToGivenParent #-}
145+deleteUpToGivenParent :: (MonadIO m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m ()
146+deleteUpToGivenParent currentParent s e = do
147+ fix $ \loop -> do
148+ Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
149+ _ <- removeChild currentParent $ Just x
150+ when (toNode s /= toNode x) loop
151+
152+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)
133153
134154newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))
135155
@@ -248,6 +268,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
248268 return $ TextNode n
249269 {-# INLINABLE element #-}
250270 element elementTag cfg child = fst <$> makeElement elementTag cfg child
271+ {-
251272 {-# INLINABLE placeholder #-}
252273 placeholder (PlaceholderConfig toInsertAbove delete) = liftThrough (deletable delete) $ do
253274 n <- textNodeInternal ("" :: Text)
@@ -257,6 +278,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
257278 mp <- getParentNode n
258279 forM_ mp $ \p -> removeChild p $ Just n
259280 return $ Placeholder insertedAbove deleted
281+-}
260282 {-# INLINABLE inputElement #-}
261283 inputElement cfg = do
262284 ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
@@ -354,6 +376,39 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
354376 placeRawElement = append
355377 wrapRawElement = wrap
356378
379+instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, PerformEvent t m, MonadIO (Performable m)) => MonadAdjust t (ImmediateDomBuilderT t m) where
380+ sequenceDMapWithAdjust (dm0 :: DMap k (ImmediateDomBuilderT t m)) dm' = do
381+ initialEnv <- ImmediateDomBuilderT ask
382+ let drawChildInitial :: ImmediateDomBuilderT t m a -> m (DOM.DocumentFragment, DOM.Text, a)
383+ 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.
384+ drawChildUpdate :: ImmediateDomBuilderT t m a -> m (DOM.DocumentFragment, DOM.Text, a)
385+ drawChildUpdate child = do
386+ Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
387+ runImmediateDomBuilderT ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child) $ initialEnv
388+ { _immediateDomBuilderEnv_parent = toNode df
389+ }
390+ updateChildren = ffor dm' $ \(PatchDMap p) -> PatchDMap $
391+ mapKeyValuePairsMonotonic (\(k :=> Compose mv) -> WrapArg k :=> Compose (fmap drawChildUpdate mv)) p
392+ (children0, children') <- lift $ sequenceDMapWithAdjust (mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> drawChildInitial v) dm0) (updateChildren :: Event t (PatchDMap (DMap (WrapArg ((,,) DOM.DocumentFragment DOM.Text) k) m))) --TODO: Update stuff
393+ let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, _, v)) -> k :=> Identity v) children0
394+ placeholders0 = dmapToMap $ mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, ph, _)) -> Const2 (Some.This k) :=> Identity ph) children0
395+ result' = ffor children' $ \(PatchDMap p) -> PatchDMap $
396+ mapKeyValuePairsMonotonic (\(WrapArg k :=> v) -> k :=> fmap (\(_, _, r) -> r) v) p
397+ placeholders' = ffor children' $ \(PatchDMap p) -> PatchMap $
398+ dmapToMap $ mapKeyValuePairsMonotonic (\(WrapArg k :=> v) -> Const2 (Some.This k) :=> Identity (fmap ((\(_, ph, _) -> ph) . runIdentity) (getCompose v))) p
399+ placeholders :: Behavior t (Map (Some k) DOM.Text) <- current . incrementalToDynamic <$> holdIncremental placeholders0 placeholders'
400+ lastPlaceholder <- textNodeInternal ("" :: Text)
401+ performEvent_ $ flip push children' $ \(PatchDMap p) -> do
402+ phs <- sample placeholders
403+ if DMap.null p then return Nothing else return $ Just $ do
404+ let f :: DSum (WrapArg ((,,) DOM.DocumentFragment DOM.Text) k) (Compose Maybe Identity) -> Performable m ()
405+ f (WrapArg k :=> Compose mv) = do
406+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
407+ forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
408+ forM_ mv $ \(Identity (df, _, _)) -> df `insertBefore` nextPlaceholder
409+ mapM_ f $ DMap.toList p
410+ return (result0, result')
411+
357412mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)
358413mkHasFocus e = do
359414 let initialFocus = False --TODO: Actually get the initial focus of the element
@@ -374,21 +429,15 @@ insertImmediateAbove n toInsertAbove = do
374429 , _immediateDomBuilderEnv_document = doc
375430 , _immediateDomBuilderEnv_events = events
376431 }
377− mp <- getParentNode n
378− case mp of
379− Nothing -> trace "ImmediateDomBuilderT: placeholder: Warning: (getParentNode n) returned Nothing" $ return ()
380− Just p -> void $ insertBefore p (Just df) (Just n) -- 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
432+ df `insertBefore` n
381433 return result
382434
383−instance SupportsImmediateDomBuilder t m => Deletable t (ImmediateDomBuilderT t m) where
384− {-# INLINABLE deletable #-}
385− deletable delete child = liftThrough (deletable delete) $ do
386− top <- textNodeInternal ("" :: Text)
387− result <- child
388− bottom <- textNodeInternal ("" :: Text)
389− lift $ performEvent_ $ ffor delete $ \_ -> do
390− deleteBetweenInclusive top bottom
391− return result
435+insertBefore :: (MonadIO m, IsNode new, IsNode existing) => new -> existing -> m ()
436+insertBefore new existing = do
437+ mp <- getParentNode existing
438+ case mp of
439+ Nothing -> trace "ImmediateDomBuilderT: placeholder: Warning: (getParentNode n) returned Nothing" $ return ()
440+ 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
392441
393442instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where
394443 type Performable (ImmediateDomBuilderT t m) = Performable m