@@ -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 #-}
@@ -27,6 +28,7 @@ import Reflex.Host.Class
2728import Control.Concurrent.Chan
2829import Control.Lens hiding (element)
2930import Control.Monad.Exception
31+import Control.Monad.Primitive
3032import Control.Monad.Reader
3133import Control.Monad.Ref
3234import Control.Monad.Trans.Control
@@ -37,8 +39,12 @@ import qualified Data.Dependent.Map as DMap
3739import Data.Dependent.Sum
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)
@@ -74,6 +81,10 @@ data ImmediateDomBuilderEnv t
7481
7582newtype ImmediateDomBuilderT t m a = ImmediateDomBuilderT { unImmediateDomBuilderT :: ReaderT (ImmediateDomBuilderEnv t) m a } deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException, MonadAsyncException)
7683
84+instance PrimMonad m => PrimMonad (ImmediateDomBuilderT x m) where
85+ type PrimState (ImmediateDomBuilderT x m) = PrimState m
86+ primitive = lift . primitive
87+
7788instance MonadTransControl (ImmediateDomBuilderT t) where
7889 type StT (ImmediateDomBuilderT t) a = StT (ReaderT (ImmediateDomBuilderEnv t)) a
7990 liftWith = defaultLiftWith ImmediateDomBuilderT unImmediateDomBuilderT
@@ -117,19 +128,46 @@ textNodeInternal t = do
117128{-# INLINABLE deleteBetweenInclusive #-}
118129deleteBetweenInclusive :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m ()
119130deleteBetweenInclusive s e = do
131+ mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
132+ case mCurrentParent of
133+ Nothing -> return () --TODO: Is this the right behavior?
134+ Just currentParent -> do
135+ deleteUpToGivenParent currentParent s e
136+ _ <- removeChild currentParent $ Just e
137+ return ()
138+
139+-- | s and e must both be children of the same node and s must precede e
140+deleteBetweenExclusive :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m ()
141+deleteBetweenExclusive s e = do
120142 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
121143 case mCurrentParent of
122144 Nothing -> return () --TODO: Is this the right behavior?
123145 Just currentParent -> do
124146 let go = do
125147 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
148+ when (toNode s /= toNode x) $ do
149+ _ <- removeChild currentParent $ Just x
150+ go
128151 go
129− _ <- removeChild currentParent $ Just e
130− return ()
131152
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)
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
154+{-# INLINABLE deleteUpTo #-}
155+deleteUpTo :: (MonadIO m, IsNode start, IsNode end) => start -> end -> m ()
156+deleteUpTo s e = do
157+ mCurrentParent <- getParentNode e -- May be different than it was at initial construction, e.g., because the parent may have dumped us in from a DocumentFragment
158+ case mCurrentParent of
159+ Nothing -> return () --TODO: Is this the right behavior?
160+ Just currentParent -> deleteUpToGivenParent currentParent s e
161+
162+{-# INLINABLE deleteUpToGivenParent #-}
163+deleteUpToGivenParent :: (MonadIO m, IsNode parent, IsNode start, IsNode end) => parent -> start -> end -> m ()
164+deleteUpToGivenParent currentParent s e = do
165+ fix $ \loop -> do
166+ Just x <- getPreviousSibling e -- This can't be Nothing because we should hit 's' first
167+ _ <- removeChild currentParent $ Just x
168+ when (toNode s /= toNode x) loop
169+
170+type SupportsImmediateDomBuilder t m = (Reflex t, MonadIO m, MonadIO (Performable m), MonadHold t m, MonadFix m, PerformEvent t m, MonadReflexCreateTrigger t m, MonadRef m, Ref m ~ Ref IO, MonadAdjust t m)
133171
134172newtype EventFilterTriggerRef t er (en :: EventTag) = EventFilterTriggerRef (IORef (Maybe (EventTrigger t (er en))))
135173
@@ -248,6 +286,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
248286 return $ TextNode n
249287 {-# INLINABLE element #-}
250288 element elementTag cfg child = fst <$> makeElement elementTag cfg child
289+ {-
251290 {-# INLINABLE placeholder #-}
252291 placeholder (PlaceholderConfig toInsertAbove delete) = liftThrough (deletable delete) $ do
253292 n <- textNodeInternal ("" :: Text)
@@ -257,6 +296,7 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
257296 mp <- getParentNode n
258297 forM_ mp $ \p -> removeChild p $ Just n
259298 return $ Placeholder insertedAbove deleted
299+-}
260300 {-# INLINABLE inputElement #-}
261301 inputElement cfg = do
262302 ((e, _), domElement) <- makeElement "input" (cfg ^. inputElementConfig_elementConfig) $ return ()
@@ -354,6 +394,57 @@ instance SupportsImmediateDomBuilder t m => DomBuilder t (ImmediateDomBuilderT t
354394 placeRawElement = append
355395 wrapRawElement = wrap
356396
397+instance (Reflex t, MonadAdjust t m, MonadIO m, MonadHold t m, PerformEvent t m, MonadIO (Performable m)) => MonadAdjust t (ImmediateDomBuilderT t m) where
398+ runWithReplace a0 a' = do
399+ initialEnv <- ImmediateDomBuilderT ask
400+ before <- textNodeInternal ("" :: Text)
401+ -- We draw 'after' in this roundabout way to avoid using MonadFix
402+ Just after <- createTextNode (_immediateDomBuilderEnv_document initialEnv) ("" :: Text)
403+ let drawInitialChild = do
404+ result <- a0
405+ append after
406+ return result
407+ (result0, result') <- lift $ runWithReplace (runImmediateDomBuilderT drawInitialChild initialEnv) $ ffor a' $ \child -> do
408+ Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
409+ result <- runImmediateDomBuilderT child $ initialEnv
410+ { _immediateDomBuilderEnv_parent = toNode df
411+ }
412+ deleteBetweenExclusive before after
413+ insertBefore df after
414+ return result
415+ return (result0, result')
416+ sequenceDMapWithAdjust (dm0 :: DMap k (ImmediateDomBuilderT t m)) dm' = do
417+ initialEnv <- ImmediateDomBuilderT ask
418+ let drawChildInitial :: ImmediateDomBuilderT t m a -> m (DOM.DocumentFragment, DOM.Text, a)
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.
420+ drawChildUpdate :: ImmediateDomBuilderT t m a -> m (DOM.DocumentFragment, DOM.Text, a)
421+ drawChildUpdate child = do
422+ Just df <- createDocumentFragment $ _immediateDomBuilderEnv_document initialEnv
423+ runImmediateDomBuilderT ((,,) <$> pure df <*> textNodeInternal ("" :: Text) <*> child) $ initialEnv
424+ { _immediateDomBuilderEnv_parent = toNode df
425+ }
426+ updateChildren = ffor dm' $ \(PatchDMap p) -> PatchDMap $
427+ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> WrapArg k :=> ComposeMaybe (fmap drawChildUpdate mv)) p
428+ (children0, children') <- lift $ sequenceDMapWithAdjust (mapKeyValuePairsMonotonic (\(k :=> v) -> WrapArg k :=> drawChildInitial v) dm0) (updateChildren :: Event t (PatchDMap (WrapArg ((,,) DOM.DocumentFragment DOM.Text) k) m)) --TODO: Update stuff
429+ let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, _, v)) -> k :=> Identity v) children0
430+ placeholders0 = dmapToMap $ mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, ph, _)) -> Const2 (Some.This k) :=> Identity ph) children0
431+ result' = ffor children' $ \(PatchDMap p) -> PatchDMap $
432+ mapKeyValuePairsMonotonic (\(WrapArg k :=> v) -> k :=> fmap (\(_, _, r) -> r) v) p
433+ placeholders' = ffor children' $ \(PatchDMap p) -> PatchMap $
434+ dmapToMap $ mapKeyValuePairsMonotonic (\(WrapArg k :=> v) -> Const2 (Some.This k) :=> Identity (fmap ((\(_, ph, _) -> ph) . runIdentity) (getComposeMaybe v))) p
435+ placeholders :: Behavior t (Map (Some k) DOM.Text) <- current . incrementalToDynamic <$> holdIncremental placeholders0 placeholders'
436+ lastPlaceholder <- textNodeInternal ("" :: Text)
437+ performEvent_ $ flip push children' $ \(PatchDMap p) -> do
438+ phs <- sample placeholders
439+ if DMap.null p then return Nothing else return $ Just $ do
440+ let f :: DSum (WrapArg ((,,) DOM.DocumentFragment DOM.Text) k) (ComposeMaybe Identity) -> Performable m ()
441+ f (WrapArg k :=> ComposeMaybe mv) = do
442+ let nextPlaceholder = maybe lastPlaceholder snd $ Map.lookupGT (Some.This k) phs
443+ forM_ (Map.lookup (Some.This k) phs) $ \thisPlaceholder -> thisPlaceholder `deleteUpTo` nextPlaceholder
444+ forM_ mv $ \(Identity (df, _, _)) -> df `insertBefore` nextPlaceholder
445+ mapM_ f $ DMap.toList p
446+ return (result0, result')
447+
357448mkHasFocus :: (MonadHold t m, Reflex t) => Element er d t -> m (Dynamic t Bool)
358449mkHasFocus e = do
359450 let initialFocus = False --TODO: Actually get the initial focus of the element
@@ -363,7 +454,7 @@ mkHasFocus e = do
363454 ]
364455
365456{-# INLINABLE insertImmediateAbove #-}
366−insertImmediateAbove :: (Reflex t, IsNode placeholder, PerformEvent t m, MonadIO (Performable m)) => placeholder -> Event t (ImmediateDomBuilderT t (Performable m) a) -> ImmediateDomBuilderT t m (Event t a)
457+insertImmediateAbove :: (IsNode placeholder, PerformEvent t m, MonadIO (Performable m)) => placeholder -> Event t (ImmediateDomBuilderT t (Performable m) a) -> ImmediateDomBuilderT t m (Event t a)
367458insertImmediateAbove n toInsertAbove = do
368459 events <- askEvents
369460 lift $ performEvent $ ffor toInsertAbove $ \new -> do
@@ -374,21 +465,15 @@ insertImmediateAbove n toInsertAbove = do
374465 , _immediateDomBuilderEnv_document = doc
375466 , _immediateDomBuilderEnv_events = events
376467 }
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
468+ df `insertBefore` n
381469 return result
382470
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
471+insertBefore :: (MonadIO m, IsNode new, IsNode existing) => new -> existing -> m ()
472+insertBefore new existing = do
473+ mp <- getParentNode existing
474+ case mp of
475+ Nothing -> trace "ImmediateDomBuilderT: placeholder: Warning: (getParentNode n) returned Nothing" $ return ()
476+ Just p -> void $ DOM.insertBefore p (Just new) (Just existing) -- If there's no parent, that means we've been removed from the DOM; this should not happen if the we're removing ourselves from the performEvent properly
392477
393478instance PerformEvent t m => PerformEvent t (ImmediateDomBuilderT t m) where
394479 type Performable (ImmediateDomBuilderT t m) = Performable m
@@ -497,7 +582,7 @@ type family EventType en where
497582defaultDomEventHandler :: IsElement e => e -> EventName en -> EventM e (EventType en) (Maybe (EventResult en))
498583defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
499584 Click -> return ()
500− Dblclick -> return ()
585+ Dblclick -> getMouseEventCoords
501586 Keypress -> getKeyEvent
502587 Scroll -> getScrollTop e
503588 Keydown -> getKeyEvent
@@ -547,7 +632,7 @@ defaultDomEventHandler e evt = fmap (Just . EventResult) $ case evt of
547632defaultDomWindowEventHandler :: DOM.Window -> EventName en -> EventM DOM.Window (EventType en) (Maybe (EventResult en))
548633defaultDomWindowEventHandler w evt = fmap (Just . EventResult) $ case evt of
549634 Click -> return ()
550− Dblclick -> return ()
635+ Dblclick -> getMouseEventCoords
551636 Keypress -> getKeyEvent
552637 Scroll -> Window.getScrollY w
553638 Keydown -> getKeyEvent
@@ -796,7 +881,7 @@ getKeyEvent = do
796881getMouseEventCoords :: EventM e MouseEvent (Int, Int)
797882getMouseEventCoords = do
798883 e <- event
799− bisequence (getX e, getY e)
884+ bisequence (getClientX e, getClientY e)
800885
801886instance MonadSample t m => MonadSample t (ImmediateDomBuilderT t m) where
802887 {-# INLINABLE sample #-}